-withLockedDistDir
- :: HasEnvConfig env
+withLockedDistDir ::
+ HasEnvConfig env
=> (Utf8Builder -> RIO env ()) -- ^ announce
-> Path Abs Dir -- ^ root directory for package
-> RIO env a
@@ -1129,12 +1142,12 @@
case taskType of
TTLocalMutable lp | lpWanted lp ->
liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)
- _ -> return ()
+ _ -> pure ()
withBinaryFile fp WriteMode $ \h -> inner $ OTLogFile logPath h
- withCabal
- :: Package
+ withCabal ::
+ Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a)
@@ -1157,7 +1170,7 @@
-- types, see:
-- https://github.com/commercialhaskell/stack/issues/370
case (packageBuildType package, eeSetupExe) of
- (C.Simple, Just setupExe) -> return $ Left setupExe
+ (C.Simple, Just setupExe) -> pure $ Left setupExe
_ -> liftIO $ Right <$> getSetupHs pkgDir
inner $ \keepOutputOpen stripTHLoading args -> do
let cabalPackageArg
@@ -1188,7 +1201,7 @@
, fromString $ packageNameString $ packageName package
, flow "uses a custom Cabal build, but does not use a custom-setup stanza"
]
- _ -> return ()
+ _ -> pure ()
getPackageArgs :: Path Abs Dir -> RIO env [String]
getPackageArgs setupDir =
@@ -1212,17 +1225,17 @@
x:xs -> do
unless (null xs)
(logWarn ("Found multiple installed packages for custom-setup dep: " <> fromString (packageNameString name)))
- return ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))
+ pure ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))
[] -> do
logWarn ("Could not find custom-setup dep: " <> fromString (packageNameString name))
- return ("-package=" ++ packageNameString name, Nothing)
+ pure ("-package=" ++ packageNameString name, Nothing)
let depsArgs = map fst matchedDeps
-- Generate setup_macros.h and provide it to ghc
let macroDeps = mapMaybe snd matchedDeps
cppMacrosFile = setupDir relFileSetupMacrosH
cppArgs = ["-optP-include", "-optP" ++ toFilePath cppMacrosFile]
writeBinaryFileAtomic cppMacrosFile (encodeUtf8Builder (T.pack (C.generatePackageVersionMacros (packageVersion package) macroDeps)))
- return (packageDBArgs ++ depsArgs ++ cppArgs)
+ pure (packageDBArgs ++ depsArgs ++ cppArgs)
-- This branch is usually taken for builds, and
-- is always taken for `stack sdist`.
@@ -1243,7 +1256,7 @@
-- stack.yaml file.
Nothing -> do
warnCustomNoDeps
- return $ cabalPackageArg ++
+ pure $ cabalPackageArg ++
-- NOTE: This is different from
-- packageDBArgs above in that it does not
-- include the local database and does not
@@ -1261,10 +1274,10 @@
runAndOutput compilerVer `catch` \ece -> do
(mlogFile, bss) <-
case outputType of
- OTConsole _ -> return (Nothing, [])
+ OTConsole _ -> pure (Nothing, [])
OTLogFile logFile h ->
if keepOutputOpen == KeepOpen
- then return (Nothing, []) -- expected failure build continues further
+ then pure (Nothing, []) -- expected failure build continues further
else do
liftIO $ hClose h
fmap (Just logFile,) $ withSourceFile (toFilePath logFile) $ \src ->
@@ -1273,7 +1286,7 @@
.| CT.decodeUtf8Lenient
.| mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer
.| CL.consume
- throwM $ CabalExitedUnsuccessfully
+ throwM $ PrettyException $ CabalExitedUnsuccessfully
(eceExitCode ece)
taskProvides
exeName
@@ -1296,8 +1309,8 @@
void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs
(outputSink KeepTHLoading LevelWarn compilerVer prefix)
(outputSink stripTHLoading LevelInfo compilerVer prefix)
- outputSink
- :: HasCallStack
+ outputSink ::
+ HasCallStack
=> ExcludeTHLoading
-> LogLevel
-> ActualCompiler
@@ -1306,7 +1319,7 @@
outputSink excludeTH level compilerVer prefix =
CT.decodeUtf8Lenient
.| mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer
- .| CL.mapM_ (logGeneric "" level . (prefix <>) . RIO.display)
+ .| CL.mapM_ (logGeneric "" level . (prefix <>) . display)
-- If users want control, we should add a config option for this
makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute = case stripTHLoading of
@@ -1314,14 +1327,14 @@
KeepTHLoading -> KeepPathsAsIs
exeName <- case esetupexehs of
- Left setupExe -> return setupExe
+ Left setupExe -> pure setupExe
Right setuphs -> do
distDir <- distDirFromDir pkgDir
let setupDir = distDir relDirSetup
outputFile = setupDir relFileSetupLower
customBuilt <- liftIO $ readIORef eeCustomBuilt
if Set.member (packageName package) customBuilt
- then return outputFile
+ then pure outputFile
else do
ensureDir setupDir
compilerPath <- view $ compilerPathsL.to cpCompiler
@@ -1351,7 +1364,7 @@
liftIO $ atomicModifyIORef' eeCustomBuilt $
\oldCustomBuilt -> (Set.insert (packageName package) oldCustomBuilt, ())
- return outputFile
+ pure outputFile
let cabalVerboseArg =
let CabalVerbosity cv = boptsCabalVerbose eeBuildOpts
in "--verbose=" <> showForCabal cv
@@ -1390,7 +1403,7 @@
mcurator <- view $ buildConfigL.to bcCurator
realConfigAndBuild cache mcurator allDepsMap
case minstalled of
- Nothing -> return ()
+ Nothing -> pure ()
Just installed -> do
writeFlagCache installed cache
liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed
@@ -1410,7 +1423,7 @@
eres <- tryAny $ action KeepOpen
case eres of
Right () -> logWarn $ fromString (packageNameString pname) <> ": unexpected Haddock success"
- Left _ -> return ()
+ Left _ -> pure ()
fulfillHaddockExpectations _ action = do
action CloseOnException
@@ -1450,25 +1463,25 @@
(configCacheHaddock cache)
(configCacheDeps cache)
case mpc of
- Nothing -> return Nothing
+ Nothing -> pure Nothing
-- Only pay attention to precompiled caches that refer to packages within
-- the snapshot.
Just pc | maybe False
(bcoSnapInstallRoot eeBaseConfigOpts `isProperPrefixOf`)
(pcLibrary pc) ->
- return Nothing
+ pure Nothing
-- If old precompiled cache files are left around but snapshots are deleted,
-- it is possible for the precompiled file to refer to the very library
-- we're building, and if flags are changed it may try to copy the library
-- to itself. This check prevents that from happening.
Just pc -> do
- let allM _ [] = return True
+ let allM _ [] = pure True
allM f (x:xs) = do
b <- f x
- if b then allM f xs else return False
+ if b then allM f xs else pure False
b <- liftIO $ allM doesFileExist $ maybe id (:) (pcLibrary pc) $ pcExes pc
- return $ if b then Just pc else Nothing
- _ -> return Nothing
+ pure $ if b then Just pc else Nothing
+ _ -> pure Nothing
copyPreCompiled (PrecompiledCache mlib sublibs exes) = do
wc <- view $ actualCompilerVersionL.whichCompilerL
@@ -1507,7 +1520,7 @@
-- first unregister everything that needs to be unregistered
forM_ allToUnregister $ \packageName -> catchAny
(readProcessNull (toFilePath ghcPkgExe) [ "unregister", "--force", packageName])
- (const (return ()))
+ (const (pure ()))
-- now, register the cached conf files
forM_ allToRegister $ \libpath ->
@@ -1519,17 +1532,17 @@
createLink (toFilePath exe) (toFilePath dst) `catchIO` \_ -> copyFile exe dst
case (mlib, exes) of
(Nothing, _:_) -> markExeInstalled (taskLocation task) taskProvides
- _ -> return ()
+ _ -> pure ()
-- Find the package in the database
let pkgDbs = [bcoSnapDB eeBaseConfigOpts]
case mlib of
- Nothing -> return $ Just $ Executable taskProvides
+ Nothing -> pure $ Just $ Executable taskProvides
Just _ -> do
mpkgid <- loadInstalledPkg pkgDbs eeSnapshotDumpPkgs pname
- return $ Just $
+ pure $ Just $
case mpkgid of
Nothing -> assert False $ Executable taskProvides
Just pkgid -> Library taskProvides pkgid Nothing
@@ -1545,7 +1558,7 @@
("Building all executables for `" <> fromString (packageNameString (packageName package)) <>
"' once. After a successful build of all of them, only specified executables will be rebuilt."))
- _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> RIO.display (annSuffix executableBuildStatuses))) cabal cabalfp task
+ _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> display (annSuffix executableBuildStatuses))) cabal cabalfp task
let installedMapHasThisPkg :: Bool
installedMapHasThisPkg =
case Map.lookup (packageName package) installedMap of
@@ -1559,19 +1572,19 @@
-- because their configure step will require that this
-- package is built. See
-- https://github.com/commercialhaskell/stack/issues/2787
- (True, _) | null acDownstream -> return Nothing
+ (True, _) | null acDownstream -> pure Nothing
(_, True) | null acDownstream || installedMapHasThisPkg -> do
initialBuildSteps executableBuildStatuses cabal announce
- return Nothing
+ pure Nothing
_ -> fulfillCuratorBuildExpectations pname mcurator enableTests enableBenchmarks Nothing $
Just <$> realBuild cache package pkgDir cabal0 announce executableBuildStatuses
initialBuildSteps executableBuildStatuses cabal announce = do
- announce ("initial-build-steps" <> RIO.display (annSuffix executableBuildStatuses))
+ announce ("initial-build-steps" <> display (annSuffix executableBuildStatuses))
cabal KeepTHLoading ["repl", "stack-initial-build-steps"]
- realBuild
- :: ConfigCache
+ realBuild ::
+ ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
@@ -1589,7 +1602,7 @@
caches <- runMemoizedWith $ lpNewBuildCaches lp
mapM_ (uncurry (writeBuildCache pkgDir))
(Map.toList caches)
- TTRemotePackage{} -> return ()
+ TTRemotePackage{} -> pure ()
-- FIXME: only output these if they're in the build plan.
@@ -1598,8 +1611,8 @@
TTLocalMutable lp -> do
warnings <- checkForUnlistedFiles taskType pkgDir
-- TODO: Perhaps only emit these warnings for non extra-dep?
- return (Just (lpCabalFile lp, warnings))
- _ -> return Nothing
+ pure (Just (lpCabalFile lp, warnings))
+ _ -> pure Nothing
-- NOTE: once
-- https://github.com/commercialhaskell/stack/issues/2649
-- is resolved, we will want to partition the warnings
@@ -1608,16 +1621,29 @@
"- In" <+>
fromString (T.unpack (renderComponent comp)) <>
":" <> line <>
- indent 4 (mconcat $ intersperse line $ map (style Good . fromString . C.display) modules)
+ indent 4 ( mconcat
+ $ L.intersperse line
+ $ map
+ (style Good . fromString . C.display)
+ modules
+ )
forM_ mlocalWarnings $ \(cabalfp, warnings) -> do
unless (null warnings) $ prettyWarn $
- "The following modules should be added to exposed-modules or other-modules in" <+>
- pretty cabalfp <> ":" <> line <>
- indent 4 (mconcat $ intersperse line $ map showModuleWarning warnings) <>
- line <> line <>
- "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems."
+ flow "The following modules should be added to \
+ \exposed-modules or other-modules in" <+>
+ pretty cabalfp
+ <> ":"
+ <> line
+ <> indent 4 ( mconcat
+ $ L.intersperse line
+ $ map showModuleWarning warnings
+ )
+ <> blankLine
+ <> flow "Missing modules in the Cabal file are likely \
+ \to cause undefined reference errors from the \
+ \linker, along with other problems."
- () <- announce ("build" <> RIO.display (annSuffix executableBuildStatuses))
+ () <- announce ("build" <> display (annSuffix executableBuildStatuses))
config <- view configL
extraOpts <- extraBuildOptions wc eeBuildOpts
let stripTHLoading
@@ -1625,20 +1651,21 @@
| otherwise = KeepTHLoading
cabal stripTHLoading (("build" :) $ (++ extraOpts) $
case (taskType, taskAllInOne, isFinalBuild) of
- (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step."
+ (_, True, True) -> throwM AllInOneBuildBug
(TTLocalMutable lp, False, False) -> primaryComponentOptions executableBuildStatuses lp
(TTLocalMutable lp, False, True) -> finalComponentOptions lp
(TTLocalMutable lp, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp
(TTRemotePackage{}, _, _) -> [])
`catch` \ex -> case ex of
- CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex
+ CabalExitedUnsuccessfully{} ->
+ postBuildCheck False >> throwM (PrettyException ex)
_ -> throwM ex
postBuildCheck True
mcurator <- view $ buildConfigL.to bcCurator
when (doHaddock mcurator package) $ do
announce "haddock"
- sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then return [] else do
+ sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then pure [] else do
-- See #2429 for why the temp dir is used
ec
<- withWorkingDir (toFilePath eeTempDir)
@@ -1651,14 +1678,14 @@
*> Concurrently (waitExitCode p)
case ec of
-- Fancy crosslinked source
- ExitSuccess -> return ["--haddock-option=--hyperlinked-source"]
+ ExitSuccess -> pure ["--haddock-option=--hyperlinked-source"]
-- Older hscolour colouring
ExitFailure _ -> do
hscolourExists <- doesExecutableExist "HsColour"
unless hscolourExists $ logWarn
("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <>
"found on PATH (use 'stack install hscolour' to install).")
- return ["--hyperlink-source" | hscolourExists]
+ pure ["--hyperlink-source" | hscolourExists]
-- For GHC 8.4 and later, provide the --quickjump option.
actualCompiler <- view actualCompilerVersionL
@@ -1690,8 +1717,10 @@
eres <- try $ cabal KeepTHLoading ["copy"]
case eres of
Left err@CabalExitedUnsuccessfully{} ->
- throwM $ CabalCopyFailed (packageBuildType package == C.Simple) (show err)
- _ -> return ()
+ throwM $ CabalCopyFailed
+ (packageBuildType package == C.Simple)
+ (displayException err)
+ _ -> pure ()
when hasLibrary $ cabal KeepTHLoading ["register"]
-- copy ddump-* files
@@ -1705,12 +1734,12 @@
runConduitRes
$ CF.sourceDirectoryDeep False (toFilePath distDir)
- .| CL.filter (isInfixOf ".dump-")
+ .| CL.filter (L.isInfixOf ".dump-")
.| CL.mapM_ (\src -> liftIO $ do
parentDir <- parent <$> parseRelDir src
destBaseDir <- (ddumpDir ) <$> stripProperPrefix distDir parentDir
-- exclude .stack-work dir
- unless (".stack-work" `isInfixOf` toFilePath destBaseDir) $ do
+ unless (".stack-work" `L.isInfixOf` toFilePath destBaseDir) $ do
ensureDir destBaseDir
src' <- parseRelFile src
copyFile src' (destBaseDir filename src'))
@@ -1725,7 +1754,7 @@
( bcoLocalDB eeBaseConfigOpts
, eeLocalDumpPkgs )
let ident = PackageIdentifier (packageName package) (packageVersion package)
- -- only return the sublibs to cache them if we also cache the main lib (that is, if it exists)
+ -- only pure the sublibs to cache them if we also cache the main lib (that is, if it exists)
(mpkgid, sublibsPkgIds) <- case packageLibraries package of
HasLibraries _ -> do
sublibsPkgIds <- fmap catMaybes $
@@ -1733,16 +1762,16 @@
-- z-haddock-library-z-attoparsec for internal lib attoparsec of haddock-library
let sublibName = T.concat ["z-", T.pack $ packageNameString $ packageName package, "-z-", sublib]
case parsePackageName $ T.unpack sublibName of
- Nothing -> return Nothing -- invalid lib, ignored
+ Nothing -> pure Nothing -- invalid lib, ignored
Just subLibName -> loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar subLibName
mpkgid <- loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar (packageName package)
case mpkgid of
Nothing -> throwM $ Couldn'tFindPkgId $ packageName package
- Just pkgid -> return (Library ident pkgid Nothing, sublibsPkgIds)
+ Just pkgid -> pure (Library ident pkgid Nothing, sublibsPkgIds)
NoLibraries -> do
markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache?
- return (Executable ident, []) -- don't return sublibs in this case
+ pure (Executable ident, []) -- don't pure sublibs in this case
case taskType of
TTRemotePackage Immutable _ loc ->
@@ -1753,7 +1782,7 @@
(configCacheHaddock cache)
(configCacheDeps cache)
mpkgid sublibsPkgIds (packageExes package)
- _ -> return ()
+ _ -> pure ()
case taskType of
-- For packages from a package index, pkgDir is in the tmp
@@ -1762,19 +1791,19 @@
TTRemotePackage{} -> do
let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining)
when (null remaining) $ removeDirRecur pkgDir
- TTLocalMutable{} -> return ()
+ TTLocalMutable{} -> pure ()
- return mpkgid
+ pure mpkgid
loadInstalledPkg pkgDbs tvar name = do
pkgexe <- getGhcPkgExe
dps <- ghcPkgDescribe pkgexe name pkgDbs $ conduitDumpPackage .| CL.consume
case dps of
- [] -> return Nothing
+ [] -> pure Nothing
[dp] -> do
liftIO $ atomically $ modifyTVar' tvar (Map.insert (dpGhcPkgId dp) dp)
- return $ Just (dpGhcPkgId dp)
- _ -> error $ "singleBuild: invariant violated: multiple results when describing installed package " ++ show (name, dps)
+ pure $ Just (dpGhcPkgId dp)
+ _ -> throwM $ MulipleResultsBug name dps
-- | Get the build status of all the package executables. Do so by
-- testing whether their expected output file exists, e.g.
@@ -1782,8 +1811,8 @@
-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha
-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.exe
-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.jsexe/ (NOTE: a dir)
-getExecutableBuildStatuses
- :: HasEnvConfig env
+getExecutableBuildStatuses ::
+ HasEnvConfig env
=> Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses package pkgDir = do
distDir <- distDirFromDir pkgDir
@@ -1793,8 +1822,8 @@
(mapM (checkExeStatus platform distDir) (Set.toList (packageExes package)))
-- | Check whether the given executable is defined in the given dist directory.
-checkExeStatus
- :: HasLogFunc env
+checkExeStatus ::
+ HasLogFunc env
=> Platform
-> Path b Dir
-> Text
@@ -1820,7 +1849,11 @@
file = T.unpack name
-- | Check if any unlisted files have been found, and add them to the build cache.
-checkForUnlistedFiles :: HasEnvConfig env => TaskType -> Path Abs Dir -> RIO env [PackageWarning]
+checkForUnlistedFiles ::
+ HasEnvConfig env
+ => TaskType
+ -> Path Abs Dir
+ -> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable lp) pkgDir = do
caches <- runMemoizedWith $ lpNewBuildCaches lp
(addBuildCache,warnings) <-
@@ -1833,8 +1866,8 @@
let cache = Map.findWithDefault Map.empty component caches
writeBuildCache pkgDir component $
Map.unions (cache : newToCache)
- return warnings
-checkForUnlistedFiles TTRemotePackage{} _ = return []
+ pure warnings
+checkForUnlistedFiles TTRemotePackage{} _ = pure []
-- | Implements running a package's tests. Also handles producing
-- coverage reports if coverage is enabled.
@@ -1861,23 +1894,23 @@
if toDisableRun topts
then do
announce "Test running disabled by --no-run-tests flag."
- return False
+ pure False
else if toRerunTests topts
- then return True
+ then pure True
else do
status <- getTestStatus pkgDir
case status of
TSSuccess -> do
unless (null testsToRun) $ announce "skipping already passed test"
- return False
+ pure False
TSFailure
| expectFailure -> do
announce "skipping already failed test that's expected to fail"
- return False
+ pure False
| otherwise -> do
announce "rerunning previously failed test"
- return True
- TSUnknown -> return True
+ pure True
+ TSUnknown -> pure True
when toRun $ do
buildDir <- distDirFromDir pkgDir
@@ -1895,8 +1928,8 @@
let stestName = T.unpack testName
(testName', isTestTypeLib) <-
case suiteInterface of
- C.TestSuiteLibV09{} -> return (stestName ++ "Stub", True)
- C.TestSuiteExeV10{} -> return (stestName, False)
+ C.TestSuiteLibV09{} -> pure (stestName ++ "Stub", True)
+ C.TestSuiteExeV10{} -> pure (stestName, False)
interface -> throwM (TestSuiteTypeUnsupported interface)
let exeName = testName' ++
@@ -1919,10 +1952,10 @@
Just (Library _ ghcPkgId _) -> [ghcPkgId]
_ -> []
-- doctest relies on template-haskell in QuickCheck-based tests
- thGhcId <- case find ((== "template-haskell") . pkgName . dpPackageIdent. snd)
+ thGhcId <- case L.find ((== "template-haskell") . pkgName . dpPackageIdent. snd)
(Map.toList $ eeGlobalDumpPkgs ee) of
- Just (ghcId, _) -> return ghcId
- Nothing -> error "template-haskell is a wired-in GHC boot library but it wasn't found"
+ Just (ghcId, _) -> pure ghcId
+ Nothing -> throwIO TemplateHaskellNotFoundBug
-- env variable GHC_ENVIRONMENT is set for doctest so module names for
-- packages with proper dependencies should no longer get ambiguous
-- see e.g. https://github.com/doctest/issues/119
@@ -1944,7 +1977,7 @@
"global-package-db\n" <>
"package-db " <> fromString snapDBPath <> "\n" <>
"package-db " <> fromString localDBPath <> "\n" <>
- foldMap (\ghcId -> "package-id " <> RIO.display (unGhcPkgId ghcId) <> "\n")
+ foldMap (\ghcId -> "package-id " <> display (unGhcPkgId ghcId) <> "\n")
(pkgGhcIdList ++ thGhcId:M.elems allDepsMap)
writeFileUtf8Builder fp ghcEnv
menv <- liftIO $ setEnv fp =<< configProcessContextSettings config EnvSettings
@@ -1968,7 +2001,7 @@
argsDisplay = case args of
[] -> ""
_ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
- announce $ "test (suite: " <> RIO.display testName <> RIO.display argsDisplay <> ")"
+ announce $ "test (suite: " <> display testName <> display argsDisplay <> ")"
-- Clear "Progress: ..." message before
-- redirecting output.
@@ -1987,7 +2020,7 @@
CT.decodeUtf8Lenient .|
CT.lines .|
CL.map stripCR .|
- CL.mapM_ (\t -> logInfo $ prefix <> RIO.display t))
+ CL.mapM_ (\t -> logInfo $ prefix <> display t))
createSource
OTLogFile _ h -> Nothing <$ useHandleOpen h
optionalTimeout action
@@ -1997,16 +2030,22 @@
mec <- withWorkingDir (toFilePath pkgDir) $
optionalTimeout $ proc (toFilePath exePath) args $ \pc0 -> do
- stdinBS <-
+ changeStdin <-
if isTestTypeLib
then do
logPath <- buildLogPath package (Just stestName)
ensureDir (parent logPath)
- pure $ BL.fromStrict
+ pure $ setStdin
+ $ byteStringInput
+ $ BL.fromStrict
$ encodeUtf8 $ fromString $
show (logPath, mkUnqualComponentName (T.unpack testName))
- else pure mempty
- let pc = setStdin (byteStringInput stdinBS)
+ else do
+ isTerminal <- view $ globalOptsL.to globalTerminal
+ if toAllowStdin topts && isTerminal
+ then pure id
+ else pure $ setStdin $ byteStringInput mempty
+ let pc = changeStdin
$ setStdout output
$ setStderr output
pc0
@@ -2026,28 +2065,28 @@
-- tidiness.
when needHpc $
updateTixFile (packageName package) tixPath testName'
- let announceResult result = announce $ "Test suite " <> RIO.display testName <> " " <> result
+ let announceResult result = announce $ "Test suite " <> display testName <> " " <> result
case mec of
Just ExitSuccess -> do
announceResult "passed"
- return Map.empty
+ pure Map.empty
Nothing -> do
announceResult "timed out"
if expectFailure
- then return Map.empty
- else return $ Map.singleton testName Nothing
+ then pure Map.empty
+ else pure $ Map.singleton testName Nothing
Just ec -> do
announceResult "failed"
if expectFailure
- then return Map.empty
- else return $ Map.singleton testName (Just ec)
+ then pure Map.empty
+ else pure $ Map.singleton testName (Just ec)
else do
unless expectFailure $ logError $ displayShow $ TestSuiteExeMissing
(packageBuildType package == C.Simple)
exeName
(packageNameString (packageName package))
(T.unpack testName)
- return emptyResult
+ pure emptyResult
when needHpc $ do
let testsToRun' = map f testsToRun
@@ -2059,7 +2098,7 @@
bs <- liftIO $
case outputType of
- OTConsole _ -> return ""
+ OTConsole _ -> pure ""
OTLogFile logFile h -> do
hClose h
S.readFile $ toFilePath logFile
@@ -2095,9 +2134,9 @@
if beoDisableRun beopts
then do
announce "Benchmark running disabled by --no-run-benchmarks flag."
- return False
+ pure False
else do
- return True
+ pure True
when toRun $ do
announce "benchmarks"
@@ -2157,11 +2196,11 @@
if isValidSuffix y
then liftIO $ liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $
forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) `catch`
- \(_ :: PathException) -> return Nothing
- else return Nothing
+ \(_ :: PathException) -> pure Nothing
+ else pure Nothing
case mabs of
- Nothing -> return bs
- Just fp -> return $ fp `T.append` y
+ Nothing -> pure bs
+ Just fp -> pure $ fp `T.append` y
doNothing :: ConduitM Text Text m ()
doNothing = awaitForever yield
@@ -2170,11 +2209,11 @@
isValidSuffix = isRight . parseOnly lineCol
lineCol = char ':'
>> choice
- [ num >> char ':' >> num >> optional (char '-' >> num) >> return ()
- , char '(' >> num >> char ',' >> num >> string ")-(" >> num >> char ',' >> num >> char ')' >> return ()
+ [ num >> char ':' >> num >> optional (char '-' >> num) >> pure ()
+ , char '(' >> num >> char ',' >> num >> P.string ")-(" >> num >> char ',' >> num >> char ')' >> pure ()
]
>> char ':'
- >> return ()
+ >> pure ()
where num = some digit
-- | Whether to prefix log lines with timestamps.
@@ -2206,11 +2245,11 @@
getSetupHs dir = do
exists1 <- doesFileExist fp1
if exists1
- then return fp1
+ then pure fp1
else do
exists2 <- doesFileExist fp2
if exists2
- then return fp2
+ then pure fp2
else throwM $ NoSetupHsFound dir
where
fp1 = dir relFileSetupHs
@@ -2228,9 +2267,9 @@
if toCoverage (boptsTestOpts bopts)
then do
hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir
- return [optsFlag, "-hpcdir " ++ hpcIndexDir ++ baseOpts]
+ pure [optsFlag, "-hpcdir " ++ hpcIndexDir ++ baseOpts]
else
- return [optsFlag, baseOpts]
+ pure [optsFlag, baseOpts]
-- Library, internal and foreign libraries and executable build components.
primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String]
@@ -2308,15 +2347,15 @@
case eres of
Right res -> do
logWarn $ fromString (packageNameString pname) <> ": unexpected test build success"
- return res
- Left _ -> return defValue
+ pure res
+ Left _ -> pure defValue
fulfillCuratorBuildExpectations pname mcurator _ enableBench defValue action | enableBench &&
expectBenchmarkFailure pname mcurator = do
eres <- tryAny action
case eres of
Right res -> do
logWarn $ fromString (packageNameString pname) <> ": unexpected benchmark build success"
- return res
- Left _ -> return defValue
+ pure res
+ Left _ -> pure defValue
fulfillCuratorBuildExpectations _ _ _ _ _ action = do
action
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
@@ -3,7 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Generate haddocks
@@ -16,26 +16,25 @@
, shouldHaddockDeps
) where
-import Stack.Prelude
import qualified Data.Foldable as F
import qualified Data.HashSet as HS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
-import Data.Time (UTCTime)
+import Data.Time ( UTCTime )
import Path
import Path.Extra
import Path.IO
-import RIO.List (intercalate)
-import RIO.PrettyPrint
+import RIO.List ( intercalate )
+import RIO.Process
import Stack.Constants
import Stack.PackageDump
+import Stack.Prelude
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import qualified System.FilePath as FP
-import RIO.Process
-import Web.Browser (openBrowser)
+import Web.Browser ( openBrowser )
openHaddocksInBrowser
:: HasTerm env
@@ -51,13 +50,13 @@
let localDocs = haddockIndexFile (localDepsDocDir bco)
localExists <- doesFileExist localDocs
if localExists
- then return localDocs
+ then pure localDocs
else do
let snapDocs = haddockIndexFile (snapDocDir bco)
snapExists <- doesFileExist snapDocs
if snapExists
- then return snapDocs
- else throwString "No local or snapshot doc index found to open."
+ then pure snapDocs
+ else throwIO HaddockIndexNotFound
docFile <-
case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of
([_], [Just (pkgId, iloc)]) -> do
@@ -69,7 +68,7 @@
let docFile = haddockIndexFile (docLocation pkgRelDir)
exists <- doesFileExist docFile
if exists
- then return docFile
+ then pure docFile
else do
logWarn $
"Expected to find documentation at " <>
@@ -79,7 +78,7 @@
_ -> getDocIndex
prettyInfo $ "Opening" <+> pretty docFile <+> "in the browser."
_ <- liftIO $ openBrowser (toFilePath docFile)
- return ()
+ pure ()
-- | Determine whether we should haddock for a package.
shouldHaddockPackage :: BuildOpts
@@ -107,7 +106,7 @@
generateLocalHaddockIndex bco localDumpPkgs locals = do
let dumpPackages =
mapMaybe
- (\LocalPackage{lpPackage = Package{..}} ->
+ (\LocalPackage{lpPackage = Package{packageName, packageVersion}} ->
F.find
(\dp -> dpPackageIdent dp == PackageIdentifier packageName packageVersion)
localDumpPkgs)
@@ -139,7 +138,7 @@
depDocDir
where
getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
- getGhcPkgId LocalPackage{lpPackage = Package{..}} =
+ getGhcPkgId LocalPackage{lpPackage = Package{packageName, packageVersion}} =
let pkgId = PackageIdentifier packageName packageVersion
mdpPkg = F.find (\dp -> dpPackageIdent dp == pkgId) localDumpPkgs
in fmap dpGhcPkgId mdpPkg
@@ -219,9 +218,9 @@
fromString (toFilePath destIndexFile)
where
toInterfaceOpt :: DumpPackage -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
- toInterfaceOpt DumpPackage {..} =
+ toInterfaceOpt DumpPackage {dpHaddockInterfaces, dpPackageIdent, dpHaddockHtml} =
case dpHaddockInterfaces of
- [] -> return Nothing
+ [] -> pure Nothing
srcInterfaceFP:_ -> do
srcInterfaceAbsFile <- parseCollapsedAbsFile srcInterfaceFP
let (PackageIdentifier name _) = dpPackageIdent
@@ -236,7 +235,7 @@
destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP)
esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile
- return $
+ pure $
case esrcInterfaceModTime of
Left _ -> Nothing
Right srcInterfaceModTime ->
@@ -258,7 +257,7 @@
Left _ -> doCopy
Right destInterfaceModTime
| destInterfaceModTime < srcInterfaceModTime -> doCopy
- | otherwise -> return ()
+ | otherwise -> pure ()
where
doCopy = do
ignoringAbsence (removeDirRecur destHtmlAbsDir)
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
@@ -16,7 +16,6 @@
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Set as Set
-import Data.List
import qualified Data.Map.Strict as Map
import Path
import Stack.Build.Cache
@@ -35,15 +34,15 @@
projectInstalls <-
for (smProject sourceMap) $ \pp -> do
version <- loadVersion (ppCommon pp)
- return (Local, version)
+ pure (Local, version)
depInstalls <-
for (smDeps sourceMap) $ \dp ->
case dpLocation dp of
PLImmutable pli -> pure (Snap, getPLIVersion pli)
PLMutable _ -> do
version <- loadVersion (dpCommon dp)
- return (Local, version)
- return $ projectInstalls <> depInstalls
+ pure (Local, version)
+ pure $ projectInstalls <> depInstalls
-- | Returns the new InstalledMap and all of the locally registered packages.
getInstalled :: HasEnvConfig env
@@ -99,7 +98,7 @@
, installedLibs
]
- return ( installedMap
+ pure ( installedMap
, globalDumpPkgs
, snapshotDumpPkgs
, localDumpPkgs
@@ -126,7 +125,7 @@
lhDeps
const
(lhs0 ++ lhs1)
- return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)
+ pure (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)
where
mloc = fmap fst mdb
sinkDP = CL.map (isAllowed installMap mloc &&& toLoadHelper mloc)
@@ -139,7 +138,7 @@
=> Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper)
-> RIO env (Maybe LoadHelper)
-processLoadResult _ (Allowed, lh) = return (Just lh)
+processLoadResult _ (Allowed, lh) = pure (Just lh)
processLoadResult mdb (reason, lh) = do
logDebug $
"Ignoring package " <>
@@ -154,7 +153,7 @@
fromString (versionString wanted) <>
" instead of " <>
fromString (versionString actual)
- return Nothing
+ pure Nothing
data Allowed
= Allowed
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
@@ -23,7 +23,7 @@
import Data.ByteString.Builder (toLazyByteString)
import Conduit (ZipSink (..), withSourceFile)
import qualified Distribution.PackageDescription as C
-import Data.List
+import qualified Data.List as L
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
@@ -36,6 +36,7 @@
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Package
+import Stack.Types.PackageFile
import Stack.Types.SourceMap
import System.FilePath (takeFileName)
import System.IO.Error (isDoesNotExistError)
@@ -57,7 +58,7 @@
PLMutable dir -> do
pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)
Just <$> loadLocalPackage pp
- _ -> return Nothing
+ _ -> pure Nothing
-- | Given the parsed targets and build command line options constructs
-- a source map
@@ -107,7 +108,7 @@
logDebug "Checking flags"
checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps
logDebug "SourceMap constructed"
- return
+ pure
SourceMap
{ smTargets = smt
, smCompiler = compiler
@@ -153,12 +154,12 @@
bootGhcOpts = map display (generalGhcOptions bc boptsCli False False)
hashedContent = toLazyByteString $ compilerPath <> compilerInfo <>
getUtf8Builder (mconcat bootGhcOpts) <> mconcat immDeps
- return $ SourceMapHash (SHA256.hashLazyBytes hashedContent)
+ pure $ SourceMapHash (SHA256.hashLazyBytes hashedContent)
depPackageHashableContent :: (HasConfig env) => DepPackage -> RIO env Builder
depPackageHashableContent DepPackage {..} = do
case dpLocation of
- PLMutable _ -> return ""
+ PLMutable _ -> pure ""
PLImmutable pli -> do
let flagToBs (f, enabled) =
if enabled
@@ -169,7 +170,7 @@
cabalConfigOpts = map display (cpCabalConfigOpts dpCommon)
haddocks = if cpHaddocks dpCommon then "haddocks" else ""
hash = immutableLocSha pli
- return $ hash <> haddocks <> getUtf8Builder (mconcat flags) <>
+ pure $ hash <> haddocks <> getUtf8Builder (mconcat flags) <>
getUtf8Builder (mconcat ghcOptions) <>
getUtf8Builder (mconcat cabalConfigOpts)
@@ -250,7 +251,7 @@
loadCommonPackage common = do
config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common)
gpkg <- liftIO $ cpGPD common
- return $ resolvePackage config gpkg
+ pure $ resolvePackage config gpkg
-- | Upgrade the initial project package info to a full-blown @LocalPackage@
-- based on the selected components
@@ -315,25 +316,13 @@
{ packageConfigEnableTests = not $ Set.null tests
, packageConfigEnableBenchmarks = not $ Set.null benches
}
- testconfig = config
- { packageConfigEnableTests = True
- , packageConfigEnableBenchmarks = False
- }
- benchconfig = config
- { packageConfigEnableTests = False
- , packageConfigEnableBenchmarks = True
- }
- -- We resolve the package in 4 different configurations:
+ -- We resolve the package in 2 different configurations:
--
-- - pkg doesn't have tests or benchmarks enabled.
--
-- - btpkg has them enabled if they are present.
--
- -- - testpkg has tests enabled, but not benchmarks.
- --
- -- - benchpkg has benchmarks enabled, but not tests.
- --
-- The latter two configurations are used to compute the deps
-- when --enable-benchmarks or --enable-tests are configured.
-- This allows us to do an optimization where these are passed
@@ -343,8 +332,6 @@
btpkg
| Set.null tests && Set.null benches = Nothing
| otherwise = Just (resolvePackage btconfig gpkg)
- testpkg = resolvePackage testconfig gpkg
- benchpkg = resolvePackage benchconfig gpkg
componentFiles <- memoizeRefWith $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents
@@ -355,7 +342,7 @@
checkCacheResult <- checkBuildCache
(fromMaybe Map.empty mbuildCache)
(Set.toList files)
- return (component, checkCacheResult)
+ pure (component, checkCacheResult)
let dirtyFiles = do
checkCacheResults' <- checkCacheResults
@@ -363,17 +350,15 @@
pure $
if not (Set.null allDirtyFiles)
then let tryStripPrefix y =
- fromMaybe y (stripPrefix (toFilePath $ ppRoot pp) y)
+ fromMaybe y (L.stripPrefix (toFilePath $ ppRoot pp) y)
in Just $ Set.map tryStripPrefix allDirtyFiles
else Nothing
newBuildCaches =
M.fromList . map (\(c, (_, cache)) -> (c, cache))
<$> checkCacheResults
- return LocalPackage
+ pure LocalPackage
{ lpPackage = pkg
- , lpTestDeps = dvVersionRange <$> packageDeps testpkg
- , lpBenchDeps = dvVersionRange <$> packageDeps benchpkg
, lpTestBench = btpkg
, lpComponentFiles = componentFiles
, lpBuildHaddocks = cpHaddocks (ppCommon pp)
@@ -404,7 +389,7 @@
checkBuildCache oldCache files = do
fileTimes <- liftM Map.fromList $ forM files $ \fp -> do
mdigest <- liftIO (getFileDigestMaybe (toFilePath fp))
- return (toFilePath fp, mdigest)
+ pure (toFilePath fp, mdigest)
liftM (mconcat . Map.elems) $ sequence $
Map.mergeWithKey
(\fp mdigest fci -> Just (go fp mdigest (Just fci)))
@@ -415,16 +400,16 @@
where
go :: FilePath -> Maybe SHA256 -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo)
-- Filter out the cabal_macros file to avoid spurious recompilations
- go fp _ _ | takeFileName fp == "cabal_macros.h" = return (Set.empty, Map.empty)
+ go fp _ _ | takeFileName fp == "cabal_macros.h" = pure (Set.empty, Map.empty)
-- Common case where it's in the cache and on the filesystem.
go fp (Just digest') (Just fci)
- | fciHash fci == digest' = return (Set.empty, Map.singleton fp fci)
- | otherwise = return (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest')
+ | fciHash fci == digest' = pure (Set.empty, Map.singleton fp fci)
+ | otherwise = pure (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest')
-- Missing file. Add it to dirty files, but no FileCacheInfo.
- go fp Nothing _ = return (Set.singleton fp, Map.empty)
+ go fp Nothing _ = pure (Set.singleton fp, Map.empty)
-- Missing cache. Add it to dirty files and compute FileCacheInfo.
go fp (Just digest') Nothing =
- return (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest')
+ pure (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest')
-- | Returns entries to add to the build cache for any newly found unlisted modules
addUnlistedToBuildCache
@@ -442,14 +427,14 @@
Set.toList $
Set.map toFilePath files `Set.difference` Map.keysSet buildCache
addBuildCache <- mapM addFileToCache newFiles
- return ((component, addBuildCache), warnings)
- return (M.fromList (map fst results), concatMap snd results)
+ pure ((component, addBuildCache), warnings)
+ pure (M.fromList (map fst results), concatMap snd results)
where
addFileToCache fp = do
mdigest <- getFileDigestMaybe fp
case mdigest of
- Nothing -> return Map.empty
- Just digest' -> return . Map.singleton fp $ FileCacheInfo digest'
+ Nothing -> pure Map.empty
+ Just digest' -> pure . Map.singleton fp $ FileCacheInfo digest'
-- | Gets list of Paths for files relevant to a set of components in a package.
-- Note that the library component, if any, is always automatically added to the
@@ -468,7 +453,7 @@
componentsFiles =
M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath $ Set.fromList files)) $
M.filterWithKey (\component _ -> component `elem` components) compFiles
- return (componentsFiles, warnings)
+ pure (componentsFiles, warnings)
-- | Get file digest, if it exists
getFileDigestMaybe :: MonadIO m => FilePath -> m (Maybe SHA256)
@@ -478,7 +463,7 @@
(liftM Just . withSourceFile fp $ getDigest)
(\e ->
if isDoesNotExistError e
- then return Nothing
+ then pure Nothing
else throwM e))
where
getDigest src = runConduit $ src .| getZipSink (ZipSink SHA256.sinkHash)
@@ -493,7 +478,7 @@
getPackageConfig flags ghcOptions cabalConfigOpts = do
platform <- view platformL
compilerVersion <- view actualCompilerVersionL
- return PackageConfig
+ pure PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = flags
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
@@ -58,28 +58,28 @@
-- Finally, we upgrade the snapshot by using
-- calculatePackagePromotion.
module Stack.Build.Target
- ( -- * Types
- Target (..)
- , NeedTargets (..)
- , PackageType (..)
- , parseTargets
- -- * Convenience helpers
- , gpdVersion
- -- * Test suite exports
- , parseRawTarget
- , RawTarget (..)
- , UnresolvedComponent (..)
- ) where
+ ( -- * Types
+ Target (..)
+ , NeedTargets (..)
+ , PackageType (..)
+ , parseTargets
+ -- * Convenience helpers
+ , gpdVersion
+ -- * Test suite exports
+ , parseRawTarget
+ , RawTarget (..)
+ , UnresolvedComponent (..)
+ ) where
-import Stack.Prelude
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Path
-import Path.Extra (rejectMissingDir)
+import Path.Extra ( rejectMissingDir )
import Path.IO
-import RIO.Process (HasProcessContext)
+import RIO.Process ( HasProcessContext )
import Stack.SourceMap
+import Stack.Prelude
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Build
@@ -142,18 +142,18 @@
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs root locals ri =
case parseRawTarget t of
- Just rt -> return $ Right [(ri, rt)]
+ Just rt -> pure $ Right [(ri, rt)]
Nothing -> do
mdir <- liftIO $ forgivingAbsence (resolveDir root (T.unpack t))
>>= rejectMissingDir
case mdir of
- Nothing -> return $ Left $ "Directory not found: " `T.append` t
+ Nothing -> pure $ Left $ "Directory not found: " `T.append` t
Just dir ->
case mapMaybe (childOf dir) $ Map.toList locals of
- [] -> return $ Left $
+ [] -> pure $ Left $
"No local directories found as children of " `T.append`
t
- names -> return $ Right $ map ((ri, ) . RTPackage) names
+ names -> pure $ Right $ map ((ri, ) . RTPackage) names
where
childOf dir (name, pp) =
if dir == ppRoot pp || isProperPrefixOf dir (ppRoot pp)
@@ -298,7 +298,7 @@
]
go (RTPackage name)
- | Map.member name locals = return $ Right ResolveResult
+ | Map.member name locals = pure $ Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
@@ -319,7 +319,7 @@
-- files!
go (RTPackageIdentifier ident@(PackageIdentifier name version))
- | Map.member name locals = return $ Left $ T.concat
+ | Map.member name locals = pure $ Left $ T.concat
[ tshow (packageNameString name)
, " target has a specific version number, but it is a local package."
, "\nTo avoid confusion, we will not install the specified version or build the local one."
@@ -380,7 +380,7 @@
, rrPackageType = PTDependency
}
- -- This is actually an error case. We _could_ return a
+ -- This is actually an error case. We _could_ pure a
-- Left value here, but it turns out to be better to defer
-- this until the ConstructPlan phase, and let it complain
-- about the missing package so that we get more errors
@@ -404,9 +404,9 @@
combineResolveResults results = do
addedDeps <- fmap Map.unions $ forM results $ \result ->
case rrAddedDep result of
- Nothing -> return Map.empty
+ Nothing -> pure Map.empty
Just pl -> do
- return $ Map.singleton (rrName result) pl
+ pure $ Map.singleton (rrName result) pl
let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results
(errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) ->
@@ -425,7 +425,7 @@
, T.unwords $ map (unRawInput . rrRaw) rrs
]
- return (errs, Map.unions ms, addedDeps)
+ pure (errs, Map.unions ms, addedDeps)
---------------------------------------------------------------------------------
-- OK, let's do it!
@@ -455,12 +455,12 @@
(errs3, targets, addedDeps) <- combineResolveResults resolveResults
case concat [errs1, errs2, errs3] of
- [] -> return ()
+ [] -> pure ()
errs -> throwIO $ TargetParseException errs
case (Map.null targets, needTargets) of
- (False, _) -> return ()
- (True, AllowNoTargets) -> return ()
+ (False, _) -> pure ()
+ (True, AllowNoTargets) -> pure ()
(True, NeedTargets)
| null textTargets' && bcImplicitGlobal bconfig -> throwIO $ TargetParseException
["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
@@ -471,7 +471,7 @@
addedDeps' <- mapM (additionalDepPackage haddockDeps . PLImmutable) addedDeps
- return SMTargets
+ pure SMTargets
{ smtTargets = targets
, smtDeps = addedDeps'
}
diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs
--- a/src/Stack/BuildPlan.hs
+++ b/src/Stack/BuildPlan.hs
@@ -14,7 +14,7 @@
( BuildPlanException (..)
, BuildPlanCheck (..)
, checkSnapBuildPlan
- , DepError(..)
+ , DepError (..)
, DepErrors
, removeSrcPkgDefaultFlags
, selectBestSnapshot
@@ -37,7 +37,6 @@
import Distribution.Text (display)
import Distribution.Types.UnqualComponentName (unUnqualComponentName)
import qualified Distribution.Version as C
-import qualified RIO
import Stack.Constants
import Stack.Package
import Stack.SourceMap
@@ -46,6 +45,8 @@
import Stack.Types.Config
import Stack.Types.Compiler
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.BuildPlan" module.
data BuildPlanException
= UnknownPackages
(Path Abs File) -- stack.yaml file
@@ -53,17 +54,20 @@
(Map PackageName (Set PackageIdentifier)) -- shadowed
| SnapshotNotFound SnapName
| NeitherCompilerOrResolverSpecified T.Text
- deriving (Typeable)
-instance Exception BuildPlanException
-instance Show BuildPlanException where
- show (SnapshotNotFound snapName) = unlines
- [ "SnapshotNotFound " ++ snapName'
+ | DuplicatePackagesBug
+ deriving (Show, Typeable)
+
+instance Exception BuildPlanException where
+ displayException (SnapshotNotFound snapName) = unlines
+ [ "Error: [S-2045]"
+ , "SnapshotNotFound " ++ snapName'
, "Non existing resolver: " ++ snapName' ++ "."
, "For a complete list of available snapshots see https://www.stackage.org/snapshots"
]
- where snapName' = show snapName
- show (UnknownPackages stackYaml unknown shadowed) =
- unlines $ unknown' ++ shadowed'
+ where snapName' = show snapName
+ displayException (UnknownPackages stackYaml unknown shadowed) =
+ "Error: [S-7571]\n"
+ ++ unlines (unknown' ++ shadowed')
where
unknown' :: [String]
unknown'
@@ -115,7 +119,7 @@
, ["Note: further dependencies may need to be added"]
]
where
- go (dep, users) | Set.null users = packageNameString dep ++ " (internal stack error: this should never be null)"
+ go (dep, users) | Set.null users = packageNameString dep ++ " (internal Stack error: this should never be null)"
go (dep, users) = concat
[ packageNameString dep
, " (used by "
@@ -129,10 +133,14 @@
$ Set.toList
$ Set.unions
$ Map.elems shadowed
- show (NeitherCompilerOrResolverSpecified url) =
- "Failed to load custom snapshot at " ++
- T.unpack url ++
- ", because no 'compiler' or 'resolver' is specified."
+ displayException (NeitherCompilerOrResolverSpecified url) = concat
+ [ "Error: [S-8559]\n"
+ , "Failed to load custom snapshot at "
+ , T.unpack url
+ , ", because no 'compiler' or 'resolver' is specified."
+ ]
+ displayException DuplicatePackagesBug = bugReport "[S-5743]"
+ "Duplicate packages are not expected here."
gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription)
@@ -307,7 +315,7 @@
flags' f gpd = fromMaybe Map.empty (Map.lookup (gpdPackageName gpd) f)
pool' = Map.union (gpdPackages gpds) pool
- dupError _ _ = error "Bug: Duplicate packages are not expected here"
+ dupError _ _ = impureThrow DuplicatePackagesBug
data BuildPlanCheck =
BuildPlanCheckOk (Map PackageName (Map FlagName Bool))
@@ -362,11 +370,11 @@
cerrs = compilerErrors compiler errs
if Map.null errs then
- return $ BuildPlanCheckOk f
+ pure $ BuildPlanCheckOk f
else if Map.null cerrs then do
- return $ BuildPlanCheckPartial f errs
+ pure $ BuildPlanCheckPartial f errs
else
- return $ BuildPlanCheckFail f cerrs compiler
+ pure $ BuildPlanCheckFail f cerrs compiler
where
compilerErrors compiler errs
| whichCompiler compiler == Ghc = ghcErrors errs
@@ -383,40 +391,56 @@
-> NonEmpty SnapName
-> RIO env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot pkgDirs snaps = do
- logInfo $ "Selecting the best among "
- <> displayShow (NonEmpty.length snaps)
- <> " snapshots...\n"
+ prettyInfo $
+ fillSep
+ [ flow "Selecting the best among"
+ , fromString $ show (NonEmpty.length snaps)
+ , "snapshots..."
+ ]
+ <> line
F.foldr1 go (NonEmpty.map (getResult <=< snapshotLocation) snaps)
where
go mold mnew = do
old@(_snap, _loc, bpc) <- mold
case bpc of
- BuildPlanCheckOk {} -> return old
+ BuildPlanCheckOk {} -> pure old
_ -> fmap (betterSnap old) mnew
getResult loc = do
candidate <- loadProjectSnapshotCandidate loc NoPrintWarnings False
result <- checkSnapBuildPlan pkgDirs Nothing candidate
reportResult result loc
- return (candidate, loc, result)
+ pure (candidate, loc, result)
betterSnap (s1, l1, r1) (s2, l2, r2)
| compareBuildPlanCheck r1 r2 /= LT = (s1, l1, r1)
| otherwise = (s2, l2, r2)
- reportResult BuildPlanCheckOk {} loc = do
- logInfo $ "* Matches " <> RIO.display loc
- logInfo ""
-
- reportResult r@BuildPlanCheckPartial {} loc = do
- logWarn $ "* Partially matches " <> RIO.display loc
- logWarn $ RIO.display $ indent $ T.pack $ show r
+ reportResult BuildPlanCheckOk {} loc =
+ prettyNote $
+ fillSep
+ [ flow "Matches"
+ , pretty $ PrettyRawSnapshotLocation loc
+ ]
+ <> line
- reportResult r@BuildPlanCheckFail {} loc = do
- logWarn $ "* Rejected " <> RIO.display loc
- logWarn $ RIO.display $ indent $ T.pack $ show r
+ reportResult r@BuildPlanCheckPartial {} loc =
+ prettyWarn $
+ fillSep
+ [ flow "Partially matches"
+ , pretty $ PrettyRawSnapshotLocation loc
+ ]
+ <> blankLine
+ <> indent 4 (string (show r))
- indent t = T.unlines $ fmap (" " <>) (T.lines t)
+ reportResult r@BuildPlanCheckFail {} loc =
+ prettyWarn $
+ fillSep
+ [ flow "Rejected"
+ , pretty $ PrettyRawSnapshotLocation loc
+ ]
+ <> blankLine
+ <> indent 4 (string (show r))
showItems :: [String] -> Text
showItems items = T.concat (map formatItem items)
diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs
--- a/src/Stack/Clean.hs
+++ b/src/Stack/Clean.hs
@@ -6,38 +6,58 @@
-- | Clean a project.
module Stack.Clean
- (clean
- ,CleanOpts(..)
- ,CleanCommand(..)
- ,StackCleanException(..)
- ) where
+ ( clean
+ , CleanOpts (..)
+ , CleanCommand (..)
+ ) where
-import Stack.Prelude
-import Data.List ((\\),intercalate)
+import Data.List ( (\\), intercalate )
import qualified Data.Map.Strict as Map
-import Path.IO (ignoringAbsence, removeDirRecur)
-import Stack.Config (withBuildConfig)
-import Stack.Constants.Config (rootDistDirFromDir, workDirFromDir)
+import Path.IO ( ignoringAbsence, removeDirRecur )
+import Stack.Config ( withBuildConfig )
+import Stack.Constants.Config ( rootDistDirFromDir, workDirFromDir )
+import Stack.Prelude
import Stack.Types.Config
import Stack.Types.SourceMap
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Clean" module.
+data CleanException
+ = NonLocalPackages [PackageName]
+ | DeletionFailures [(Path Abs Dir, SomeException)]
+ deriving (Show, Typeable)
+
+instance Exception CleanException where
+ displayException (NonLocalPackages pkgs) = concat
+ [ "Error: [S-9463]\n"
+ , "The following packages are not part of this project: "
+ , intercalate ", " (map show pkgs)
+ ]
+ displayException (DeletionFailures failures) = concat
+ [ "Error: [S-6321]\n"
+ , "Exception while recursively deleting:\n"
+ , concatMap (\(dir, e) ->
+ toFilePath dir <> "\n" <> displayException e <> "\n") failures
+ , "Perhaps you do not have permission to delete these files or they \
+ \are in use?"
+ ]
+
-- | Deletes build artifacts in the current project.
---
--- Throws 'StackCleanException'.
clean :: CleanOpts -> RIO Config ()
clean cleanOpts = do
toDelete <- withBuildConfig $ dirsToDelete cleanOpts
logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete))
- failures <- mapM cleanDir toDelete
- when (or failures) exitFailure
- where
- cleanDir dir = do
- logDebug $ "Deleting directory: " <> fromString (toFilePath dir)
- liftIO (ignoringAbsence (removeDirRecur dir) >> return False) `catchAny` \ex -> do
- logError $ "Exception while recursively deleting " <> fromString (toFilePath dir) <> "\n" <> displayShow ex
- logError "Perhaps you do not have permission to delete these files or they are in use?"
- return True
+ failures <- catMaybes <$> mapM cleanDir toDelete
+ case failures of
+ [] -> pure ()
+ _ -> throwIO $ DeletionFailures failures
+cleanDir :: Path Abs Dir -> RIO Config (Maybe (Path Abs Dir, SomeException))
+cleanDir dir = do
+ logDebug $ "Deleting directory: " <> fromString (toFilePath dir)
+ liftIO (ignoringAbsence (removeDirRecur dir) >> pure Nothing) `catchAny` \ex ->
+ pure $ Just (dir, ex)
+
dirsToDelete :: CleanOpts -> RIO BuildConfig [Path Abs Dir]
dirsToDelete cleanOpts = do
packages <- view $ buildConfigL.to (smwProject . bcSMWanted)
@@ -54,7 +74,7 @@
CleanFull -> do
pkgWorkDirs <- mapM (workDirFromDir . ppRoot) $ Map.elems packages
projectWorkDir <- getProjectWorkDir
- return (projectWorkDir : pkgWorkDirs)
+ pure (projectWorkDir : pkgWorkDirs)
-- | Options for @stack clean@.
data CleanOpts
@@ -69,15 +89,3 @@
data CleanCommand
= Clean
| Purge
-
--- | Exceptions during cleanup.
-newtype StackCleanException
- = NonLocalPackages [PackageName]
- deriving (Typeable)
-
-instance Show StackCleanException where
- show (NonLocalPackages pkgs) =
- "The following packages are not part of this project: " ++
- intercalate ", " (map show pkgs)
-
-instance Exception StackCleanException
diff --git a/src/Stack/ComponentFile.hs b/src/Stack/ComponentFile.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/ComponentFile.hs
@@ -0,0 +1,561 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | A module which exports all component-level file-gathering logic. It also
+-- includes utility functions for handling paths and directories.
+
+module Stack.ComponentFile
+ ( resolveOrWarn
+ , libraryFiles
+ , executableFiles
+ , testFiles
+ , benchmarkFiles
+ , componentOutputDir
+ , componentBuildDir
+ , packageAutogenDir
+ , buildDir
+ , componentAutogenDir
+ ) where
+
+import Control.Exception ( throw )
+import Data.List ( find, isPrefixOf )
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Distribution.ModuleName ( ModuleName )
+import qualified Distribution.ModuleName as Cabal
+import Distribution.Package
+ hiding
+ ( Module, Package, PackageIdentifier, packageName
+ , packageVersion
+ )
+import Distribution.PackageDescription hiding ( FlagName )
+import Distribution.Text ( display )
+import Distribution.Utils.Path ( getSymbolicPath )
+import Distribution.Version ( mkVersion )
+import qualified HiFileParser as Iface
+import Path as FL hiding ( replaceExtension )
+import Path.Extra
+import Path.IO hiding ( findFiles )
+import Stack.Constants
+import Stack.Prelude hiding ( Display (..) )
+import Stack.Types.Config
+import Stack.Types.NamedComponent
+import Stack.Types.Package
+import Stack.Types.PackageFile
+ ( GetPackageFileContext (..), DotCabalDescriptor (..)
+ , DotCabalPath (..), PackageWarning (..)
+ )
+import qualified System.Directory as D ( doesFileExist )
+import qualified System.FilePath as FilePath
+
+-- | Get all files referenced by the benchmark.
+benchmarkFiles
+ :: NamedComponent
+ -> Benchmark
+ -> RIO
+ GetPackageFileContext
+ (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
+benchmarkFiles component bench = do
+ resolveComponentFiles component build names
+ where
+ names = bnames <> exposed
+ exposed =
+ case benchmarkInterface bench of
+ BenchmarkExeV10 _ fp -> [DotCabalMain fp]
+ BenchmarkUnsupported _ -> []
+ bnames = map DotCabalModule (otherModules build)
+ build = benchmarkBuildInfo bench
+
+-- | Get all files referenced by the test.
+testFiles
+ :: NamedComponent
+ -> TestSuite
+ -> RIO
+ GetPackageFileContext
+ (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
+testFiles component test = do
+ resolveComponentFiles component build names
+ where
+ names = bnames <> exposed
+ exposed =
+ case testInterface test of
+ TestSuiteExeV10 _ fp -> [DotCabalMain fp]
+ TestSuiteLibV09 _ mn -> [DotCabalModule mn]
+ TestSuiteUnsupported _ -> []
+ bnames = map DotCabalModule (otherModules build)
+ build = testBuildInfo test
+
+-- | Get all files referenced by the executable.
+executableFiles
+ :: NamedComponent
+ -> Executable
+ -> RIO
+ GetPackageFileContext
+ (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
+executableFiles component exe = do
+ resolveComponentFiles component build names
+ where
+ build = buildInfo exe
+ names =
+ map DotCabalModule (otherModules build) ++
+ [DotCabalMain (modulePath exe)]
+
+-- | Get all files referenced by the library.
+libraryFiles
+ :: NamedComponent
+ -> Library
+ -> RIO
+ GetPackageFileContext
+ (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
+libraryFiles component lib = do
+ resolveComponentFiles component build names
+ where
+ build = libBuildInfo lib
+ names = bnames ++ exposed
+ exposed = map DotCabalModule (exposedModules lib)
+ bnames = map DotCabalModule (otherModules build)
+
+-- | Get all files referenced by the component.
+resolveComponentFiles
+ :: NamedComponent
+ -> BuildInfo
+ -> [DotCabalDescriptor]
+ -> RIO
+ GetPackageFileContext
+ (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
+resolveComponentFiles component build names = do
+ dirs <- mapMaybeM (resolveDirOrWarn . getSymbolicPath) (hsSourceDirs build)
+ dir <- asks (parent . ctxFile)
+ agdirs <- autogenDirs
+ (modules,files,warnings) <-
+ resolveFilesAndDeps
+ component
+ ((if null dirs then [dir] else dirs) ++ agdirs)
+ names
+ cfiles <- buildOtherSources build
+ pure (modules, files <> cfiles, warnings)
+ where
+ autogenDirs = do
+ cabalVer <- asks ctxCabalVer
+ distDir <- asks ctxDistDir
+ let compDir = componentAutogenDir cabalVer component distDir
+ pkgDir = maybeToList $ packageAutogenDir cabalVer distDir
+ filterM doesDirExist $ compDir : pkgDir
+
+-- | Try to resolve the list of base names in the given directory by
+-- looking for unique instances of base names applied with the given
+-- extensions, plus find any of their module and TemplateHaskell
+-- dependencies.
+resolveFilesAndDeps
+ :: NamedComponent -- ^ Package component name
+ -> [Path Abs Dir] -- ^ Directories to look in.
+ -> [DotCabalDescriptor] -- ^ Base names.
+ -> RIO
+ GetPackageFileContext
+ (Map ModuleName (Path Abs File),[DotCabalPath],[PackageWarning])
+resolveFilesAndDeps component dirs names0 = do
+ (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty
+ warnings <-
+ liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules)
+ pure (foundModules, dotCabalPaths, warnings)
+ where
+ loop [] _ = pure ([], M.empty, [])
+ loop names doneModules0 = do
+ resolved <- resolveFiles dirs names
+ let foundFiles = mapMaybe snd resolved
+ foundModules = mapMaybe toResolvedModule resolved
+ missingModules = mapMaybe toMissingModule resolved
+ pairs <- mapM (getDependencies component dirs) foundFiles
+ let doneModules = S.union
+ doneModules0
+ (S.fromList (mapMaybe dotCabalModule names))
+ moduleDeps = S.unions (map fst pairs)
+ thDepFiles = concatMap snd pairs
+ modulesRemaining = S.difference moduleDeps doneModules
+ -- Ignore missing modules discovered as dependencies - they may
+ -- have been deleted.
+ (resolvedFiles, resolvedModules, _) <-
+ loop (map DotCabalModule (S.toList modulesRemaining)) doneModules
+ pure
+ ( nubOrd $ foundFiles <> map DotCabalFilePath thDepFiles <> resolvedFiles
+ , M.union
+ (M.fromList foundModules)
+ resolvedModules
+ , missingModules
+ )
+ warnUnlisted foundModules = do
+ let unlistedModules =
+ foundModules `M.difference`
+ M.fromList (mapMaybe (fmap (, ()) . dotCabalModule) names0)
+ pure $
+ if M.null unlistedModules
+ then []
+ else [ UnlistedModulesWarning
+ component
+ (map fst (M.toList unlistedModules))
+ ]
+ warnMissing _missingModules = do
+ pure []
+ -- TODO: bring this back - see
+ -- https://github.com/commercialhaskell/stack/issues/2649
+ {-
+ cabalfp <- asks ctxFile
+ pure $
+ if null missingModules
+ then []
+ else [ MissingModulesWarning
+ cabalfp
+ component
+ missingModules]
+ -}
+ -- TODO: In usages of toResolvedModule / toMissingModule, some sort
+ -- of map + partition would probably be better.
+ toResolvedModule
+ :: (DotCabalDescriptor, Maybe DotCabalPath)
+ -> Maybe (ModuleName, Path Abs File)
+ toResolvedModule (DotCabalModule mn, Just (DotCabalModulePath fp)) =
+ Just (mn, fp)
+ toResolvedModule _ =
+ Nothing
+ toMissingModule
+ :: (DotCabalDescriptor, Maybe DotCabalPath)
+ -> Maybe ModuleName
+ toMissingModule (DotCabalModule mn, Nothing) =
+ Just mn
+ toMissingModule _ =
+ Nothing
+
+-- | Get the dependencies of a Haskell module file.
+getDependencies
+ :: NamedComponent
+ -> [Path Abs Dir]
+ -> DotCabalPath
+ -> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
+getDependencies component dirs dotCabalPath =
+ case dotCabalPath of
+ DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile
+ DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile
+ DotCabalFilePath{} -> pure (S.empty, [])
+ DotCabalCFilePath{} -> pure (S.empty, [])
+ where
+ readResolvedHi resolvedFile = do
+ dumpHIDir <- componentOutputDir component <$> asks ctxDistDir
+ dir <- asks (parent . ctxFile)
+ let sourceDir = fromMaybe dir $ find (`isProperPrefixOf` resolvedFile) dirs
+ stripSourceDir d = stripProperPrefix d resolvedFile
+ case stripSourceDir sourceDir of
+ Nothing -> pure (S.empty, [])
+ Just fileRel -> do
+ let hiPath = FilePath.replaceExtension
+ (toFilePath (dumpHIDir fileRel))
+ ".hi"
+ dumpHIExists <- liftIO $ D.doesFileExist hiPath
+ if dumpHIExists
+ then parseHI hiPath
+ else pure (S.empty, [])
+
+-- | Parse a .hi file into a set of modules and files.
+parseHI
+ :: FilePath -> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
+parseHI hiPath = do
+ dir <- asks (parent . ctxFile)
+ result <-
+ liftIO $ catchAnyDeep
+ (Iface.fromFile hiPath)
+ (\e -> pure (Left (displayException e)))
+ case result of
+ Left msg -> do
+ prettyStackDevL
+ [ flow "Failed to decode module interface:"
+ , style File $ fromString hiPath
+ , flow "Decoding failure:"
+ , style Error $ fromString msg
+ ]
+ pure (S.empty, [])
+ Right iface -> do
+ let moduleNames = fmap (fromString . T.unpack . decodeUtf8Lenient . fst) .
+ Iface.unList . Iface.dmods . Iface.deps
+ resolveFileDependency file = do
+ resolved <-
+ liftIO (forgivingAbsence (resolveFile dir file)) >>=
+ rejectMissingFile
+ when (isNothing resolved) $
+ prettyWarnL
+ [ flow "Dependent file listed in:"
+ , style File $ fromString hiPath
+ , flow "does not exist:"
+ , style File $ fromString file
+ ]
+ pure resolved
+ resolveUsages = traverse
+ (resolveFileDependency . Iface.unUsage) . Iface.unList . Iface.usage
+ resolvedUsages <- catMaybes <$> resolveUsages iface
+ pure (S.fromList $ moduleNames iface, resolvedUsages)
+
+-- | The directory where generated files are put like .o or .hs (from .x files).
+componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir
+componentOutputDir namedComponent distDir =
+ case namedComponent of
+ CLib -> buildDir distDir
+ CInternalLib name -> makeTmp name
+ CExe name -> makeTmp name
+ CTest name -> makeTmp name
+ CBench name -> makeTmp name
+ where
+ makeTmp name =
+ buildDir distDir componentNameToDir (name <> "/" <> name <> "-tmp")
+
+-- | Try to resolve the list of base names in the given directory by
+-- looking for unique instances of base names applied with the given
+-- extensions.
+resolveFiles
+ :: [Path Abs Dir] -- ^ Directories to look in.
+ -> [DotCabalDescriptor] -- ^ Base names.
+ -> RIO GetPackageFileContext [(DotCabalDescriptor, Maybe DotCabalPath)]
+resolveFiles dirs names =
+ forM names (\name -> liftM (name, ) (findCandidate dirs name))
+
+-- | Find a candidate for the given module-or-filename from the list
+-- of directories and given extensions.
+findCandidate
+ :: [Path Abs Dir]
+ -> DotCabalDescriptor
+ -> RIO GetPackageFileContext (Maybe DotCabalPath)
+findCandidate dirs name = do
+ pkg <- asks ctxFile >>= parsePackageNameFromFilePath
+ customPreprocessorExts <- view $ configL . to configCustomPreprocessorExts
+ let haskellPreprocessorExts =
+ haskellDefaultPreprocessorExts ++ customPreprocessorExts
+ candidates <- liftIO $ makeNameCandidates haskellPreprocessorExts
+ case candidates of
+ [candidate] -> pure (Just (cons candidate))
+ [] -> do
+ case name of
+ DotCabalModule mn
+ | display mn /= paths_pkg pkg -> logPossibilities dirs mn
+ _ -> pure ()
+ pure Nothing
+ (candidate:rest) -> do
+ warnMultiple name candidate rest
+ pure (Just (cons candidate))
+ where
+ cons =
+ case name of
+ DotCabalModule{} -> DotCabalModulePath
+ DotCabalMain{} -> DotCabalMainPath
+ DotCabalFile{} -> DotCabalFilePath
+ DotCabalCFile{} -> DotCabalCFilePath
+ paths_pkg pkg = "Paths_" ++ packageNameString pkg
+ makeNameCandidates haskellPreprocessorExts =
+ liftM
+ (nubOrd . concat)
+ (mapM (makeDirCandidates haskellPreprocessorExts) dirs)
+ makeDirCandidates :: [Text]
+ -> Path Abs Dir
+ -> IO [Path Abs File]
+ makeDirCandidates haskellPreprocessorExts dir =
+ case name of
+ DotCabalMain fp -> resolveCandidate dir fp
+ DotCabalFile fp -> resolveCandidate dir fp
+ DotCabalCFile fp -> resolveCandidate dir fp
+ DotCabalModule mn -> do
+ let perExt ext =
+ resolveCandidate
+ dir (Cabal.toFilePath mn ++ "." ++ T.unpack ext)
+ withHaskellExts <- mapM perExt haskellFileExts
+ withPPExts <- mapM perExt haskellPreprocessorExts
+ pure $
+ case (concat withHaskellExts, concat withPPExts) of
+ -- If we have exactly 1 Haskell extension and exactly
+ -- 1 preprocessor extension, assume the former file is
+ -- generated from the latter
+ --
+ -- See https://github.com/commercialhaskell/stack/issues/4076
+ ([_], [y]) -> [y]
+
+ -- Otherwise, return everything
+ (xs, ys) -> xs ++ ys
+ resolveCandidate dir = fmap maybeToList . resolveDirFile dir
+
+-- | Log that we couldn't find a candidate, but there are
+-- possibilities for custom preprocessor extensions.
+--
+-- For example: .erb for a Ruby file might exist in one of the
+-- directories.
+logPossibilities
+ :: HasTerm env
+ => [Path Abs Dir]
+ -> ModuleName
+ -> RIO env ()
+logPossibilities dirs mn = do
+ possibilities <- liftM concat (makePossibilities mn)
+ unless (null possibilities) $ prettyWarnL
+ [ flow "Unable to find a known candidate for the Cabal entry"
+ , (style Module . fromString $ display mn) <> ","
+ , flow "but did find:"
+ , line <> bulletedList (map pretty possibilities)
+ , flow "If you are using a custom preprocessor for this module"
+ , flow "with its own file extension, consider adding the extension"
+ , flow "to the 'custom-preprocessor-extensions' field in stack.yaml."
+ ]
+ where
+ makePossibilities name =
+ mapM
+ ( \dir -> do
+ (_,files) <- listDir dir
+ pure
+ ( map
+ filename
+ ( filter
+ (isPrefixOf (display name) . toFilePath . filename)
+ files
+ )
+ )
+ )
+ dirs
+
+-- | Get all C sources and extra source files in a build.
+buildOtherSources :: BuildInfo -> RIO GetPackageFileContext [DotCabalPath]
+buildOtherSources build = do
+ cwd <- liftIO getCurrentDir
+ dir <- asks (parent . ctxFile)
+ file <- asks ctxFile
+ let resolveDirFiles files toCabalPath =
+ forMaybeM files $ \fp -> do
+ result <- resolveDirFile dir fp
+ case result of
+ Nothing -> do
+ warnMissingFile "File" cwd fp file
+ pure Nothing
+ Just p -> pure $ Just (toCabalPath p)
+ csources <- resolveDirFiles (cSources build) DotCabalCFilePath
+ jsources <- resolveDirFiles (targetJsSources build) DotCabalFilePath
+ pure (csources <> jsources)
+
+-- | Get the target's JS sources.
+targetJsSources :: BuildInfo -> [FilePath]
+targetJsSources = jsSources
+
+-- | Resolve file as a child of a specified directory, symlinks
+-- don't get followed.
+resolveDirFile
+ :: (MonadIO m, MonadThrow m)
+ => Path Abs Dir -> FilePath.FilePath -> m (Maybe (Path Abs File))
+resolveDirFile x y = do
+ -- The standard canonicalizePath does not work for this case
+ p <- parseCollapsedAbsFile (toFilePath x FilePath. y)
+ exists <- doesFileExist p
+ pure $ if exists then Just p else Nothing
+
+-- | Warn the user that multiple candidates are available for an
+-- entry, but that we picked one anyway and continued.
+warnMultiple
+ :: DotCabalDescriptor
+ -> Path b t
+ -> [Path b t]
+ -> RIO GetPackageFileContext ()
+warnMultiple name candidate rest =
+ -- TODO: figure out how to style 'name' and the dispOne stuff
+ prettyWarnL
+ [ flow "There were multiple candidates for the Cabal entry"
+ , fromString . showName $ name
+ , line <> bulletedList (map dispOne (candidate:rest))
+ , line <> flow "picking:"
+ , dispOne candidate
+ ]
+ where
+ showName (DotCabalModule name') = display name'
+ showName (DotCabalMain fp) = fp
+ showName (DotCabalFile fp) = fp
+ showName (DotCabalCFile fp) = fp
+ dispOne = fromString . toFilePath
+ -- TODO: figure out why dispOne can't be just `display`
+ -- (remove the .hlint.yaml exception if it can be)
+
+-- | Parse a package name from a file path.
+parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
+parsePackageNameFromFilePath fp = do
+ base <- clean $ toFilePath $ filename fp
+ case parsePackageName base of
+ Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp
+ Just x -> pure x
+ where
+ clean = liftM reverse . strip . reverse
+ strip ('l':'a':'b':'a':'c':'.':xs) = pure xs
+ strip _ = throwM (CabalFileNameParseFail (toFilePath fp))
+
+-- | Resolve the directory, if it can't be resolved, warn for the user
+-- (purely to be helpful).
+resolveDirOrWarn :: FilePath.FilePath
+ -> RIO GetPackageFileContext (Maybe (Path Abs Dir))
+resolveDirOrWarn = resolveOrWarn "Directory" f
+ where
+ f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir
+
+-- | Make the global autogen dir if Cabal version is new enough.
+packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)
+packageAutogenDir cabalVer distDir
+ | cabalVer < mkVersion [2, 0] = Nothing
+ | otherwise = Just $ buildDir distDir relDirGlobalAutogen
+
+-- | Make the autogen dir.
+componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
+componentAutogenDir cabalVer component distDir =
+ componentBuildDir cabalVer component distDir relDirAutogen
+
+-- | Make the build dir. Note that Cabal >= 2.0 uses the
+-- 'componentBuildDir' above for some things.
+buildDir :: Path Abs Dir -> Path Abs Dir
+buildDir distDir = distDir relDirBuild
+
+-- NOTE: don't export this, only use it for valid paths based on
+-- component names.
+componentNameToDir :: Text -> Path Rel Dir
+componentNameToDir name =
+ fromMaybe (throw ComponentNotParsedBug) (parseRelDir (T.unpack name))
+
+-- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir'
+componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
+componentBuildDir cabalVer component distDir
+ | cabalVer < mkVersion [2, 0] = buildDir distDir
+ | otherwise =
+ case component of
+ CLib -> buildDir distDir
+ CInternalLib name -> buildDir distDir componentNameToDir name
+ CExe name -> buildDir distDir componentNameToDir name
+ CTest name -> buildDir distDir componentNameToDir name
+ CBench name -> buildDir distDir componentNameToDir name
+
+-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn
+resolveOrWarn :: Text
+ -> (Path Abs Dir -> String -> RIO GetPackageFileContext (Maybe a))
+ -> FilePath.FilePath
+ -> RIO GetPackageFileContext (Maybe a)
+resolveOrWarn subject resolver path = do
+ cwd <- liftIO getCurrentDir
+ file <- asks ctxFile
+ dir <- asks (parent . ctxFile)
+ result <- resolver dir path
+ when (isNothing result) $ warnMissingFile subject cwd path file
+ pure result
+
+warnMissingFile
+ :: Text
+ -> Path Abs Dir
+ -> FilePath
+ -> Path Abs File
+ -> RIO GetPackageFileContext ()
+warnMissingFile subject cwd path fromFile =
+ prettyWarnL
+ [ fromString . T.unpack $ subject -- TODO: needs style?
+ , flow "listed in"
+ , maybe (pretty fromFile) pretty (stripProperPrefix cwd fromFile)
+ , flow "file does not exist:"
+ , style Dir . fromString $ path
+ ]
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
--- a/src/Stack/Config.hs
+++ b/src/Stack/Config.hs
@@ -19,55 +19,60 @@
-- probably default to behaving like cabal, possibly with spitting out
-- a warning that "you should run `stk init` to make things better".
module Stack.Config
- (loadConfig
- ,loadConfigYaml
- ,packagesParser
- ,getImplicitGlobalProjectDir
- ,getSnapshots
- ,makeConcreteResolver
- ,checkOwnership
- ,getInContainer
- ,getInNixShell
- ,defaultConfigYaml
- ,getProjectConfig
- ,withBuildConfig
- ,withNewLogFunc
+ ( loadConfig
+ , loadConfigYaml
+ , packagesParser
+ , getImplicitGlobalProjectDir
+ , getSnapshots
+ , makeConcreteResolver
+ , checkOwnership
+ , getInContainer
+ , getInNixShell
+ , defaultConfigYaml
+ , getProjectConfig
+ , withBuildConfig
+ , withNewLogFunc
) where
-import Control.Monad.Extra (firstJustM)
-import Stack.Prelude
-import Pantry.Internal.AesonExtended
-import Data.Array.IArray ((!), (//))
+import Control.Monad.Extra ( firstJustM )
+import Data.Array.IArray ( (!), (//) )
import qualified Data.ByteString as S
-import Data.ByteString.Builder (byteString)
-import Data.Coerce (coerce)
+import Data.ByteString.Builder ( byteString )
+import Data.Coerce ( coerce )
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as MS
import qualified Data.Monoid
-import Data.Monoid.Map (MonoidMap(..))
+import Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
-import Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
+import Distribution.System
+ ( Arch (OtherArch), OS (..), Platform (..), buildPlatform )
import qualified Distribution.Text
-import Distribution.Version (simplifyVersionRange, mkVersion')
-import GHC.Conc (getNumProcessors)
-import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody)
-import Options.Applicative (Parser, help, long, metavar, strOption)
+import Distribution.Version ( simplifyVersionRange )
+import GHC.Conc ( getNumProcessors )
+import Network.HTTP.StackClient
+ ( httpJSON, parseUrlThrow, getResponseBody )
+import Options.Applicative ( Parser, help, long, metavar, strOption )
+import Pantry.Internal.AesonExtended
import Path
-import Path.Extra (toFilePathNoTrailingSep)
-import Path.Find (findInParents)
+import Path.Extra ( toFilePathNoTrailingSep )
+import Path.Find ( findInParents )
import Path.IO
-import qualified Paths_stack as Meta
+import RIO.List ( unzip )
+import RIO.Process
+import RIO.Time ( toGregorian )
+import Stack.Build.Haddock ( shouldHaddockDeps )
import Stack.Config.Build
import Stack.Config.Docker
import Stack.Config.Nix
import Stack.Constants
-import Stack.Build.Haddock (shouldHaddockDeps)
-import Stack.Lock (lockCachedWanted)
-import Stack.Storage.Project (initProjectStorage)
-import Stack.Storage.User (initUserStorage)
+import Stack.Lock ( lockCachedWanted )
+import Stack.Prelude
import Stack.SourceMap
+import Stack.Storage.Project ( initProjectStorage )
+import Stack.Storage.User ( initUserStorage )
+import Stack.Storage.Util ( handleMigrationException )
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
@@ -76,23 +81,20 @@
import Stack.Types.Resolver
import Stack.Types.SourceMap
import Stack.Types.Version
-import System.Console.ANSI (hSupportsANSIWithoutEmulation, setSGRCode)
+ ( IntersectingVersionRange (..), VersionCheck (..)
+ , stackVersion, withinRange
+ )
+import System.Console.ANSI
+ ( hSupportsANSIWithoutEmulation, setSGRCode )
import System.Environment
-import System.Info.ShortPathName (getShortPathName)
-import System.PosixCompat.Files (fileOwner, getFileStatus)
-import System.PosixCompat.User (getEffectiveUserID)
-import RIO.List (unzip)
-import RIO.PrettyPrint (Style (Highlight, Secondary),
- logLevelToStyle, stylesUpdateL, useColorL)
-import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..))
-import RIO.PrettyPrint.DefaultStyles (defaultStyles)
-import RIO.Process
-import RIO.Time (toGregorian)
+import System.Info.ShortPathName ( getShortPathName )
+import System.PosixCompat.Files ( fileOwner, getFileStatus )
+import System.PosixCompat.User ( getEffectiveUserID )
-- | If deprecated path exists, use it and print a warning.
-- Otherwise, return the new path.
-tryDeprecatedPath
- :: HasLogFunc env
+tryDeprecatedPath ::
+ HasLogFunc env
=> Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)
-> (Path Abs a -> RIO env Bool) -- ^ Test for existence
-> Path Abs a -- ^ New path
@@ -101,13 +103,13 @@
tryDeprecatedPath mWarningDesc exists new old = do
newExists <- exists new
if newExists
- then return (new, True)
+ then pure (new, True)
else do
oldExists <- exists old
if oldExists
then do
case mWarningDesc of
- Nothing -> return ()
+ Nothing -> pure ()
Just desc ->
logWarn $
"Warning: Location of " <> display desc <> " at '" <>
@@ -115,14 +117,14 @@
"' is deprecated; rename it to '" <>
fromString (toFilePath new) <>
"' instead"
- return (old, True)
- else return (new, False)
+ pure (old, True)
+ else pure (new, False)
-- | Get the location of the implicit global project directory.
-- If the directory already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
-getImplicitGlobalProjectDir
- :: HasLogFunc env
+getImplicitGlobalProjectDir ::
+ HasLogFunc env
=> Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir config =
--TEST no warning printed
@@ -142,11 +144,11 @@
logDebug $ "Downloading snapshot versions file from " <> display latestUrlText
result <- httpJSON latestUrl
logDebug "Done downloading and parsing snapshot versions file"
- return $ getResponseBody result
+ pure $ getResponseBody result
-- | Turn an 'AbstractResolver' into a 'Resolver'.
-makeConcreteResolver
- :: HasConfig env
+makeConcreteResolver ::
+ HasConfig env
=> AbstractResolver
-> RIO env RawSnapshotLocation
makeConcreteResolver (ARResolver r) = pure r
@@ -159,21 +161,21 @@
let fp = implicitGlobalDir stackDotYaml
iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
ProjectAndConfigMonoid project _ <- liftIO iopc
- return $ projectResolver project
+ pure $ projectResolver project
ARLatestNightly -> RSLSynonym . Nightly . snapshotsNightly <$> getSnapshots
ARLatestLTSMajor x -> do
snapshots <- getSnapshots
case IntMap.lookup x $ snapshotsLts snapshots of
- Nothing -> throwString $ "No LTS release found with major version " ++ show x
- Just y -> return $ RSLSynonym $ LTS x y
+ Nothing -> throwIO $ NoLTSWithMajorVersion x
+ Just y -> pure $ RSLSynonym $ LTS x y
ARLatestLTS -> do
snapshots <- getSnapshots
if IntMap.null $ snapshotsLts snapshots
- then throwString "No LTS releases found"
+ then throwIO NoLTSFound
else let (x, y) = IntMap.findMax $ snapshotsLts snapshots
- in return $ RSLSynonym $ LTS x y
+ in pure $ RSLSynonym $ LTS x y
logInfo $ "Selected resolver: " <> display r
- return r
+ pure r
-- | Get the latest snapshot resolver available.
getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation
@@ -184,9 +186,9 @@
pure $ RSLSynonym $ fromMaybe (Nightly (snapshotsNightly snapshots)) mlts
-- Interprets ConfigMonoid options.
-configFromConfigMonoid
- :: HasRunner env
- => Path Abs Dir -- ^ stack root, e.g. ~/.stack
+configFromConfigMonoid ::
+ HasRunner env
+ => Path Abs Dir -- ^ Stack root, e.g. ~/.stack
-> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml
-> Maybe AbstractResolver
-> ProjectConfig (Project, Path Abs File)
@@ -209,7 +211,7 @@
PCProject _ -> True
PCGlobalProject -> True
PCNoProject _ -> False
- configWorkDir0 <- maybe (return relDirStackWork) (liftIO . parseRelDir) mstackWorkEnv
+ configWorkDir0 <- maybe (pure relDirStackWork) (liftIO . parseRelDir) mstackWorkEnv
let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir
configLatestSnapshot = fromFirst
"https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
@@ -245,9 +247,9 @@
configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck
case arch of
- OtherArch "aarch64" -> return ()
+ OtherArch "aarch64" -> pure ()
OtherArch unk -> logWarn $ "Warning: Unknown value for architecture setting: " <> displayShow unk
- _ -> return ()
+ _ -> pure ()
configPlatformVariant <- liftIO $
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
@@ -262,7 +264,7 @@
(Just False, True) ->
throwM NixRequiresSystemGhc
_ ->
- return
+ pure
(fromFirst
(dockerEnable configDocker || nixEnable configNix)
configMonoidSystemGHC)
@@ -271,15 +273,15 @@
throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
rawEnv <- liftIO getEnvironment
- pathsEnv <- either throwM return
+ pathsEnv <- either throwM pure
$ augmentPathMap (map toFilePath configMonoidExtraPath)
(Map.fromList (map (T.pack *** T.pack) rawEnv))
origEnv <- mkProcessContext pathsEnv
- let configProcessContextSettings _ = return origEnv
+ let configProcessContextSettings _ = pure origEnv
configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of
Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv
- Just path -> return path
+ Just path -> pure path
let localProgramsFilePath = toFilePath configLocalProgramsBase
when (osIsWindows && ' ' `elem` localProgramsFilePath) $ do
ensureDir configLocalProgramsBase
@@ -288,11 +290,12 @@
shortLocalProgramsFilePath <-
liftIO $ getShortPathName localProgramsFilePath
when (' ' `elem` shortLocalProgramsFilePath) $ do
- logError $ "Stack's 'programs' path contains a space character and " <>
- "has no alternative short ('8 dot 3') name. This will cause " <>
- "problems with packages that use the GNU project's 'configure' " <>
- "shell script. Use the 'local-programs-path' configuration option " <>
- "to specify an alternative path. The current path is: " <>
+ logError $ "Error: [S-8432]\n"<>
+ "Stack's 'programs' path contains a space character and has no " <>
+ "alternative short ('8 dot 3') name. This will cause problems " <>
+ "with packages that use the GNU project's 'configure' shell " <>
+ "script. Use the 'local-programs-path' configuration option to " <>
+ "specify an alternative path. The current path is: " <>
display (T.pack localProgramsFilePath)
platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)
let configLocalPrograms = configLocalProgramsBase platformOnlyDir
@@ -301,7 +304,7 @@
case getFirst configMonoidLocalBinPath of
Nothing -> do
localDir <- getAppUserDataDir "local"
- return $ localDir relDirBin
+ pure $ localDir relDirBin
Just userPath ->
(case mproject of
-- Not in a project
@@ -317,7 +320,7 @@
configJobs <-
case getFirst configMonoidJobs of
Nothing -> liftIO getNumProcessors
- Just i -> return i
+ Just i -> pure i
let configConcurrentTests = fromFirst True configMonoidConcurrentTests
let configTemplateParams = configMonoidTemplateParameters
@@ -332,6 +335,7 @@
configRebuildGhcOptions = fromFirstFalse configMonoidRebuildGhcOptions
configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions
configAllowNewer = fromFirst False configMonoidAllowNewer
+ configAllowNewerDeps = coerce configMonoidAllowNewerDeps
configDefaultTemplate = getFirst configMonoidDefaultTemplate
configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs
configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds
@@ -342,7 +346,7 @@
configAllowDifferentUser <-
case getFirst configMonoidAllowDifferentUser of
- Just True -> return True
+ Just True -> pure True
_ -> getInContainer
configRunner' <- view runnerL
@@ -355,7 +359,7 @@
useColor' = runnerUseColor configRunner'
mUseColor = do
colorWhen <- getFirst configMonoidColorWhen
- return $ case colorWhen of
+ pure $ case colorWhen of
ColorNever -> False
ColorAlways -> True
ColorAuto -> useAnsi
@@ -366,17 +370,22 @@
& useColorL .~ useColor''
go = runnerGlobalOpts configRunner'
- hsc <-
- case getFirst configMonoidPackageIndices of
- Nothing -> pure defaultHackageSecurityConfig
- Just [hsc] -> pure hsc
- Just x -> error $ "When overriding the default package index, you must provide exactly one value, received: " ++ show x
- mpantryRoot <- liftIO $ lookupEnv "PANTRY_ROOT"
+ pic <-
+ case getFirst configMonoidPackageIndex of
+ Nothing ->
+ case getFirst configMonoidPackageIndices of
+ Nothing -> pure defaultPackageIndexConfig
+ Just [pic] -> do
+ logWarn $ fromString packageIndicesWarning
+ pure pic
+ Just x -> throwIO $ MultiplePackageIndices x
+ Just pic -> pure pic
+ mpantryRoot <- liftIO $ lookupEnv pantryRootEnvVar
pantryRoot <-
case mpantryRoot of
Just dir ->
case parseAbsDir dir of
- Nothing -> throwString $ "Failed to parse PANTRY_ROOT environment variable (expected absolute directory): " ++ show dir
+ Nothing -> throwIO $ ParseAbsolutePathException pantryRootEnvVar dir
Just x -> pure x
Nothing -> pure $ configStackRoot relDirPantry
@@ -403,17 +412,18 @@
withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
let configRunner = configRunner'' & logFuncL .~ logFunc
- withLocalLogFunc logFunc $ withPantryConfig
- pantryRoot
- hsc
- (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
- clConnectionCount
- (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
- defaultCasaMaxPerRequest
- snapLoc
- (\configPantryConfig -> initUserStorage
- (configStackRoot relFileStorage)
- (\configUserStorage -> inner Config {..}))
+ withLocalLogFunc logFunc $ handleMigrationException $
+ withPantryConfig
+ pantryRoot
+ pic
+ (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
+ clConnectionCount
+ (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
+ defaultCasaMaxPerRequest
+ snapLoc
+ (\configPantryConfig -> initUserStorage
+ (configStackRoot relFileStorage)
+ (\configUserStorage -> inner Config {..}))
-- | Runs the provided action with the given 'LogFunc' in the environment
withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a
@@ -454,23 +464,24 @@
-> ProcessContext
-> m (Path Abs Dir)
getDefaultLocalProgramsBase configStackRoot configPlatform override =
- let
- defaultBase = configStackRoot relDirPrograms
- in
case configPlatform of
-- For historical reasons, on Windows a subdirectory of LOCALAPPDATA is
-- used instead of a subdirectory of STACK_ROOT. Unifying the defaults would
-- mean that Windows users would manually have to move data from the old
-- location to the new one, which is undesirable.
- Platform _ Windows ->
- case Map.lookup "LOCALAPPDATA" $ view envVarsL override of
- Just t ->
- case parseAbsDir $ T.unpack t of
- Nothing -> throwM $ stringException ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t)
- Just lad ->
- return $ lad relDirUpperPrograms relDirStackProgName
- Nothing -> return defaultBase
- _ -> return defaultBase
+ Platform _ Windows -> do
+ let envVars = view envVarsL override
+ case T.unpack <$> Map.lookup "LOCALAPPDATA" envVars of
+ Just t -> case parseAbsDir t of
+ Nothing ->
+ throwM $ ParseAbsolutePathException "LOCALAPPDATA" t
+ Just lad ->
+ pure $ lad relDirUpperPrograms
+ relDirStackProgName
+ Nothing -> pure defaultBase
+ _ -> pure defaultBase
+ where
+ defaultBase = configStackRoot relDirPrograms
-- | Load the configuration, using current directory, environment variables,
-- and defaults as necessary.
@@ -480,7 +491,7 @@
mproject <- loadProjectConfig mstackYaml
mresolver <- view $ globalOptsL.to globalResolver
configArgs <- view $ globalOptsL.to globalConfigMonoid
- (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs
+ (configRoot, stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs
let (mproject', addConfigMonoid) =
case mproject of
@@ -488,7 +499,7 @@
PCGlobalProject -> (PCGlobalProject, id)
PCNoProject deps -> (PCNoProject deps, id)
- userConfigPath <- getDefaultUserConfigPath stackRoot
+ userConfigPath <- getDefaultUserConfigPath configRoot
extraConfigs0 <- getExtraConfigs userConfigPath >>=
mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)
let extraConfigs =
@@ -507,7 +518,7 @@
(mconcat $ configArgs : addConfigMonoid extraConfigs)
withConfig $ \config -> do
- unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config)
+ unless (stackVersion `withinRange` configRequireStackVersion config)
(throwM (BadStackVersionException (configRequireStackVersion config)))
unless (configAllowDifferentUser config) $ do
unless userOwnsStackRoot $
@@ -518,8 +529,8 @@
-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
-- values.
-withBuildConfig
- :: RIO BuildConfig a
+withBuildConfig ::
+ RIO BuildConfig a
-> RIO Config a
withBuildConfig inner = do
config <- ask
@@ -539,13 +550,13 @@
(project', stackYamlFP) <- case configProject config of
PCProject (project, fp) -> do
forM_ (projectUserMsg project) (logWarn . fromString)
- return (project, fp)
+ pure (project, fp)
PCNoProject extraDeps -> do
p <-
case mresolver of
Nothing -> throwIO NoResolverWhenUsingNoProject
Just _ -> getEmptyProject mresolver extraDeps
- return (p, configUserConfigPath config)
+ pure (p, configUserConfigPath config)
PCGlobalProject -> do
logDebug "Run from outside a project, using implicit global project config"
destDir <- getImplicitGlobalProjectDir config
@@ -567,8 +578,8 @@
display (projectResolver project) <>
" from implicit global project's config file: " <>
fromString dest'
- Just _ -> return ()
- return (project, dest)
+ Just _ -> pure ()
+ pure (project, dest)
else do
logInfo ("Writing implicit global project config file to: " <> fromString dest')
logInfo "Note: You can change the snapshot via the resolver field there."
@@ -576,11 +587,11 @@
liftIO $ do
writeBinaryFileAtomic dest $ byteString $ S.concat
[ "# This is the implicit global project's config file, which is only used when\n"
- , "# 'stack' is run outside of a real project. Settings here do _not_ act as\n"
- , "# defaults for all projects. To change stack's default settings, edit\n"
+ , "# 'stack' is run outside of a real project. Settings here do _not_ act as\n"
+ , "# defaults for all projects. To change Stack's default settings, edit\n"
, "# '", encodeUtf8 (T.pack $ toFilePath $ configUserConfigPath config), "' instead.\n"
, "#\n"
- , "# For more information about stack's configuration, see\n"
+ , "# For more information about Stack's configuration, see\n"
, "# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"
, "#\n"
, Yaml.encode p]
@@ -588,7 +599,7 @@
"This is the implicit global project, which is " <>
"used only when 'stack' is run\noutside of a " <>
"real project.\n"
- return (p, dest)
+ pure (p, dest)
mcompiler <- view $ globalOptsL.to globalCompiler
let project = project'
{ projectCompiler = mcompiler <|> projectCompiler project'
@@ -619,12 +630,12 @@
r <- case mresolver of
Just resolver -> do
logInfo ("Using resolver: " <> display resolver <> " specified on command line")
- return resolver
+ pure resolver
Nothing -> do
r'' <- getLatestResolver
logInfo ("Using latest snapshot resolver: " <> display r'')
- return r''
- return Project
+ pure r''
+ pure Project
{ projectUserMsg = Nothing
, projectPackages = []
, projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps
@@ -730,38 +741,49 @@
-- exception.
checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m ()
checkDuplicateNames locals =
- case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of
- [] -> return ()
+ case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second pure) locals of
+ [] -> pure ()
x -> throwM $ DuplicateLocalPackageNames x
where
hasMultiples (_, _:_:_) = True
hasMultiples _ = False
--- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it.
+-- | Get the Stack root, e.g. @~/.stack@, and determine whether the user owns it.
--
-- On Windows, the second value is always 'True'.
determineStackRootAndOwnership
:: (MonadIO m)
=> ConfigMonoid
-- ^ Parsed command-line arguments
- -> m (Path Abs Dir, Bool)
+ -> m (Path Abs Dir, Path Abs Dir, Bool)
determineStackRootAndOwnership clArgs = liftIO $ do
- stackRoot <- do
+ (configRoot, stackRoot) <- do
case getFirst (configMonoidStackRoot clArgs) of
- Just x -> return x
+ Just x -> pure (x, x)
Nothing -> do
mstackRoot <- lookupEnv stackRootEnvVar
case mstackRoot of
- Nothing -> getAppUserDataDir stackProgName
+ Nothing -> do
+ wantXdg <- fromMaybe "" <$> lookupEnv stackXdgEnvVar
+ if not (null wantXdg)
+ then do
+ xdgRelDir <- parseRelDir stackProgName
+ (,)
+ <$> getXdgDir XdgConfig (Just xdgRelDir)
+ <*> getXdgDir XdgData (Just xdgRelDir)
+ else do
+ oldStyleRoot <- getAppUserDataDir stackProgName
+ pure (oldStyleRoot, oldStyleRoot)
Just x -> case parseAbsDir x of
- Nothing -> throwString ("Failed to parse STACK_ROOT environment variable (expected absolute directory): " ++ show x)
- Just parsed -> return parsed
+ Nothing ->
+ throwIO $ ParseAbsolutePathException stackRootEnvVar x
+ Just parsed -> pure (parsed, parsed)
(existingStackRootOrParentDir, userOwnsIt) <- do
mdirAndOwnership <- findInParents getDirAndOwnership stackRoot
case mdirAndOwnership of
- Just x -> return x
+ Just x -> pure x
Nothing -> throwIO (BadStackRoot stackRoot)
when (existingStackRootOrParentDir /= stackRoot) $
@@ -772,8 +794,9 @@
stackRoot
existingStackRootOrParentDir
+ configRoot' <- canonicalizePath configRoot
stackRoot' <- canonicalizePath stackRoot
- return (stackRoot', userOwnsIt)
+ pure (configRoot', stackRoot', userOwnsIt)
-- | @'checkOwnership' dir@ throws 'UserDoesn'tOwnDirectory' if @dir@
-- isn't owned by the current user.
@@ -785,33 +808,33 @@
checkOwnership dir = do
mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir]
case mdirAndOwnership of
- Just (_, True) -> return ()
+ Just (_, True) -> pure ()
Just (dir', False) -> throwIO (UserDoesn'tOwnDirectory dir')
Nothing ->
(throwIO . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir
-- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@
-- exists and the current user owns it in the sense of 'isOwnedByUser'.
-getDirAndOwnership
- :: (MonadIO m)
+getDirAndOwnership ::
+ (MonadIO m)
=> Path Abs Dir
-> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership dir = liftIO $ forgivingAbsence $ do
ownership <- isOwnedByUser dir
- return (dir, ownership)
+ pure (dir, ownership)
-- | Check whether the current user (determined with 'getEffectiveUserId') is
-- the owner for the given path.
--
--- Will always return 'True' on Windows.
+-- Will always pure 'True' on Windows.
isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser path = liftIO $ do
if osIsWindows
- then return True
+ then pure True
else do
fileStatus <- getFileStatus (toFilePath path)
user <- getEffectiveUserID
- return (user == fileOwner fileStatus)
+ pure (user == fileOwner fileStatus)
-- | 'True' if we are currently running inside a Docker container.
getInContainer :: (MonadIO m) => m Bool
@@ -832,48 +855,49 @@
liftIO $ do
env <- getEnvironment
mstackConfig <-
- maybe (return Nothing) (fmap Just . parseAbsFile)
+ maybe (pure Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_CONFIG" env
mstackGlobalConfig <-
- maybe (return Nothing) (fmap Just . parseAbsFile)
+ maybe (pure Nothing) (fmap Just . parseAbsFile)
$ lookup "STACK_GLOBAL_CONFIG" env
filterM doesFileExist
$ fromMaybe userConfigPath mstackConfig
- : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath)
+ : maybe [] pure (mstackGlobalConfig <|> defaultStackGlobalConfigPath)
-- | Load and parse YAML from the given config file. Throws
-- 'ParseConfigFileException' when there's a decoding error.
-loadConfigYaml
- :: HasLogFunc env
+loadConfigYaml ::
+ HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadConfigYaml parser path = do
eres <- loadYaml parser path
case eres of
- Left err -> liftIO $ throwM (ParseConfigFileException path err)
- Right res -> return res
+ Left err -> liftIO $
+ throwM $ PrettyException (ParseConfigFileException path err)
+ Right res -> pure res
-- | Load and parse YAML from the given file.
-loadYaml
- :: HasLogFunc env
+loadYaml ::
+ HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env (Either Yaml.ParseException a)
loadYaml parser path = do
eres <- liftIO $ Yaml.decodeFileEither (toFilePath path)
case eres of
- Left err -> return (Left err)
+ Left err -> pure (Left err)
Right val ->
case Yaml.parseEither parser val of
- Left err -> return (Left (Yaml.AesonException err))
+ Left err -> pure (Left (Yaml.AesonException err))
Right (WithJSONWarnings res warnings) -> do
logJSONWarnings (toFilePath path) warnings
- return (Right res)
+ pure (Right res)
-- | Get the location of the project config file, if it exists.
getProjectConfig :: HasLogFunc env
=> StackYamlLoc
-- ^ Override stack.yaml
-> RIO env (ProjectConfig (Path Abs File))
-getProjectConfig (SYLOverride stackYaml) = return $ PCProject stackYaml
-getProjectConfig SYLGlobalProject = return PCGlobalProject
+getProjectConfig (SYLOverride stackYaml) = pure $ PCProject stackYaml
+getProjectConfig SYLGlobalProject = pure PCGlobalProject
getProjectConfig SYLDefault = do
env <- liftIO getEnvironment
case lookup "STACK_YAML" env of
@@ -890,9 +914,9 @@
logDebug $ "Checking for project config at: " <> fromString fp'
exists <- doesFileExist fp
if exists
- then return $ Just fp
- else return Nothing
-getProjectConfig (SYLNoProject extraDeps) = return $ PCNoProject extraDeps
+ then pure $ Just fp
+ else pure Nothing
+getProjectConfig (SYLNoProject extraDeps) = pure $ PCNoProject extraDeps
-- | Find the project config file location, respecting environment variables
-- and otherwise traversing parents. If no config is found, we supply a default
@@ -911,21 +935,21 @@
PCProject <$> load fp
PCGlobalProject -> do
logDebug "No project config file found, using defaults."
- return PCGlobalProject
+ pure PCGlobalProject
PCNoProject extraDeps -> do
logDebug "Ignoring config files"
- return $ PCNoProject extraDeps
+ pure $ PCNoProject extraDeps
where
load fp = do
iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
ProjectAndConfigMonoid project config <- liftIO iopc
- return (project, fp, config)
+ pure (project, fp, config)
--- | Get the location of the default stack configuration file.
+-- | Get the location of the default Stack configuration file.
-- If a file already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
-getDefaultGlobalConfigPath
- :: HasLogFunc env
+getDefaultGlobalConfigPath ::
+ HasLogFunc env
=> RIO env (Maybe (Path Abs File))
getDefaultGlobalConfigPath =
case (defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated) of
@@ -936,14 +960,14 @@
doesFileExist
new
old
- (Just new,Nothing) -> return (Just new)
- _ -> return Nothing
+ (Just new,Nothing) -> pure (Just new)
+ _ -> pure Nothing
-- | Get the location of the default user configuration file.
-- If a file already exists at the deprecated location, its location is returned.
-- Otherwise, the new location is returned.
-getDefaultUserConfigPath
- :: HasLogFunc env
+getDefaultUserConfigPath ::
+ HasLogFunc env
=> Path Abs Dir -> RIO env (Path Abs File)
getDefaultUserConfigPath stackRoot = do
(path, exists) <- tryDeprecatedPath
@@ -954,7 +978,7 @@
unless exists $ do
ensureDir (parent path)
liftIO $ writeBinaryFileAtomic path defaultConfigYaml
- return path
+ pure path
packagesParser :: Parser [String]
packagesParser = many (strOption
@@ -964,12 +988,12 @@
defaultConfigYaml :: (IsString s, Semigroup s) => s
defaultConfigYaml =
- "# This file contains default non-project-specific settings for 'stack', used\n" <>
- "# in all projects. For more information about stack's configuration, see\n" <>
+ "# This file contains default non-project-specific settings for Stack, used\n" <>
+ "# in all projects. For more information about Stack's configuration, see\n" <>
"# http://docs.haskellstack.org/en/stable/yaml_configuration/\n" <>
"\n" <>
- "# The following parameters are used by \"stack new\" to automatically fill fields\n" <>
- "# in the cabal config. We recommend uncommenting them and filling them out if\n" <>
+ "# The following parameters are used by 'stack new' to automatically fill fields\n" <>
+ "# in the Cabal file. We recommend uncommenting them and filling them out if\n" <>
"# you intend to use 'stack new'.\n" <>
"# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates\n" <>
"templates:\n" <>
@@ -979,9 +1003,9 @@
"# copyright:\n" <>
"# github-username:\n" <>
"\n" <>
- "# The following parameter specifies stack's output styles; STYLES is a\n" <>
+ "# The following parameter specifies Stack's output styles; STYLES is a\n" <>
"# colon-delimited sequence of key=value, where 'key' is a style name and\n" <>
"# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n" <>
- "# Rendition) control codes (in decimal). Use \"stack ls stack-colors --basic\"\n" <>
+ "# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n" <>
"# to see the current sequence.\n" <>
"# stack-colors: STYLES\n"
diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs
--- a/src/Stack/Config/Build.hs
+++ b/src/Stack/Config/Build.hs
@@ -2,94 +2,102 @@
{-# LANGUAGE RecordWildCards #-}
-- | Build configuration
-module Stack.Config.Build where
+module Stack.Config.Build
+ ( benchmarkOptsFromMonoid
+ , buildOptsFromMonoid
+ , haddockOptsFromMonoid
+ , testOptsFromMonoid
+ ) where
+import Distribution.Verbosity ( normal )
import Stack.Prelude
import Stack.Types.Config
-import Distribution.Verbosity (normal)
-- | Interprets BuildOptsMonoid options.
buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts
buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
- { boptsLibProfile = fromFirstFalse
- (buildMonoidLibProfile <>
- FirstFalse (if tracing || profiling then Just True else Nothing))
- , boptsExeProfile = fromFirstFalse
- (buildMonoidExeProfile <>
- FirstFalse (if tracing || profiling then Just True else Nothing))
- , boptsLibStrip = fromFirstTrue
- (buildMonoidLibStrip <>
- FirstTrue (if noStripping then Just False else Nothing))
- , boptsExeStrip = fromFirstTrue
- (buildMonoidExeStrip <>
- FirstTrue (if noStripping then Just False else Nothing))
- , boptsHaddock = fromFirstFalse buildMonoidHaddock
- , boptsHaddockOpts = haddockOptsFromMonoid buildMonoidHaddockOpts
- , boptsOpenHaddocks = fromFirstFalse buildMonoidOpenHaddocks
- , boptsHaddockDeps = getFirst buildMonoidHaddockDeps
- , boptsHaddockInternal = fromFirstFalse buildMonoidHaddockInternal
- , boptsHaddockHyperlinkSource = fromFirstTrue buildMonoidHaddockHyperlinkSource
- , boptsInstallExes = fromFirstFalse buildMonoidInstallExes
- , boptsInstallCompilerTool = fromFirstFalse buildMonoidInstallCompilerTool
- , boptsPreFetch = fromFirstFalse buildMonoidPreFetch
- , boptsKeepGoing = getFirst buildMonoidKeepGoing
- , boptsKeepTmpFiles = fromFirstFalse buildMonoidKeepTmpFiles
- , boptsForceDirty = fromFirstFalse buildMonoidForceDirty
- , boptsTests = fromFirstFalse buildMonoidTests
- , boptsTestOpts =
- testOptsFromMonoid buildMonoidTestOpts additionalArgs
- , boptsBenchmarks = fromFirstFalse buildMonoidBenchmarks
- , boptsBenchmarkOpts =
- benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs
- , boptsReconfigure = fromFirstFalse buildMonoidReconfigure
- , boptsCabalVerbose = fromFirst (CabalVerbosity normal) buildMonoidCabalVerbose
- , boptsSplitObjs = fromFirstFalse buildMonoidSplitObjs
- , boptsSkipComponents = buildMonoidSkipComponents
- , boptsInterleavedOutput = fromFirstTrue buildMonoidInterleavedOutput
- , boptsDdumpDir = getFirst buildMonoidDdumpDir
- }
- where
- -- These options are not directly used in bopts, instead they
- -- transform other options.
- tracing = getAny buildMonoidTrace
- profiling = getAny buildMonoidProfile
- noStripping = getAny buildMonoidNoStrip
- -- Additional args for tracing / profiling
- additionalArgs =
- if tracing || profiling
- then Just $ "+RTS" : catMaybes [trac, prof, Just "-RTS"]
- else Nothing
- trac =
- if tracing
- then Just "-xc"
- else Nothing
- prof =
- if profiling
- then Just "-p"
- else Nothing
+ { boptsLibProfile = fromFirstFalse
+ (buildMonoidLibProfile <>
+ FirstFalse (if tracing || profiling then Just True else Nothing))
+ , boptsExeProfile = fromFirstFalse
+ (buildMonoidExeProfile <>
+ FirstFalse (if tracing || profiling then Just True else Nothing))
+ , boptsLibStrip = fromFirstTrue
+ (buildMonoidLibStrip <>
+ FirstTrue (if noStripping then Just False else Nothing))
+ , boptsExeStrip = fromFirstTrue
+ (buildMonoidExeStrip <>
+ FirstTrue (if noStripping then Just False else Nothing))
+ , boptsHaddock = fromFirstFalse buildMonoidHaddock
+ , boptsHaddockOpts = haddockOptsFromMonoid buildMonoidHaddockOpts
+ , boptsOpenHaddocks = fromFirstFalse buildMonoidOpenHaddocks
+ , boptsHaddockDeps = getFirst buildMonoidHaddockDeps
+ , boptsHaddockInternal = fromFirstFalse buildMonoidHaddockInternal
+ , boptsHaddockHyperlinkSource = fromFirstTrue buildMonoidHaddockHyperlinkSource
+ , boptsInstallExes = fromFirstFalse buildMonoidInstallExes
+ , boptsInstallCompilerTool = fromFirstFalse buildMonoidInstallCompilerTool
+ , boptsPreFetch = fromFirstFalse buildMonoidPreFetch
+ , boptsKeepGoing = getFirst buildMonoidKeepGoing
+ , boptsKeepTmpFiles = fromFirstFalse buildMonoidKeepTmpFiles
+ , boptsForceDirty = fromFirstFalse buildMonoidForceDirty
+ , boptsTests = fromFirstFalse buildMonoidTests
+ , boptsTestOpts =
+ testOptsFromMonoid buildMonoidTestOpts additionalArgs
+ , boptsBenchmarks = fromFirstFalse buildMonoidBenchmarks
+ , boptsBenchmarkOpts =
+ benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs
+ , boptsReconfigure = fromFirstFalse buildMonoidReconfigure
+ , boptsCabalVerbose = fromFirst (CabalVerbosity normal) buildMonoidCabalVerbose
+ , boptsSplitObjs = fromFirstFalse buildMonoidSplitObjs
+ , boptsSkipComponents = buildMonoidSkipComponents
+ , boptsInterleavedOutput = fromFirstTrue buildMonoidInterleavedOutput
+ , boptsDdumpDir = getFirst buildMonoidDdumpDir
+ }
+ where
+ -- These options are not directly used in bopts, instead they
+ -- transform other options.
+ tracing = getAny buildMonoidTrace
+ profiling = getAny buildMonoidProfile
+ noStripping = getAny buildMonoidNoStrip
+ -- Additional args for tracing / profiling
+ additionalArgs =
+ if tracing || profiling
+ then Just $ "+RTS" : catMaybes [trac, prof, Just "-RTS"]
+ else Nothing
+ trac =
+ if tracing
+ then Just "-xc"
+ else Nothing
+ prof =
+ if profiling
+ then Just "-p"
+ else Nothing
haddockOptsFromMonoid :: HaddockOptsMonoid -> HaddockOpts
-haddockOptsFromMonoid HaddockOptsMonoid{..} =
- defaultHaddockOpts
- {hoAdditionalArgs = hoMonoidAdditionalArgs}
+haddockOptsFromMonoid HaddockOptsMonoid{..} = defaultHaddockOpts
+ { hoAdditionalArgs = hoMonoidAdditionalArgs }
testOptsFromMonoid :: TestOptsMonoid -> Maybe [String] -> TestOpts
-testOptsFromMonoid TestOptsMonoid{..} madditional =
- defaultTestOpts
- { toRerunTests = fromFirstTrue toMonoidRerunTests
- , toAdditionalArgs = fromMaybe [] madditional <> toMonoidAdditionalArgs
- , toCoverage = fromFirstFalse toMonoidCoverage
- , toDisableRun = fromFirstFalse toMonoidDisableRun
- , toMaximumTimeSeconds = fromFirst (toMaximumTimeSeconds defaultTestOpts) toMonoidMaximumTimeSeconds
- }
+testOptsFromMonoid TestOptsMonoid{..} madditional = defaultTestOpts
+ { toRerunTests = fromFirstTrue toMonoidRerunTests
+ , toAdditionalArgs = fromMaybe [] madditional <> toMonoidAdditionalArgs
+ , toCoverage = fromFirstFalse toMonoidCoverage
+ , toDisableRun = fromFirstFalse toMonoidDisableRun
+ , toMaximumTimeSeconds =
+ fromFirst (toMaximumTimeSeconds defaultTestOpts) toMonoidMaximumTimeSeconds
+ , toAllowStdin = fromFirstTrue toMonoidAllowStdin
+ }
-benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> Maybe [String] -> BenchmarkOpts
+benchmarkOptsFromMonoid ::
+ BenchmarkOptsMonoid
+ -> Maybe [String]
+ -> BenchmarkOpts
benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} madditional =
- defaultBenchmarkOpts
+ defaultBenchmarkOpts
{ beoAdditionalArgs =
- fmap (\args -> unwords args <> " ") madditional <>
- getFirst beoMonoidAdditionalArgs
+ fmap (\args -> unwords args <> " ") madditional <>
+ getFirst beoMonoidAdditionalArgs
, beoDisableRun = fromFirst
- (beoDisableRun defaultBenchmarkOpts)
- beoMonoidDisableRun
+ (beoDisableRun defaultBenchmarkOpts)
+ beoMonoidDisableRun
}
diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs
--- a/src/Stack/Config/Docker.hs
+++ b/src/Stack/Config/Docker.hs
@@ -4,20 +4,44 @@
{-# LANGUAGE RecordWildCards #-}
-- | Docker configuration
-module Stack.Config.Docker where
+module Stack.Config.Docker
+ ( ConfigDockerException (..)
+ , addDefaultTag
+ , dockerOptsFromMonoid
+ ) where
-import Stack.Prelude
-import Data.List (find)
+import Data.List ( find )
import qualified Data.Text as T
-import Distribution.Version (simplifyVersionRange)
+import Distribution.Version ( simplifyVersionRange )
+import Stack.Prelude
import Stack.Types.Version
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Resolver
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Config.Docker" module.
+data ConfigDockerException
+ = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
+ -- ^ Only LTS resolvers are supported for default image tag.
+ deriving (Show, Typeable)
+
+instance Exception ConfigDockerException where
+ displayException (ResolverNotSupportedException mproject maresolver) =
+ concat
+ [ "Error: [S-8575]\n"
+ , "Resolver not supported for Docker images:\n "
+ , case (mproject, maresolver) of
+ (Nothing, Nothing) -> "no resolver specified"
+ (_, Just aresolver) -> T.unpack $ utf8BuilderToText $ display aresolver
+ (Just project, Nothing) -> T.unpack $ utf8BuilderToText $ display $ projectResolver project
+ , "\nUse an LTS resolver, or set the '"
+ , T.unpack dockerImageArgName
+ , "' explicitly, in your configuration file."]
+
-- | Add a default Docker tag name to a given base image.
-addDefaultTag
- :: MonadThrow m
+addDefaultTag ::
+ MonadThrow m
=> String -- ^ base
-> Maybe Project
-> Maybe AbstractResolver
@@ -25,76 +49,55 @@
addDefaultTag base mproject maresolver = do
let exc = throwM $ ResolverNotSupportedException mproject maresolver
lts <- case maresolver of
- Just (ARResolver (RSLSynonym lts@(LTS _ _))) -> return lts
+ Just (ARResolver (RSLSynonym lts@(LTS _ _))) -> pure lts
Just _aresolver -> exc
Nothing ->
case projectResolver <$> mproject of
- Just (RSLSynonym lts@(LTS _ _)) -> return lts
+ Just (RSLSynonym lts@(LTS _ _)) -> pure lts
_ -> exc
- return $ base ++ ":" ++ show lts
+ pure $ base ++ ":" ++ show lts
-- | Interprets DockerOptsMonoid options.
-dockerOptsFromMonoid
- :: MonadThrow m
- => Maybe Project
- -> Maybe AbstractResolver
- -> DockerOptsMonoid
- -> m DockerOpts
+dockerOptsFromMonoid ::
+ MonadThrow m
+ => Maybe Project
+ -> Maybe AbstractResolver
+ -> DockerOptsMonoid
+ -> m DockerOpts
dockerOptsFromMonoid mproject maresolver DockerOptsMonoid{..} = do
- let dockerImage =
- case getFirst dockerMonoidRepoOrImage of
- Nothing -> addDefaultTag "fpco/stack-build" mproject maresolver
- Just (DockerMonoidImage image) -> pure image
- Just (DockerMonoidRepo repo) ->
- case find (`elem` (":@" :: String)) repo of
- Nothing -> addDefaultTag repo mproject maresolver
- -- Repo already specified a tag or digest, so don't append default
- Just _ -> pure repo
- let dockerEnable =
- fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable
- dockerRegistryLogin =
- fromFirst
- (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername)))
- dockerMonoidRegistryLogin
- dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername)
- dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword)
- dockerAutoPull = fromFirstTrue dockerMonoidAutoPull
- dockerDetach = fromFirstFalse dockerMonoidDetach
- dockerPersist = fromFirstFalse dockerMonoidPersist
- dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName)
- dockerNetwork = emptyToNothing (getFirst dockerMonoidNetwork)
- dockerRunArgs = dockerMonoidRunArgs
- dockerMount = dockerMonoidMount
- dockerMountMode = emptyToNothing (getFirst dockerMonoidMountMode)
- dockerEnv = dockerMonoidEnv
- dockerSetUser = getFirst dockerMonoidSetUser
- dockerRequireDockerVersion =
- simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion)
- dockerStackExe = getFirst dockerMonoidStackExe
-
- return DockerOpts{..}
- where emptyToNothing Nothing = Nothing
- emptyToNothing (Just s) | null s = Nothing
- | otherwise = Just s
-
--- | Exceptions thrown by Stack.Docker.Config.
-data StackDockerConfigException
- = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
- -- ^ Only LTS resolvers are supported for default image tag.
- deriving (Typeable)
-
--- | Exception instance for StackDockerConfigException.
-instance Exception StackDockerConfigException
-
--- | Show instance for StackDockerConfigException.
-instance Show StackDockerConfigException where
- show (ResolverNotSupportedException mproject maresolver) =
- concat
- [ "Resolver not supported for Docker images:\n "
- , case (mproject, maresolver) of
- (Nothing, Nothing) -> "no resolver specified"
- (_, Just aresolver) -> T.unpack $ utf8BuilderToText $ display aresolver
- (Just project, Nothing) -> T.unpack $ utf8BuilderToText $ display $ projectResolver project
- , "\nUse an LTS resolver, or set the '"
- , T.unpack dockerImageArgName
- , "' explicitly, in your configuration file."]
+ let dockerImage =
+ case getFirst dockerMonoidRepoOrImage of
+ Nothing -> addDefaultTag "fpco/stack-build" mproject maresolver
+ Just (DockerMonoidImage image) -> pure image
+ Just (DockerMonoidRepo repo) ->
+ case find (`elem` (":@" :: String)) repo of
+ Nothing -> addDefaultTag repo mproject maresolver
+ -- Repo already specified a tag or digest, so don't append default
+ Just _ -> pure repo
+ let dockerEnable =
+ fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable
+ dockerRegistryLogin =
+ fromFirst
+ (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername)))
+ dockerMonoidRegistryLogin
+ dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername)
+ dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword)
+ dockerAutoPull = fromFirstTrue dockerMonoidAutoPull
+ dockerDetach = fromFirstFalse dockerMonoidDetach
+ dockerPersist = fromFirstFalse dockerMonoidPersist
+ dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName)
+ dockerNetwork = emptyToNothing (getFirst dockerMonoidNetwork)
+ dockerRunArgs = dockerMonoidRunArgs
+ dockerMount = dockerMonoidMount
+ dockerMountMode = emptyToNothing (getFirst dockerMonoidMountMode)
+ dockerEnv = dockerMonoidEnv
+ dockerSetUser = getFirst dockerMonoidSetUser
+ dockerRequireDockerVersion =
+ simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion)
+ dockerStackExe = getFirst dockerMonoidStackExe
+ pure DockerOpts{..}
+ where
+ emptyToNothing Nothing = Nothing
+ emptyToNothing (Just s)
+ | null s = Nothing
+ | otherwise = Just s
diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs
--- a/src/Stack/Config/Nix.hs
+++ b/src/Stack/Config/Nix.hs
@@ -5,56 +5,79 @@
-- | Nix configuration
module Stack.Config.Nix
- (nixOptsFromMonoid
- ,nixCompiler
- ,nixCompilerVersion
- ,StackNixException(..)
- ) where
+ ( nixCompiler
+ , nixCompilerVersion
+ , nixOptsFromMonoid
+ ) where
-import Stack.Prelude
-import Control.Monad.Extra (ifM)
+import Control.Monad.Extra ( ifM )
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
-import Distribution.System (OS (..))
-import Stack.Constants
-import Stack.Types.Config
-import Stack.Types.Nix
-import System.Directory (doesFileExist)
+import Distribution.System ( OS (..) )
+import Stack.Constants ( osIsWindows )
+import Stack.Prelude
+import Stack.Types.Config ( HasRunner )
+import Stack.Types.Nix ( NixOpts (..), NixOptsMonoid (..) )
+import System.Directory ( doesFileExist )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Config.Nix" module.
+data ConfigNixException
+ = NixCannotUseShellFileAndPackagesException
+ -- ^ Nix can't be given packages and a shell file at the same time
+ | GHCMajorVersionUnspecified
+ | OnlyGHCSupported
+ deriving (Show, Typeable)
+
+instance Exception ConfigNixException where
+ displayException NixCannotUseShellFileAndPackagesException =
+ "Error: [S-2726]\n"
+ ++ "You cannot have packages and a shell-file filled at the same time \
+ \in your nix-shell configuration."
+ displayException GHCMajorVersionUnspecified =
+ "Error: [S-9317]\n"
+ ++ "GHC major version not specified."
+ displayException OnlyGHCSupported =
+ "Error: [S-8605]\n"
+ ++ "Only GHC is supported by 'stack --nix'."
+
-- | Interprets NixOptsMonoid options.
-nixOptsFromMonoid
- :: HasRunner env
- => NixOptsMonoid
- -> OS
- -> RIO env NixOpts
+nixOptsFromMonoid ::
+ HasRunner env
+ => NixOptsMonoid
+ -> OS
+ -> RIO env NixOpts
nixOptsFromMonoid NixOptsMonoid{..} os = do
- let defaultPure = case os of
- OSX -> False
- _ -> True
- nixPureShell = fromFirst defaultPure nixMonoidPureShell
- nixPackages = fromFirst [] nixMonoidPackages
- nixInitFile = getFirst nixMonoidInitFile
- nixShellOptions = fromFirst [] nixMonoidShellOptions
- ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)
- nixAddGCRoots = fromFirstFalse nixMonoidAddGCRoots
+ let defaultPure = case os of
+ OSX -> False
+ _ -> True
+ nixPureShell = fromFirst defaultPure nixMonoidPureShell
+ nixPackages = fromFirst [] nixMonoidPackages
+ nixInitFile = getFirst nixMonoidInitFile
+ nixShellOptions = fromFirst [] nixMonoidShellOptions
+ ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)
+ nixAddGCRoots = fromFirstFalse nixMonoidAddGCRoots
- -- Enable Nix-mode by default on NixOS, unless Docker-mode was specified
- osIsNixOS <- isNixOS
- let nixEnable0 = fromFirst osIsNixOS nixMonoidEnable
+ -- Enable Nix-mode by default on NixOS, unless Docker-mode was specified
+ osIsNixOS <- isNixOS
+ let nixEnable0 = fromFirst osIsNixOS nixMonoidEnable
- nixEnable <- case () of _
- | nixEnable0 && osIsWindows -> do
- logInfo "Note: Disabling nix integration, since this is being run in Windows"
- return False
- | otherwise -> return nixEnable0
+ nixEnable <- case () of
+ _
+ | nixEnable0 && osIsWindows -> do
+ logInfo
+ "Note: Disabling nix integration, since this is being run in Windows"
+ pure False
+ | otherwise -> pure nixEnable0
- when (not (null nixPackages) && isJust nixInitFile) $
- throwIO NixCannotUseShellFileAndPackagesException
- return NixOpts{..}
- where prefixAll p (x:xs) = p : x : prefixAll p xs
- prefixAll _ _ = []
+ when (not (null nixPackages) && isJust nixInitFile) $
+ throwIO NixCannotUseShellFileAndPackagesException
+ pure NixOpts{..}
+ where
+ prefixAll p (x:xs) = p : x : prefixAll p xs
+ prefixAll _ _ = []
-nixCompiler :: WantedCompiler -> Either StringException T.Text
+nixCompiler :: WantedCompiler -> Either ConfigNixException T.Text
nixCompiler compilerVersion =
case compilerVersion of
WCGhc version ->
@@ -76,35 +99,23 @@
<> T.pack (versionString version) <> "\"\
\else haskell.compiler.${builtins.head compilers})"
_ -> "haskell.compiler.ghc" <> T.concat (x : y : minor)
- _ -> Left $ stringException "GHC major version not specified"
- WCGhcjs{} -> Left $ stringException "Only GHC is supported by stack --nix"
- WCGhcGit{} -> Left $ stringException "Only GHC is supported by stack --nix"
+ _ -> Left GHCMajorVersionUnspecified
+ WCGhcjs{} -> Left OnlyGHCSupported
+ WCGhcGit{} -> Left OnlyGHCSupported
-nixCompilerVersion :: WantedCompiler -> Either StringException T.Text
+nixCompilerVersion :: WantedCompiler -> Either ConfigNixException T.Text
nixCompilerVersion compilerVersion =
case compilerVersion of
WCGhc version ->
case T.split (== '.') (fromString $ versionString version) of
x : y : minor -> Right $ "ghc" <> T.concat (x : y : minor)
- _ -> Left $ stringException "GHC major version not specified"
- WCGhcjs{} -> Left $ stringException "Only GHC is supported by stack --nix"
- WCGhcGit{} -> Left $ stringException "Only GHC is supported by stack --nix"
-
--- Exceptions thrown specifically by Stack.Nix
-data StackNixException
- = NixCannotUseShellFileAndPackagesException
- -- ^ Nix can't be given packages and a shell file at the same time
- deriving (Typeable)
-
-instance Exception StackNixException
-
-instance Show StackNixException where
- show NixCannotUseShellFileAndPackagesException =
- "You cannot have packages and a shell-file filled at the same time in your nix-shell configuration."
+ _ -> Left GHCMajorVersionUnspecified
+ WCGhcjs{} -> Left OnlyGHCSupported
+ WCGhcGit{} -> Left OnlyGHCSupported
isNixOS :: MonadIO m => m Bool
isNixOS = liftIO $ do
- let fp = "/etc/os-release"
- ifM (doesFileExist fp)
- (T.isInfixOf "ID=nixos" <$> TIO.readFile fp)
- (return False)
+ let fp = "/etc/os-release"
+ ifM (doesFileExist fp)
+ (T.isInfixOf "ID=nixos" <$> TIO.readFile fp)
+ (pure False)
diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs
--- a/src/Stack/ConfigCmd.hs
+++ b/src/Stack/ConfigCmd.hs
@@ -2,48 +2,65 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Make changes to project or global configuration.
module Stack.ConfigCmd
- (ConfigCmdSet(..)
- ,configCmdSetParser
- ,cfgCmdSet
- ,cfgCmdSetName
- ,configCmdEnvParser
- ,cfgCmdEnv
- ,cfgCmdEnvName
- ,cfgCmdName) where
+ ( ConfigCmdSet (..)
+ , configCmdSetParser
+ , cfgCmdSet
+ , cfgCmdSetName
+ , configCmdEnvParser
+ , cfgCmdEnv
+ , cfgCmdEnvName
+ , cfgCmdName
+ ) where
-import Stack.Prelude
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
-import Data.Attoparsec.Text as P (Parser, parseOnly, skip, skipWhile,
- string, takeText, takeWhile)
+import Data.Attoparsec.Text as P
+ ( Parser, parseOnly, skip, skipWhile, string, takeText
+ , takeWhile
+ )
import qualified Data.Map.Merge.Strict as Map
+import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Options.Applicative as OA
-import qualified Options.Applicative.Types as OA
import Options.Applicative.Builder.Extra
-import Pantry (loadSnapshot)
+import qualified Options.Applicative.Types as OA
+import Pantry ( loadSnapshot )
import Path
import qualified RIO.Map as Map
-import RIO.Process (envVarsL)
-import Stack.Config (makeConcreteResolver, getProjectConfig,
- getImplicitGlobalProjectDir)
+import RIO.Process ( envVarsL )
+import Stack.Config
+ ( makeConcreteResolver, getProjectConfig
+ , getImplicitGlobalProjectDir
+ )
import Stack.Constants
+import Stack.Prelude
import Stack.Types.Config
import Stack.Types.Resolver
-import System.Environment (getEnvironment)
+import System.Environment ( getEnvironment )
+-- | Type repesenting exceptions thrown by functions exported by the
+-- "Stack.ConfigCmd" module.
+data ConfigCmdException
+ = NoProjectConfigAvailable
+ deriving (Show, Typeable)
+
+instance Exception ConfigCmdException where
+ displayException NoProjectConfigAvailable =
+ "Error: [S-3136]\n"
+ ++ "'config' command used when no project configuration available."
+
data ConfigCmdSet
- = ConfigCmdSetResolver (Unresolved AbstractResolver)
- | ConfigCmdSetSystemGhc CommandScope
- Bool
- | ConfigCmdSetInstallGhc CommandScope
- Bool
+ = ConfigCmdSetResolver !(Unresolved AbstractResolver)
+ | ConfigCmdSetSystemGhc !CommandScope !Bool
+ | ConfigCmdSetInstallGhc !CommandScope !Bool
+ | ConfigCmdSetDownloadPrefix !CommandScope !Text
data CommandScope
= CommandScopeGlobal
@@ -56,6 +73,7 @@
configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject
configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope
configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope
+configCmdSetScope (ConfigCmdSetDownloadPrefix scope _) = scope
cfgCmdSet
:: (HasConfig env, HasGHCVariant env)
@@ -68,32 +86,55 @@
mstackYamlOption <- view $ globalOptsL.to globalStackYaml
mstackYaml <- getProjectConfig mstackYamlOption
case mstackYaml of
- PCProject stackYaml -> return stackYaml
+ PCProject stackYaml -> pure stackYaml
PCGlobalProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf)
- PCNoProject _extraDeps -> throwString "config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?
- CommandScopeGlobal -> return (configUserConfigPath conf)
+ PCNoProject _extraDeps -> throwIO NoProjectConfigAvailable
+ -- maybe modify the ~/.stack/config.yaml file instead?
+ CommandScopeGlobal -> pure (configUserConfigPath conf)
rawConfig <- liftIO (readFileUtf8 (toFilePath configFilePath))
- config <- either throwM return (Yaml.decodeEither' $ encodeUtf8 rawConfig)
+ config <- either throwM pure (Yaml.decodeEither' $ encodeUtf8 rawConfig)
newValue <- cfgCmdSetValue (parent configFilePath) cmd
let yamlLines = T.lines rawConfig
- cmdKey = cfgCmdSetOptionName cmd -- Text
- cmdKey' = Key.fromText cmdKey -- Data.Aeson.Key.Key
+ cmdKeys = cfgCmdSetKeys cmd -- Text
newValue' = T.stripEnd $
decodeUtf8With lenientDecode $ Yaml.encode newValue -- Text
file = toFilePath configFilePath -- String
file' = display $ T.pack file -- Utf8Builder
- newYamlLines <- case KeyMap.lookup cmdKey' config of
+ newYamlLines <- case inConfig config cmdKeys of
Nothing -> do
logInfo $ file' <> " has been extended."
- pure $ yamlLines <> [cmdKey <> ": " <> newValue']
+ pure $ writeLines yamlLines "" cmdKeys newValue'
Just oldValue -> if oldValue == newValue
then do
logInfo $ file' <> " already contained the intended \
\configuration and remains unchanged."
pure yamlLines
- else switchLine file' cmdKey newValue' [] yamlLines
+ else switchLine file' (NE.last cmdKeys) newValue' [] yamlLines
liftIO $ writeFileUtf8 file (T.unlines newYamlLines)
where
+ -- This assumes that if the key does not exist, the lines that can be
+ -- appended to include it are of a form like:
+ --
+ -- key1:
+ -- key2:
+ -- key3: value
+ --
+ writeLines yamlLines spaces cmdKeys value = case NE.tail cmdKeys of
+ [] -> yamlLines <> [spaces <> NE.head cmdKeys <> ": " <> value]
+ ks -> writeLines (yamlLines <> [spaces <> NE.head cmdKeys <> ":"])
+ (spaces <> " ")
+ (NE.fromList ks)
+ value
+
+ inConfig v cmdKeys = case v of
+ Yaml.Object obj ->
+ case KeyMap.lookup (Key.fromText (NE.head cmdKeys)) obj of
+ Nothing -> Nothing
+ Just v' -> case NE.tail cmdKeys of
+ [] -> Just v'
+ ks -> inConfig v' (NE.fromList ks)
+ _ -> Nothing
+
switchLine file cmdKey _ searched [] = do
logWarn $ display cmdKey <> " not found in YAML file " <> file <>
" as a single line. Multi-line key:value formats are not supported."
@@ -102,22 +143,22 @@
case parseOnly (parseLine cmdKey) oldLine of
Left _ ->
switchLine file cmdKey newValue (oldLine:searched) rest
- Right (kt, spaces1, spaces2, comment) -> do
- let newLine = renderKey cmdKey kt <> spaces1 <> ":" <>
- spaces2 <> newValue <> comment
+ Right (kt, spaces1, spaces2, spaces3, comment) -> do
+ let newLine = spaces1 <> renderKey cmdKey kt <> spaces2 <>
+ ":" <> spaces3 <> newValue <> comment
logInfo $ file <> " has been updated."
pure $ reverse searched <> (newLine:rest)
- -- This assumes that a top-level key will not be indented in the YAML file.
- parseLine :: Text -> Parser (KeyType, Text, Text, Text)
+ parseLine :: Text -> Parser (KeyType, Text, Text, Text, Text)
parseLine key = do
- kt <- parseKey key
spaces1 <- P.takeWhile (== ' ')
- skip (== ':')
+ kt <- parseKey key
spaces2 <- P.takeWhile (== ' ')
+ skip (== ':')
+ spaces3 <- P.takeWhile (== ' ')
skipWhile (/= ' ')
comment <- takeText
- pure (kt, spaces1, spaces2, comment)
+ pure (kt, spaces1, spaces2, spaces3, comment)
-- If the key is, for example, install-ghc, this recognises install-ghc,
-- 'install-ghc' or "install-ghc".
@@ -128,7 +169,7 @@
parsePlainKey :: Text -> Parser KeyType
parsePlainKey key = do
- _ <- string key
+ _ <- P.string key
pure PlainKey
parseSingleQuotedKey :: Text -> Parser KeyType
@@ -140,7 +181,7 @@
parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey kt c key = do
skip (==c)
- _ <- string key
+ _ <- P.string key
skip (==c)
pure kt
@@ -166,17 +207,19 @@
concreteResolver <- makeConcreteResolver newResolver'
-- Check that the snapshot actually exists
void $ loadSnapshot =<< completeSnapshotLocation concreteResolver
- return (Yaml.toJSON concreteResolver)
-cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') =
- return (Yaml.Bool bool')
-cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') =
- return (Yaml.Bool bool')
+ pure (Yaml.toJSON concreteResolver)
+cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') = pure $ Yaml.Bool bool'
+cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') = pure $ Yaml.Bool bool'
+cfgCmdSetValue _ (ConfigCmdSetDownloadPrefix _ url) = pure $ Yaml.String url
-cfgCmdSetOptionName :: ConfigCmdSet -> Text
-cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver"
-cfgCmdSetOptionName (ConfigCmdSetSystemGhc _ _) = configMonoidSystemGHCName
-cfgCmdSetOptionName (ConfigCmdSetInstallGhc _ _) = configMonoidInstallGHCName
+cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty Text
+cfgCmdSetKeys (ConfigCmdSetResolver _) = ["resolver"]
+cfgCmdSetKeys (ConfigCmdSetSystemGhc _ _) = [configMonoidSystemGHCName]
+cfgCmdSetKeys (ConfigCmdSetInstallGhc _ _) = [configMonoidInstallGHCName]
+cfgCmdSetKeys (ConfigCmdSetDownloadPrefix _ _) =
+ ["package-index", "download-prefix"]
+
cfgCmdName :: String
cfgCmdName = "config"
@@ -187,30 +230,48 @@
cfgCmdEnvName = "env"
configCmdSetParser :: OA.Parser ConfigCmdSet
-configCmdSetParser = OA.hsubparser $
- mconcat
- [ OA.command "resolver"
- ( OA.info
- (ConfigCmdSetResolver <$>
- OA.argument
- readAbstractResolver
- (OA.metavar "SNAPSHOT" <>
- OA.help "E.g. \"nightly\" or \"lts-7.2\""))
- (OA.progDesc
- "Change the resolver of the current project."))
- , OA.command (T.unpack configMonoidSystemGHCName)
- ( OA.info
- (ConfigCmdSetSystemGhc <$> scopeFlag <*> boolArgument)
- (OA.progDesc
- "Configure whether Stack should use a system GHC installation \
- \or not."))
- , OA.command (T.unpack configMonoidInstallGHCName)
- ( OA.info
- (ConfigCmdSetInstallGhc <$> scopeFlag <*> boolArgument)
- (OA.progDesc
- "Configure whether Stack should automatically install GHC when \
- \necessary."))
- ]
+configCmdSetParser =
+ OA.hsubparser $
+ mconcat
+ [ OA.command "resolver"
+ ( OA.info
+ ( ConfigCmdSetResolver
+ <$> OA.argument
+ readAbstractResolver
+ ( OA.metavar "SNAPSHOT"
+ <> OA.help "E.g. \"nightly\" or \"lts-7.2\"" ))
+ ( OA.progDesc
+ "Change the resolver of the current project." ))
+ , OA.command (T.unpack configMonoidSystemGHCName)
+ ( OA.info
+ ( ConfigCmdSetSystemGhc
+ <$> scopeFlag
+ <*> boolArgument )
+ ( OA.progDesc
+ "Configure whether Stack should use a system GHC \
+ \installation or not." ))
+ , OA.command (T.unpack configMonoidInstallGHCName)
+ ( OA.info
+ ( ConfigCmdSetInstallGhc
+ <$> scopeFlag
+ <*> boolArgument )
+ ( OA.progDesc
+ "Configure whether Stack should automatically install \
+ \GHC when necessary." ))
+ , OA.command "package-index"
+ ( OA.info
+ ( OA.hsubparser $
+ OA.command "download-prefix"
+ ( OA.info
+ ( ConfigCmdSetDownloadPrefix
+ <$> scopeFlag
+ <*> urlArgument )
+ ( OA.progDesc
+ "Configure download prefix for Stack's package \
+ \index." )))
+ ( OA.progDesc
+ "Configure Stack's package index" ))
+ ]
scopeFlag :: OA.Parser CommandScope
scopeFlag = OA.flag
@@ -226,8 +287,8 @@
readBool = do
s <- OA.readerAsk
case s of
- "true" -> return True
- "false" -> return False
+ "true" -> pure True
+ "false" -> pure False
_ -> OA.readerError ("Invalid value " ++ show s ++
": Expected \"true\" or \"false\"")
@@ -236,6 +297,16 @@
readBool
( OA.metavar "true|false"
<> OA.completeWith ["true", "false"]
+ )
+
+urlArgument :: OA.Parser Text
+urlArgument = OA.strArgument
+ ( OA.metavar "URL"
+ <> OA.value defaultDownloadPrefix
+ <> OA.showDefault
+ <> OA.help
+ "Location of package index. It is highly recommended to use only the \
+ \official Hackage server or a mirror."
)
configCmdEnvParser :: OA.Parser EnvSettings
diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs
--- a/src/Stack/Constants.hs
+++ b/src/Stack/Constants.hs
@@ -6,137 +6,150 @@
-- | Constants used throughout the project.
module Stack.Constants
- (buildPlanDir
- ,buildPlanCacheDir
- ,haskellFileExts
- ,haskellDefaultPreprocessorExts
- ,stackDotYaml
- ,stackWorkEnvVar
- ,stackRootEnvVar
- ,stackRootOptionName
- ,deprecatedStackRootOptionName
- ,inContainerEnvVar
- ,inNixShellEnvVar
- ,stackProgNameUpper
- ,wiredInPackages
- ,cabalPackageName
- ,implicitGlobalProjectDirDeprecated
- ,implicitGlobalProjectDir
- ,defaultUserConfigPathDeprecated
- ,defaultUserConfigPath
- ,defaultGlobalConfigPathDeprecated
- ,defaultGlobalConfigPath
- ,platformVariantEnvVar
- ,compilerOptionsCabalFlag
- ,ghcColorForceFlag
- ,minTerminalWidth
- ,maxTerminalWidth
- ,defaultTerminalWidth
- ,osIsWindows
- ,relFileSetupHs
- ,relFileSetupLhs
- ,relFileHpackPackageConfig
- ,relDirGlobalAutogen
- ,relDirAutogen
- ,relDirLogs
- ,relFileCabalMacrosH
- ,relDirBuild
- ,relDirBin
- ,relDirPantry
- ,relDirPrograms
- ,relDirUpperPrograms
- ,relDirStackProgName
- ,relDirStackWork
- ,relFileReadmeTxt
- ,relDirScript
- ,relFileConfigYaml
- ,relDirSnapshots
- ,relDirGlobalHints
- ,relFileGlobalHintsYaml
- ,relDirInstall
- ,relDirCompilerTools
- ,relDirHoogle
- ,relFileDatabaseHoo
- ,relDirPkgdb
- ,relFileStorage
- ,relDirLoadedSnapshotCache
- ,bindirSuffix
- ,docDirSuffix
- ,relDirHpc
- ,relDirLib
- ,relDirShare
- ,relDirLibexec
- ,relDirEtc
- ,setupGhciShimCode
- ,relDirSetupExeCache
- ,relDirSetupExeSrc
- ,relFileConfigure
- ,relDirDist
- ,relFileSetupMacrosH
- ,relDirSetup
- ,relFileSetupLower
- ,relDirMingw
- ,relDirMingw32
- ,relDirMingw64
- ,relDirLocal
- ,relDirUsr
- ,relDirInclude
- ,relFileIndexHtml
- ,relDirAll
- ,relFilePackageCache
- ,relFileDockerfile
- ,relDirHaskellStackGhci
- ,relFileGhciScript
- ,relDirCombined
- ,relFileHpcIndexHtml
- ,relDirCustom
- ,relDirPackageConfInplace
- ,relDirExtraTixFiles
- ,relDirInstalledPackages
- ,backupUrlRelPath
- ,relDirDotLocal
- ,relDirDotSsh
- ,relDirDotStackProgName
- ,relDirUnderHome
- ,relDirSrc
- ,relFileLibtinfoSo5
- ,relFileLibtinfoSo6
- ,relFileLibncurseswSo6
- ,relFileLibgmpSo10
- ,relFileLibgmpSo3
- ,relDirNewCabal
- ,relFileSetupExe
- ,relFileSetupUpper
- ,relFile7zexe
- ,relFile7zdll
- ,relFileMainHs
- ,relFileStack
- ,relFileStackDotExe
- ,relFileStackDotTmpDotExe
- ,relFileStackDotTmp
- ,ghcShowOptionsOutput
- ,hadrianScriptsWindows
- ,hadrianScriptsPosix
- ,usrLibDirs
- ,testGhcEnvRelFile
- ,relFileBuildLock
- ,stackDeveloperModeDefault
- )
- where
+ ( buildPlanDir
+ , buildPlanCacheDir
+ , haskellFileExts
+ , haskellDefaultPreprocessorExts
+ , stackDotYaml
+ , stackWorkEnvVar
+ , stackRootEnvVar
+ , stackXdgEnvVar
+ , stackRootOptionName
+ , stackGlobalConfigOptionName
+ , pantryRootEnvVar
+ , deprecatedStackRootOptionName
+ , inContainerEnvVar
+ , inNixShellEnvVar
+ , stackProgNameUpper
+ , wiredInPackages
+ , cabalPackageName
+ , implicitGlobalProjectDirDeprecated
+ , implicitGlobalProjectDir
+ , defaultUserConfigPathDeprecated
+ , defaultUserConfigPath
+ , defaultGlobalConfigPathDeprecated
+ , defaultGlobalConfigPath
+ , platformVariantEnvVar
+ , compilerOptionsCabalFlag
+ , ghcColorForceFlag
+ , minTerminalWidth
+ , maxTerminalWidth
+ , defaultTerminalWidth
+ , osIsWindows
+ , relFileSetupHs
+ , relFileSetupLhs
+ , relFileHpackPackageConfig
+ , relDirGlobalAutogen
+ , relDirAutogen
+ , relDirLogs
+ , relFileCabalMacrosH
+ , relDirBuild
+ , relDirBin
+ , relDirPantry
+ , relDirPrograms
+ , relDirUpperPrograms
+ , relDirStackProgName
+ , relDirStackWork
+ , relFileReadmeTxt
+ , relDirScript
+ , relFileConfigYaml
+ , relDirSnapshots
+ , relDirGlobalHints
+ , relFileGlobalHintsYaml
+ , relDirInstall
+ , relDirCompilerTools
+ , relDirHoogle
+ , relFileDatabaseHoo
+ , relDirPkgdb
+ , relFileStorage
+ , relDirLoadedSnapshotCache
+ , bindirSuffix
+ , docDirSuffix
+ , relDirHpc
+ , relDirLib
+ , relDirShare
+ , relDirLibexec
+ , relDirEtc
+ , setupGhciShimCode
+ , relDirSetupExeCache
+ , relDirSetupExeSrc
+ , relFileConfigure
+ , relDirDist
+ , relFileSetupMacrosH
+ , relDirSetup
+ , relFileSetupLower
+ , relDirMingw
+ , relDirMingw32
+ , relDirMingw64
+ , relDirLocal
+ , relDirUsr
+ , relDirInclude
+ , relFileIndexHtml
+ , relDirAll
+ , relFilePackageCache
+ , relFileDockerfile
+ , relDirHaskellStackGhci
+ , relFileGhciScript
+ , relDirCombined
+ , relFileHpcIndexHtml
+ , relDirCustom
+ , relDirPackageConfInplace
+ , relDirExtraTixFiles
+ , relDirInstalledPackages
+ , backupUrlRelPath
+ , relDirDotLocal
+ , relDirDotSsh
+ , relDirDotStackProgName
+ , relDirUnderHome
+ , relDirSrc
+ , relFileLibtinfoSo5
+ , relFileLibtinfoSo6
+ , relFileLibncurseswSo6
+ , relFileLibgmpSo10
+ , relFileLibgmpSo3
+ , relDirNewCabal
+ , relFileSetupExe
+ , relFileSetupUpper
+ , relFile7zexe
+ , relFile7zdll
+ , relFileMainHs
+ , relFileStack
+ , relFileStackDotExe
+ , relFileStackDotTmpDotExe
+ , relFileStackDotTmp
+ , ghcShowOptionsOutput
+ , hadrianScriptsWindows
+ , hadrianScriptsPosix
+ , usrLibDirs
+ , testGhcEnvRelFile
+ , relFileBuildLock
+ , stackDeveloperModeDefault
+ , globalFooter
+ ) where
-import Data.ByteString.Builder (byteString)
-import Data.Char (toUpper)
-import Data.FileEmbed (embedFile, makeRelativeToProject)
+import Data.ByteString.Builder ( byteString )
+import Data.Char ( toUpper )
+import Data.FileEmbed ( embedFile, makeRelativeToProject )
import qualified Data.Set as Set
-import Distribution.Package (mkPackageName)
-import qualified Hpack.Config as Hpack
-import qualified Language.Haskell.TH.Syntax as TH (runIO, lift)
+import Distribution.Package ( mkPackageName )
+import Hpack.Config ( packageConfig )
+import qualified Language.Haskell.TH.Syntax as TH ( runIO, lift )
import Path as FL
import Stack.Prelude
-import Stack.Types.Compiler
-import System.Permissions (osIsWindows)
-import System.Process (readProcess)
+import Stack.Types.Compiler ( WhichCompiler (..) )
+import System.Permissions ( osIsWindows )
+import System.Process ( readProcess )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Constants" module.
+data ConstantsException
+ = WiredInPackagesNotParsedBug
+ deriving (Show, Typeable)
+
+instance Exception ConstantsException where
+ displayException WiredInPackagesNotParsedBug = bugReport "[S-6057]"
+ "Parse error in wiredInPackages."
+
-- | Extensions used for Haskell modules. Excludes preprocessor ones.
haskellFileExts :: [Text]
haskellFileExts = ["hs", "hsc", "lhs"]
@@ -149,7 +162,7 @@
stackProgNameUpper :: String
stackProgNameUpper = map toUpper stackProgName
--- | The filename used for the stack config file.
+-- | The filename used for the Stack project-level configuration file.
stackDotYaml :: Path Rel File
stackDotYaml = $(mkRelFile "stack.yaml")
@@ -161,11 +174,23 @@
stackRootEnvVar :: String
stackRootEnvVar = "STACK_ROOT"
--- | Option name for the global stack root.
+-- | Environment variable used to indicate XDG directories should be used.
+stackXdgEnvVar :: String
+stackXdgEnvVar = "STACK_XDG"
+
+-- | Option name for the global Stack root.
stackRootOptionName :: String
stackRootOptionName = "stack-root"
--- | Deprecated option name for the global stack root.
+-- | Option name for the global Stack configuration file.
+stackGlobalConfigOptionName :: String
+stackGlobalConfigOptionName = "global-config"
+
+-- | Environment variable used to override the location of the Pantry store
+pantryRootEnvVar :: String
+pantryRootEnvVar = "PANTRY_ROOT"
+
+-- | Deprecated option name for the global Stack root.
--
-- Deprecated since stack-1.1.0.
--
@@ -174,33 +199,63 @@
deprecatedStackRootOptionName :: String
deprecatedStackRootOptionName = "global-stack-root"
--- | Environment variable used to indicate stack is running in container.
+-- | Environment variable used to indicate Stack is running in container.
inContainerEnvVar :: String
inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"
--- | Environment variable used to indicate stack is running in container.
+-- | Environment variable used to indicate Stack is running in container.
-- although we already have STACK_IN_NIX_EXTRA_ARGS that is set in the same conditions,
-- it can happen that STACK_IN_NIX_EXTRA_ARGS is set to empty.
inNixShellEnvVar :: String
inNixShellEnvVar = map toUpper stackProgName ++ "_IN_NIX_SHELL"
--- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey
+-- | The comment to \'see
+-- https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey\'
+-- appears to be out of date.
+--
+-- See \'Note [About units]\' and \'Wired-in units\' at
+-- https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Unit.hs.
+--
+-- The \'wired-in packages\' appear to have been replaced by those that have (e.g)
+--
+-- > ghc-options: -this-unit-id ghc-prim
+--
+-- in their Cabal file because they are \'magic\'.
wiredInPackages :: Set PackageName
-wiredInPackages =
- maybe (error "Parse error in wiredInPackages") Set.fromList mparsed
- where
- mparsed = mapM parsePackageName
- [ "ghc-prim"
- , "integer-gmp"
- , "integer-simple"
- , "base"
- , "rts"
- , "template-haskell"
- , "dph-seq"
- , "dph-par"
- , "ghc"
- , "interactive"
- ]
+wiredInPackages = case mparsed of
+ Just parsed -> Set.fromList parsed
+ Nothing -> impureThrow WiredInPackagesNotParsedBug
+ where
+ mparsed = mapM parsePackageName
+ [ "ghc-prim"
+ -- A magic package
+ , "integer-gmp"
+ -- No longer magic > 1.0.3.0. With GHC 9.2.5 at least, there seems to be
+ -- no problem in using it.
+ , "integer-simple"
+ -- A magic package
+ , "base"
+ -- A magic package
+ , "rts"
+ -- Said to be not a \'real\' package
+ , "template-haskell"
+ -- A magic package
+ , "dph-seq"
+ -- Deprecated in favour of dph-prim-seq, which does not appear to be
+ -- magic. With GHC 9.2.5 at least, there seems to be no problem in using
+ -- it.
+ , "dph-par"
+ -- Deprecated in favour of dph-prim-par, which does not appear to be
+ -- magic. With GHC 9.2.5 at least, there seems to be no problem in using
+ -- it.
+ , "ghc"
+ -- A magic package
+ , "interactive"
+ -- Could not identify information about this package name. With GHC 9.2.5
+ -- at least, there seems to be no problem in using it.
+ , "ghc-bignum"
+ -- A magic package
+ ]
-- | Just to avoid repetition and magic strings.
cabalPackageName :: PackageName
@@ -287,7 +342,7 @@
relFileSetupLhs = $(mkRelFile "Setup.lhs")
relFileHpackPackageConfig :: Path Rel File
-relFileHpackPackageConfig = $(mkRelFile Hpack.packageConfig)
+relFileHpackPackageConfig = $(mkRelFile packageConfig)
relDirGlobalAutogen :: Path Rel Dir
relDirGlobalAutogen = $(mkRelDir "global-autogen")
@@ -562,3 +617,8 @@
-- | What should the default be for stack-developer-mode
stackDeveloperModeDefault :: Bool
stackDeveloperModeDefault = STACK_DEVELOPER_MODE_DEFAULT
+
+-- | The footer to the help for Stack's subcommands
+globalFooter :: String
+globalFooter =
+ "Command 'stack --help' for global options that apply to all subcommands."
diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs
--- a/src/Stack/Constants/Config.hs
+++ b/src/Stack/Constants/Config.hs
@@ -23,10 +23,10 @@
, templatesDir
) where
-import Stack.Prelude
-import Stack.Constants
-import Stack.Types.Config
-import Path
+import Path
+import Stack.Constants
+import Stack.Prelude
+import Stack.Types.Config
-- | Output .o/.hi directory.
objectInterfaceDirL :: HasBuildConfig env => Getting r env (Path Abs Dir)
@@ -116,7 +116,7 @@
-> m (Path Abs File)
setupConfigFromDir fp = do
dist <- distDirFromDir fp
- return $ dist $(mkRelFile "setup-config")
+ pure $ dist $(mkRelFile "setup-config")
-- | Package's build artifacts directory.
distDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
@@ -141,7 +141,7 @@
=> m (Path Rel Dir)
rootDistRelativeDir = do
workDir <- view workDirL
- return $ workDir $(mkRelDir "dist")
+ pure $ workDir $(mkRelDir "dist")
-- | Package's working directory.
workDirFromDir :: (MonadReader env m, HasConfig env)
@@ -166,7 +166,7 @@
PackageIdentifier cabalPackageName cabalPkgVer
platformAndCabal <- useShaPathOnWindows (platform envDir)
allDist <- rootDistRelativeDir
- return $ allDist platformAndCabal
+ pure $ allDist platformAndCabal
-- | Docker sandbox from project root.
projectDockerSandboxDir :: (MonadReader env m, HasConfig env)
@@ -174,7 +174,7 @@
-> m (Path Abs Dir) -- ^ Docker sandbox
projectDockerSandboxDir projectRoot = do
workDir <- view workDirL
- return $ projectRoot workDir $(mkRelDir "docker/")
+ pure $ projectRoot workDir $(mkRelDir "docker/")
-- | Image staging dir from project root.
imageStagingDir :: (MonadReader env m, HasConfig env, MonadThrow m)
@@ -184,4 +184,4 @@
imageStagingDir projectRoot imageIdx = do
workDir <- view workDirL
idxRelDir <- parseRelDir (show imageIdx)
- return $ projectRoot workDir $(mkRelDir "image") idxRelDir
+ pure $ projectRoot workDir $(mkRelDir "image") idxRelDir
diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs
--- a/src/Stack/Coverage.hs
+++ b/src/Stack/Coverage.hs
@@ -9,51 +9,66 @@
-- | Generate HPC (Haskell Program Coverage) reports
module Stack.Coverage
- ( deleteHpcReports
- , updateTixFile
- , generateHpcReport
- , HpcReportOpts(..)
- , generateHpcReportForTargets
- , generateHpcUnifiedReport
- , generateHpcMarkupIndex
- ) where
+ ( deleteHpcReports
+ , updateTixFile
+ , generateHpcReport
+ , HpcReportOpts (..)
+ , generateHpcReportForTargets
+ , generateHpcUnifiedReport
+ , generateHpcMarkupIndex
+ ) where
-import Stack.Prelude hiding (Display (..))
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
-import Data.List
+import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
-import Distribution.Version (mkVersion)
+import Distribution.Version ( mkVersion )
import Path
-import Path.Extra (toFilePathNoTrailingSep)
+import Path.Extra ( toFilePathNoTrailingSep )
import Path.IO
+import RIO.Process
import Stack.Build.Target
import Stack.Constants
import Stack.Constants.Config
import Stack.Package
+import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.SourceMap
-import System.FilePath (isPathSeparator)
-import qualified RIO
-import RIO.PrettyPrint
-import RIO.Process
+import System.FilePath ( isPathSeparator )
import Trace.Hpc.Tix
import Web.Browser (openBrowser)
-newtype CoverageException = NonTestSuiteTarget PackageName deriving Typeable
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Coverage" module.
+data CoverageException
+ = NonTestSuiteTarget PackageName
+ | NoTargetsOrTixSpecified
+ | NotLocalPackage PackageName
+ deriving (Show, Typeable)
-instance Exception CoverageException
-instance Show CoverageException where
- show (NonTestSuiteTarget name) =
- "Can't specify anything except test-suites as hpc report targets (" ++
- packageNameString name ++
- " is used with a non test-suite target)"
+instance Exception CoverageException where
+ displayException (NonTestSuiteTarget name) = concat
+ [ "Error: [S-6361]\n"
+ , "Can't specify anything except test-suites as hpc report targets ("
+ , packageNameString name
+ , ") is used with a non test-suite target."
+ ]
+ displayException NoTargetsOrTixSpecified =
+ "Error: [S-2321]\n"
+ ++ "Not generating combined report, because no targets or tix files \
+ \are specified."
+ displayException (NotLocalPackage name) = concat
+ [ "Error: [S-9975]"
+ , "Expected a local package, but "
+ , packageNameString name
+ , " is either an extra-dep or in the snapshot."
+ ]
-- | Invoked at the beginning of running with "--coverage"
deleteHpcReports :: HasEnvConfig env => RIO env ()
@@ -61,20 +76,29 @@
hpcDir <- hpcReportDir
liftIO $ ignoringAbsence (removeDirRecur hpcDir)
--- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is
--- present.
-updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env ()
+-- | Move a tix file into a sub-directory of the hpc report directory. Deletes
+-- the old one if one is present.
+updateTixFile ::
+ HasEnvConfig env
+ => PackageName
+ -> Path Abs File
+ -> String
+ -> RIO env ()
updateTixFile pkgName' tixSrc testName = do
exists <- doesFileExist tixSrc
when exists $ do
tixDest <- tixFilePath pkgName' testName
liftIO $ ignoringAbsence (removeFile tixDest)
ensureDir (parent tixDest)
- -- Remove exe modules because they are problematic. This could be revisited if there's a GHC
- -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853
+ -- Remove exe modules because they are problematic. This could be
+ -- revisited if there's a GHC version that fixes
+ -- https://ghc.haskell.org/trac/ghc/ticket/1853
mtix <- readTixOrLog tixSrc
case mtix of
- Nothing -> logError $ "Failed to read " <> fromString (toFilePath tixSrc)
+ Nothing -> logError $
+ "Error: [S-2887]\n" <>
+ "Failed to read " <>
+ fromString (toFilePath tixSrc)
Just tix -> do
liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)
-- TODO: ideally we'd do a file move, but IIRC this can
@@ -88,16 +112,16 @@
hpcPkgPath pkgName' = do
outputDir <- hpcReportDir
pkgNameRel <- parseRelDir (packageNameString pkgName')
- return (outputDir pkgNameRel)
+ pure (outputDir pkgNameRel)
--- | Get the tix file location, given the name of the file (without extension), and the package
--- identifier string.
+-- | Get the tix file location, given the name of the file (without extension),
+-- and the package identifier string.
tixFilePath :: HasEnvConfig env
=> PackageName -> String -> RIO env (Path Abs File)
tixFilePath pkgName' testName = do
pkgPath <- hpcPkgPath pkgName'
tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix")
- return (pkgPath tixRel)
+ pure (pkgPath tixRel)
-- | Generates the HTML coverage report and shows a textual coverage summary for a package.
generateHpcReport :: HasEnvConfig env
@@ -116,9 +140,9 @@
internalLibs = packageInternalLibraries package
eincludeName <-
-- Pre-7.8 uses plain PKG-version in tix files.
- if ghcVersion < mkVersion [7, 10] then return $ Right $ Just [pkgId]
+ if ghcVersion < mkVersion [7, 10] then pure $ Right $ Just [pkgId]
-- We don't expect to find a package key if there is no library.
- else if not hasLibrary && Set.null internalLibs then return $ Right Nothing
+ else if not hasLibrary && Set.null internalLibs then pure $ Right Nothing
-- Look in the inplace DB for the package key.
-- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986
else do
@@ -128,21 +152,22 @@
eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) internalLibs hpcNameField
case eincludeName of
Left err -> do
- logError $ RIO.display err
- return $ Left err
- Right includeNames -> return $ Right $ Just $ map T.unpack includeNames
+ logError $ display err
+ pure $ Left err
+ Right includeNames -> pure $ Right $ Just $ map T.unpack includeNames
forM_ tests $ \testName -> do
tixSrc <- tixFilePath (packageName package) (T.unpack testName)
let report = "coverage report for " <> pkgName' <> "'s test-suite \"" <> testName <> "\""
reportDir = parent tixSrc
case eincludeName of
- Left err -> generateHpcErrorReport reportDir (RIO.display (sanitize (T.unpack err)))
+ Left err -> generateHpcErrorReport reportDir (display (sanitize (T.unpack err)))
-- Restrict to just the current library code, if there is a library in the package (see
-- #634 - this will likely be customizable in the future)
Right mincludeName -> do
let extraArgs = case mincludeName of
- Just includeNames -> "--include" : intersperse "--include" (map (\n -> n ++ ":") includeNames)
Nothing -> []
+ Just includeNames ->
+ "--include" : L.intersperse "--include" (map (\n -> n ++ ":") includeNames)
mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs
forM_ mreportPath (displayReportPath "The" report . pretty)
@@ -150,22 +175,29 @@
=> Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do
- -- If a .tix file exists, move it to the HPC output directory and generate a report for it.
+ -- If a .tix file exists, move it to the HPC output directory and generate a
+ -- report for it.
tixFileExists <- doesFileExist tixSrc
if not tixFileExists
then do
logError $
+ "Error: [S-4634]\n" <>
"Didn't find .tix for " <>
- RIO.display report <>
+ display report <>
" - expected to find it at " <>
fromString (toFilePath tixSrc) <>
"."
- return Nothing
+ pure Nothing
else (`catch` \(err :: ProcessException) -> do
logError $ displayShow err
- generateHpcErrorReport reportDir $ RIO.display $ sanitize $ show err
- return Nothing) $
- (`onException` logError ("Error occurred while producing " <> RIO.display report)) $ do
+ generateHpcErrorReport reportDir $ display $ sanitize $
+ displayException err
+ pure Nothing) $
+ (`onException`
+ logError
+ ("Error: [S-8215]\n" <>
+ "Error occurred while producing " <>
+ display report)) $ do
-- Directories for .mix files.
hpcRelDir <- hpcRelativeDir
-- Compute arguments used for both "hpc markup" and "hpc report".
@@ -175,7 +207,7 @@
concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++
-- Look for index files in the correct dir (relative to each pkgdir).
["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"]
- logInfo $ "Generating " <> RIO.display report
+ logInfo $ "Generating " <> display report
outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines . BL.toStrict . fst) $
proc "hpc"
( "report"
@@ -186,19 +218,20 @@
if all ("(0/0)" `S8.isSuffixOf`) outputLines
then do
let msg html =
- "Error: The " <>
- RIO.display report <>
+ "Error: [S-6829]\n"<>
+ "The " <>
+ display report <>
" did not consider any code. One possible cause of this is" <>
- " if your test-suite builds the library code (see stack " <>
+ " if your test-suite builds the library code (see Stack " <>
(if html then "" else "") <>
"issue #1008" <>
(if html then "" else "") <>
- "). It may also indicate a bug in stack or" <>
+ "). It may also indicate a bug in Stack or" <>
" the hpc program. Please report this issue if you think" <>
" your coverage report should have meaningful results."
logError (msg False)
generateHpcErrorReport reportDir (msg True)
- return Nothing
+ pure Nothing
else do
let reportPath = reportDir relFileHpcIndexHtml
-- Print output, stripping @\r@ characters because Windows.
@@ -211,7 +244,7 @@
: (args ++ extraMarkupArgs)
)
readProcess_
- return (Just reportPath)
+ pure (Just reportPath)
data HpcReportOpts = HpcReportOpts
{ hroptsInputs :: [Text]
@@ -227,17 +260,14 @@
-- When there aren't any package component arguments, and --all
-- isn't passed, default to not considering any targets.
if not (hroptsAll opts) && null targetNames
- then return []
+ then pure []
else do
when (hroptsAll opts && not (null targetNames)) $
logWarn $ "Since --all is used, it is redundant to specify these targets: " <> displayShow targetNames
targets <- view $ envConfigL.to envConfigSourceMap.to smTargets.to smtTargets
liftM concat $ forM (Map.toList targets) $ \(name, target) ->
case target of
- TargetAll PTDependency -> throwString $
- "Error: Expected a local package, but " ++
- packageNameString name ++
- " is either an extra-dep or in the snapshot."
+ TargetAll PTDependency -> throwIO $ NotLocalPackage name
TargetComps comps -> do
pkgPath <- hpcPkgPath name
forM (toList comps) $ \nc ->
@@ -254,18 +284,17 @@
(dirs, _) <- listDir pkgPath
liftM concat $ forM dirs $ \dir -> do
(_, files) <- listDir dir
- return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
- else return []
+ pure (filter ((".tix" `L.isSuffixOf`) . toFilePath) files)
+ else pure []
tixPaths <- liftM (\xs -> xs ++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles
- when (null tixPaths) $
- throwString "Not generating combined report, because no targets or tix files are specified."
+ when (null tixPaths) $ throwIO NoTargetsOrTixSpecified
outputDir <- hpcReportDir
reportDir <- case hroptsDestDir opts of
- Nothing -> return (outputDir relDirCombined relDirCustom)
+ Nothing -> pure (outputDir relDirCombined relDirCustom)
Just destDir -> do
dest <- resolveDir' destDir
ensureDir dest
- return dest
+ pure dest
let report = "combined report"
mreportPath <- generateUnionReport report reportDir tixPaths
forM_ mreportPath $ \reportPath ->
@@ -284,7 +313,7 @@
(dirs', _) <- listDir dir
forM dirs' $ \dir' -> do
(_, files) <- listDir dir'
- return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
+ pure (filter ((".tix" `L.isSuffixOf`) . toFilePath) files)
extraTixFiles <- findExtraTixFiles
let tixFiles = tixFiles0 ++ extraTixFiles
reportDir = outputDir relDirCombined relDirAll
@@ -322,9 +351,9 @@
logDebug $ "Using the following tix files: " <> fromString (show tixFiles)
unless (null errs) $ logWarn $
"The following modules are left out of the " <>
- RIO.display report <>
+ display report <>
" due to version mismatches: " <>
- mconcat (intersperse ", " (map fromString errs))
+ mconcat (L.intersperse ", " (map fromString errs))
tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix")
ensureDir (parent tixDest)
liftIO $ writeTix (toFilePath tixDest) tix
@@ -333,11 +362,17 @@
readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog path = do
mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do
- logError $ "Error while reading tix: " <> fromString (show errorCall)
- return Nothing
+ logError $
+ "Error: [S-3521]\n" <>
+ "Error while reading tix: " <>
+ fromString (displayException errorCall)
+ pure Nothing
when (isNothing mtix) $
- logError $ "Failed to read tix file " <> fromString (toFilePath path)
- return mtix
+ logError $
+ "Error: [S-7786]\n" <>
+ "Failed to read tix file " <>
+ fromString (toFilePath path)
+ pure mtix
-- | Module names which contain '/' have a package name, and so they weren't built into the
-- executable.
@@ -365,11 +400,11 @@
forM subdirs $ \subdir -> do
let indexPath = subdir relFileHpcIndexHtml
exists' <- doesFileExist indexPath
- if not exists' then return Nothing else do
+ if not exists' then pure Nothing else do
relPath <- stripProperPrefix outputDir indexPath
let package = dirname dir
testsuite = dirname subdir
- return $ Just $ T.concat
+ pure $ Just $ T.concat
[ "| "
, pathToHtml package
, " | String
-dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname
+dirnameString = L.dropWhileEnd isPathSeparator . toFilePath . dirname
findPackageFieldForBuiltPackage
:: HasEnvConfig env
@@ -445,11 +480,11 @@
distDir <- distDirFromDir pkgDir
let inplaceDir = distDir relDirPackageConfInplace
pkgIdStr = packageIdentifierString pkgId
- notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr
+ notFoundErr = pure $ Left $ "Failed to find package key for " <> T.pack pkgIdStr
extractField path = do
contents <- readFileUtf8 (toFilePath path)
case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of
- Just result -> return $ Right $ T.strip result
+ Just result -> pure $ Right $ T.strip result
Nothing -> notFoundErr
cabalVer <- view cabalVersionL
if cabalVer < mkVersion [1, 24]
@@ -462,7 +497,7 @@
else do
-- With Cabal-1.24, it's in a different location.
logDebug $ "Scanning " <> fromString (toFilePath inplaceDir) <> " for files matching " <> fromString pkgIdStr
- (_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir
+ (_, files) <- handleIO (const $ pure ([], [])) $ listDir inplaceDir
logDebug $ displayShow files
-- From all the files obtained from the scanning process above, we
-- need to identify which are .conf files and then ensure that
@@ -487,9 +522,9 @@
paths -> do
(errors, keys) <- partitionEithers <$> traverse extractField paths
case errors of
- (a:_) -> return $ Left a -- the first error only, since they're repeated anyway
- [] -> return $ Right keys
- else return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>
+ (a:_) -> pure $ Left a -- the first error only, since they're repeated anyway
+ [] -> pure $ Right keys
+ else pure $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>
T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"
displayReportPath :: (HasTerm env)
@@ -506,5 +541,5 @@
if dirExists
then do
(_, files) <- listDir dir
- return $ filter ((".tix" `isSuffixOf`) . toFilePath) files
- else return []
+ pure $ filter ((".tix" `L.isSuffixOf`) . toFilePath) files
+ else pure []
diff --git a/src/Stack/DefaultColorWhen.hs b/src/Stack/DefaultColorWhen.hs
--- a/src/Stack/DefaultColorWhen.hs
+++ b/src/Stack/DefaultColorWhen.hs
@@ -2,11 +2,10 @@
( defaultColorWhen
) where
-import Stack.Prelude (stdout)
-import Stack.Types.Config (ColorWhen (ColorAuto, ColorNever))
-
-import System.Console.ANSI (hSupportsANSIWithoutEmulation)
-import System.Environment (lookupEnv)
+import Stack.Prelude ( stdout )
+import Stack.Types.Config ( ColorWhen (ColorAuto, ColorNever) )
+import System.Console.ANSI ( hSupportsANSIWithoutEmulation )
+import System.Environment ( lookupEnv )
-- | The default adopts the standard proposed at http://no-color.org/, that
-- color should not be added by default if the @NO_COLOR@ environment variable
@@ -20,7 +19,7 @@
-- command line.
supportsANSI <- hSupportsANSIWithoutEmulation stdout
mIsNoColor <- lookupEnv "NO_COLOR"
- return $ case mIsNoColor of
+ pure $ case mIsNoColor of
Just _ -> ColorNever
_ -> case supportsANSI of
Just False -> ColorNever
diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs
--- a/src/Stack/Docker.hs
+++ b/src/Stack/Docker.hs
@@ -10,67 +10,70 @@
-- | Run commands in Docker containers
module Stack.Docker
- (dockerCmdName
- ,dockerHelpOptName
- ,dockerPullCmdName
- ,entrypoint
- ,preventInContainer
- ,pull
- ,reset
- ,reExecArgName
- ,StackDockerException(..)
- ,getProjectRoot
- ,runContainerAndExit
+ ( dockerCmdName
+ , dockerHelpOptName
+ , dockerPullCmdName
+ , entrypoint
+ , preventInContainer
+ , pull
+ , reset
+ , reExecArgName
+ , DockerException (..)
+ , getProjectRoot
+ , runContainerAndExit
) where
-import Stack.Prelude
-import qualified Crypto.Hash as Hash (Digest, MD5, hash)
-import Pantry.Internal.AesonExtended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
+import qualified Crypto.Hash as Hash ( Digest, MD5, hash )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as LBS
-import Data.Char (isAscii,isDigit)
-import Data.Conduit.List (sinkNull)
-import Data.Conduit.Process.Typed hiding (proc)
-import Data.List (dropWhileEnd,isPrefixOf,isInfixOf)
-import Data.List.Extra (trim)
+import Data.Char ( isAscii, isDigit )
+import Data.Conduit.List ( sinkNull )
+import Data.Conduit.Process.Typed hiding ( proc )
+import Data.List ( dropWhileEnd, isInfixOf, isPrefixOf )
+import Data.List.Extra ( trim )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import Data.Time (UTCTime)
-import qualified Data.Version (showVersion, parseVersion)
-import Distribution.Version (mkVersion, mkVersion')
+import Data.Time ( UTCTime )
+import qualified Data.Version ( parseVersion )
+import Distribution.Version ( mkVersion, mkVersion' )
+import Pantry.Internal.AesonExtended
+ ( FromJSON (..), (.:), (.:?), (.!=), eitherDecode )
import Path
-import Path.Extra (toFilePathNoTrailingSep)
-import Path.IO hiding (canonicalizePath)
-import qualified Paths_stack as Meta
-import Stack.Config (getInContainer)
+import Path.Extra ( toFilePathNoTrailingSep )
+import Path.IO hiding ( canonicalizePath )
+import qualified RIO.Directory
+import RIO.Process
+import Stack.Config ( getInContainer )
import Stack.Constants
import Stack.Constants.Config
-import Stack.Setup (ensureDockerStackExe)
-import Stack.Storage.User (loadDockerImageExeCache,saveDockerImageExeCache)
-import Stack.Types.Version
+import Stack.Prelude
+import Stack.Setup ( ensureDockerStackExe )
+import Stack.Storage.User
+ ( loadDockerImageExeCache, saveDockerImageExeCache )
import Stack.Types.Config
import Stack.Types.Docker
-import System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)
+import Stack.Types.Version ( showStackVersion, withinRange )
+import System.Environment
+ ( getArgs, getEnv, getEnvironment, getExecutablePath
+ , getProgName
+ )
import qualified System.FilePath as FP
-import System.IO.Error (isDoesNotExistError)
-import System.IO.Unsafe (unsafePerformIO)
-import qualified System.PosixCompat.User as User
-import qualified System.PosixCompat.Files as Files
-import System.Terminal (hIsTerminalDeviceOrMinTTY)
-import Text.ParserCombinators.ReadP (readP_to_S)
-import RIO.Process
-import qualified RIO.Directory
-
+import System.IO.Error ( isDoesNotExistError )
+import System.IO.Unsafe ( unsafePerformIO )
#ifndef WINDOWS
import System.Posix.Signals
import qualified System.Posix.User as PosixUser
#endif
+import qualified System.PosixCompat.User as User
+import qualified System.PosixCompat.Files as Files
+import System.Terminal ( hIsTerminalDeviceOrMinTTY )
+import Text.ParserCombinators.ReadP ( readP_to_S )
-- | Function to get command and arguments to run in Docker container
-getCmdArgs
- :: HasConfig env
+getCmdArgs ::
+ HasConfig env
=> DockerOpts
-> Inspect
-> Bool
@@ -86,11 +89,11 @@
duUmask <- Files.setFileCreationMask 0o022
-- Only way to get old umask seems to be to change it, so set it back afterward
_ <- Files.setFileCreationMask duUmask
- return (Just DockerUser{..})
- else return Nothing
+ pure (Just DockerUser{..})
+ else pure Nothing
args <-
fmap
- (["--" ++ reExecArgName ++ "=" ++ Data.Version.showVersion Meta.version
+ (["--" ++ reExecArgName ++ "=" ++ showStackVersion
,"--" ++ dockerEntrypointArgName
,show DockerEntrypoint{..}] ++)
(liftIO getArgs)
@@ -102,7 +105,7 @@
| otherwise -> throwIO UnsupportedStackExeHostPlatformException
Just DockerStackExeImage -> do
progName <- liftIO getProgName
- return (FP.takeBaseName progName, args, [], [])
+ pure (FP.takeBaseName progName, args, [], [])
Just (DockerStackExePath path) -> do
cmdArgs args path
Just DockerStackExeDownload -> exeDownload args
@@ -116,7 +119,7 @@
(iiId imageInfo)
exePath
exeTimestamp
- return (exePath, exeTimestamp, isKnown)
+ pure (exePath, exeTimestamp, isKnown)
case misCompatible of
Just True -> cmdArgs args exePath
Just False -> exeDownload args
@@ -159,7 +162,7 @@
Left _ -> exePath
Right (x, _) -> x
let mountPath = hostBinDir FP. toFilePath (filename exeBase)
- return (mountPath, args, [], [Mount (toFilePath exePath) mountPath])
+ pure (mountPath, args, [], [Mount (toFilePath exePath) mountPath])
-- | Error if running in a container.
preventInContainer :: MonadIO m => m () -> m ()
@@ -196,13 +199,13 @@
(logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")
maybeImageInfo <- inspect image
imageInfo@Inspect{..} <- case maybeImageInfo of
- Just ii -> return ii
+ Just ii -> pure ii
Nothing
| dockerAutoPull docker ->
do pullImage docker image
mii2 <- inspect image
case mii2 of
- Just ii2 -> return ii2
+ Just ii2 -> pure ii2
Nothing -> throwM (InspectFailedException image)
| otherwise -> throwM (NotPulledException image)
projectRoot <- getProjectRoot
@@ -225,7 +228,7 @@
when (isNothing mpath) $ do
logWarn "The Docker image does not set the PATH env var"
logWarn "This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"
- newPathEnv <- either throwM return $ augmentPath
+ newPathEnv <- either throwM pure $ augmentPath
[ hostBinDir
, toFilePath (sandboxHomeDir relDirDotLocal relDirBin)]
mpath
@@ -305,7 +308,7 @@
threadDelay 30000000
readProcessNull "docker" ["kill",containerID]
oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
- return (sig, oldHandler)
+ pure (sig, oldHandler)
#endif
let args' = concat [["start"]
,["-a" | not (dockerDetach docker)]
@@ -315,7 +318,7 @@
`finally`
(do unless (dockerPersist docker || dockerDetach docker) $
readProcessNull "docker" ["rm","-f",containerID]
- `catch` (\(_::ExitCodeException) -> return ())
+ `catch` (\(_::ExitCodeException) -> pure ())
#ifndef WINDOWS
forM_ oldHandlers $ \(sig,oldHandler) ->
liftIO $ installHandler sig oldHandler Nothing
@@ -343,14 +346,14 @@
inspect image =
do results <- inspects [image]
case Map.toList results of
- [] -> return Nothing
- [(_,i)] -> return (Just i)
+ [] -> pure Nothing
+ [(_,i)] -> pure (Just i)
_ -> throwIO (InvalidInspectOutputException "expect a single result")
-- | Inspect multiple Docker images and/or containers.
inspects :: (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env (Map Text Inspect)
-inspects [] = return Map.empty
+inspects [] = pure Map.empty
inspects images =
do maybeInspectOut <-
-- not using 'readDockerProcess' as the error from a missing image
@@ -361,9 +364,9 @@
-- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8
case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of
Left msg -> throwIO (InvalidInspectOutputException msg)
- Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))
+ Right results -> pure (Map.fromList (map (\r -> (iiId r,r)) results))
Left ece
- | any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes -> return Map.empty
+ | any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes -> pure Map.empty
Left e -> throwIO e
where missingImagePrefixes = ["Error: No such image", "Error: No such object:"]
@@ -400,12 +403,12 @@
pc0
runProcess pc
case ec of
- ExitSuccess -> return ()
+ ExitSuccess -> pure ()
ExitFailure _ -> throwIO (PullFailedException image)
-- | Check docker version (throws exception if incorrect)
-checkDockerVersion
- :: (HasProcessContext env, HasLogFunc env)
+checkDockerVersion ::
+ (HasProcessContext env, HasLogFunc env)
=> DockerOpts -> RIO env ()
checkDockerVersion docker =
do dockerExists <- doesExecutableExist "docker"
@@ -422,7 +425,7 @@
| not (v' `withinRange` dockerRequireDockerVersion docker) ->
throwIO (BadDockerVersionException (dockerRequireDockerVersion docker) v')
| otherwise ->
- return ()
+ pure ()
_ -> throwIO InvalidVersionOutputException
_ -> throwIO InvalidVersionOutputException
where minimumDockerVersion = mkVersion [1, 6, 0]
@@ -457,14 +460,14 @@
User.getUserEntryForName stackUserName
-- Switch UID/GID if needed, and update user's home directory
case deUser of
- Nothing -> return ()
- Just (DockerUser 0 _ _ _) -> return ()
+ Nothing -> pure ()
+ Just (DockerUser 0 _ _ _) -> pure ()
Just du -> withProcessContext envOverride $ updateOrCreateStackUser estackUserEntry0 homeDir du
case estackUserEntry0 of
- Left _ -> return ()
+ Left _ -> pure ()
Right ue -> do
-- If the 'stack' user exists in the image, copy any build plans and package indices from
- -- its original home directory to the host's stack root, to avoid needing to download them
+ -- its original home directory to the host's Stack root, to avoid needing to download them
origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue)
let origStackRoot = origStackHomeDir relDirDotStackProgName
buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)
@@ -476,7 +479,7 @@
unless exists $ do
ensureDir (parent destBuildPlan)
copyFile srcBuildPlan destBuildPlan
- return True
+ pure True
where
updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do
case estackUserEntry of
@@ -516,7 +519,7 @@
#endif
User.setUserID duUid
_ <- Files.setFileCreationMask duUmask
- return ()
+ pure ()
stackUserName = "stack"::String
-- | MVar used to ensure the Docker entrypoint is performed exactly once
@@ -550,8 +553,8 @@
-- e.g. docker pull, in which docker uses stderr for progress output.
--
-- Use 'readProcess_' directly to customize this.
-readDockerProcess
- :: (HasProcessContext env, HasLogFunc env)
+readDockerProcess ::
+ (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env BS.ByteString
readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_
diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs
--- a/src/Stack/Dot.hs
+++ b/src/Stack/Dot.hs
@@ -4,17 +4,18 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-module Stack.Dot (dot
- ,listDependencies
- ,DotOpts(..)
- ,DotPayload(..)
- ,ListDepsOpts(..)
- ,ListDepsFormat(..)
- ,ListDepsFormatOpts(..)
- ,resolveDependencies
- ,printGraph
- ,pruneGraph
- ) where
+module Stack.Dot
+ ( dot
+ , listDependencies
+ , DotOpts (..)
+ , DotPayload (..)
+ , ListDepsOpts (..)
+ , ListDepsFormat (..)
+ , ListDepsFormatOpts (..)
+ , resolveDependencies
+ , printGraph
+ , pruneGraph
+ ) where
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBC8
@@ -25,68 +26,89 @@
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Traversable as T
-import Distribution.Text (display)
+import Distribution.License ( License (BSD3), licenseFromSPDX )
import qualified Distribution.PackageDescription as PD
import qualified Distribution.SPDX.License as SPDX
-import Distribution.License (License(BSD3), licenseFromSPDX)
-import Distribution.Types.PackageName (mkPackageName)
+import Distribution.Text ( display )
+import Distribution.Types.PackageName ( mkPackageName )
import qualified Path
-import RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..))
-import RIO.Process (HasProcessContext (..))
-import Stack.Build (loadPackage)
-import Stack.Build.Installed (getInstalled, toInstallMap)
+import RIO.Process ( HasProcessContext (..) )
+import Stack.Build ( loadPackage )
+import Stack.Build.Installed ( getInstalled, toInstallMap )
import Stack.Build.Source
+import Stack.Build.Target( NeedTargets (..), parseTargets )
import Stack.Constants
import Stack.Package
-import Stack.Prelude hiding (Display (..), pkgName, loadPackage)
-import qualified Stack.Prelude (pkgName)
+import Stack.Prelude hiding ( Display (..), pkgName, loadPackage )
+import qualified Stack.Prelude ( pkgName )
import Stack.Runners
import Stack.SourceMap
import Stack.Types.Build
-import Stack.Types.Compiler (wantedToActual)
+import Stack.Types.Compiler ( wantedToActual )
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.SourceMap
-import Stack.Build.Target(NeedTargets(..), parseTargets)
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Dot" module.
+data DotException
+ = DependencyNotFoundBug GhcPkgId
+ | PackageNotFoundBug PackageName
+ deriving (Show, Typeable)
+
+instance Exception DotException where
+ displayException (DependencyNotFoundBug depId) = bugReport "[S-7071]" $ concat
+ [ "Expected to find "
+ , ghcPkgIdString depId
+ , " in global DB."
+ ]
+ displayException (PackageNotFoundBug pkgName) = bugReport "[S-7151]" $ concat
+ [ "The '"
+ , packageNameString pkgName
+ , "' package was not found in any of the dependency sources."
+ ]
+
-- | Options record for @stack dot@
data DotOpts = DotOpts
- { dotIncludeExternal :: !Bool
- -- ^ Include external dependencies
- , dotIncludeBase :: !Bool
- -- ^ Include dependencies on base
- , dotDependencyDepth :: !(Maybe Int)
- -- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint
- , dotPrune :: !(Set PackageName)
- -- ^ Package names to prune from the graph
- , dotTargets :: [Text]
- -- ^ stack TARGETs to trace dependencies for
- , dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
- -- ^ Flags to apply when calculating dependencies
- , dotTestTargets :: Bool
- -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.
- , dotBenchTargets :: Bool
- -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.
- , dotGlobalHints :: Bool
- -- ^ Use global hints instead of relying on an actual GHC installation.
- }
+ { dotIncludeExternal :: !Bool
+ -- ^ Include external dependencies
+ , dotIncludeBase :: !Bool
+ -- ^ Include dependencies on base
+ , dotDependencyDepth :: !(Maybe Int)
+ -- ^ Limit the depth of dependency resolution to (Just n) or continue until
+ -- fixpoint
+ , dotPrune :: !(Set PackageName)
+ -- ^ Package names to prune from the graph
+ , dotTargets :: [Text]
+ -- ^ Stack TARGETs to trace dependencies for
+ , dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
+ -- ^ Flags to apply when calculating dependencies
+ , dotTestTargets :: Bool
+ -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.
+ , dotBenchTargets :: Bool
+ -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.
+ , dotGlobalHints :: Bool
+ -- ^ Use global hints instead of relying on an actual GHC installation.
+ }
-data ListDepsFormatOpts = ListDepsFormatOpts { listDepsSep :: !Text
- -- ^ Separator between the package name and details.
- , listDepsLicense :: !Bool
- -- ^ Print dependency licenses instead of versions.
- }
+data ListDepsFormatOpts = ListDepsFormatOpts
+ { listDepsSep :: !Text
+ -- ^ Separator between the package name and details.
+ , listDepsLicense :: !Bool
+ -- ^ Print dependency licenses instead of versions.
+ }
data ListDepsFormat = ListDepsText ListDepsFormatOpts
| ListDepsTree ListDepsFormatOpts
| ListDepsJSON
+ | ListDepsConstraints
data ListDepsOpts = ListDepsOpts
- { listDepsFormat :: !ListDepsFormat
- -- ^ Format of printing dependencies
- , listDepsDotOpts :: !DotOpts
- -- ^ The normal dot options.
- }
+ { listDepsFormat :: !ListDepsFormat
+ -- ^ Format of printing dependencies
+ , listDepsDotOpts :: !DotOpts
+ -- ^ The normal dot options.
+ }
-- | Visualize the project's dependencies as a graphviz graph
dot :: DotOpts -> RIO Runner ()
@@ -107,20 +129,19 @@
-- | Create the dependency graph and also prune it as specified in the dot
-- options. Returns a set of local names and a map from package names to
-- dependencies.
-createPrunedDependencyGraph :: DotOpts
- -> RIO Runner
- (Set PackageName,
- Map PackageName (Set PackageName, DotPayload))
+createPrunedDependencyGraph
+ :: DotOpts
+ -> RIO Runner (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph dotOpts = withDotConfig dotOpts $ do
localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted)
logDebug "Creating dependency graph"
resultGraph <- createDependencyGraph dotOpts
let pkgsToPrune = if dotIncludeBase dotOpts
- then dotPrune dotOpts
- else Set.insert "base" (dotPrune dotOpts)
+ then dotPrune dotOpts
+ else Set.insert "base" (dotPrune dotOpts)
prunedGraph = pruneGraph localNames pkgsToPrune resultGraph
logDebug "Returning pruned dependency graph"
- return (localNames, prunedGraph)
+ pure (localNames, prunedGraph)
-- | Create the dependency graph, the result is a map from a package
-- name to a tuple of dependencies and payload if available. This
@@ -140,14 +161,19 @@
globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump
let depLoader = createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps
loadPackageDeps name version loc flags ghcOptions cabalConfigOpts
- -- Skip packages that can't be loaded - see
- -- https://github.com/commercialhaskell/stack/issues/2967
- | name `elem` [mkPackageName "rts", mkPackageName "ghc"] =
- return (Set.empty, DotPayload (Just version) (Just $ Right BSD3) Nothing)
- | otherwise =
- fmap (packageAllDeps &&& makePayload loc) (loadPackage loc flags ghcOptions cabalConfigOpts)
+ -- Skip packages that can't be loaded - see
+ -- https://github.com/commercialhaskell/stack/issues/2967
+ | name `elem` [mkPackageName "rts", mkPackageName "ghc"] =
+ pure ( Set.empty
+ , DotPayload (Just version) (Just $ Right BSD3) Nothing )
+ | otherwise =
+ fmap (packageAllDeps &&& makePayload loc)
+ (loadPackage loc flags ghcOptions cabalConfigOpts)
resolveDependencies (dotDependencyDepth dotOpts) graph depLoader
- where makePayload loc pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just $ PLImmutable loc)
+ where
+ makePayload loc pkg = DotPayload (Just $ packageVersion pkg)
+ (Just $ packageLicense pkg)
+ (Just $ PLImmutable loc)
listDependencies
:: ListDepsOpts
@@ -156,12 +182,24 @@
let dotOpts = listDepsDotOpts opts
(pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts
liftIO $ case listDepsFormat opts of
- ListDepsTree treeOpts -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph
- ListDepsJSON -> printJSON pkgs resultGraph
- ListDepsText textOpts -> void (Map.traverseWithKey go (snd <$> resultGraph))
- where go name payload = Text.putStrLn $ listDepsLine textOpts name payload
+ ListDepsTree treeOpts ->
+ Text.putStrLn "Packages"
+ >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph
+ ListDepsJSON -> printJSON pkgs resultGraph
+ ListDepsText textOpts ->
+ void $ Map.traverseWithKey (go "" textOpts) (snd <$> resultGraph)
+ ListDepsConstraints -> do
+ let constraintOpts = ListDepsFormatOpts " ==" False
+ Text.putStrLn "constraints:"
+ void $ Map.traverseWithKey (go " , " constraintOpts)
+ (snd <$> resultGraph)
+ where
+ go prefix lineOpts name payload =
+ Text.putStrLn $ prefix <> listDepsLine lineOpts name payload
-data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload))
+data DependencyTree =
+ DependencyTree (Set PackageName)
+ (Map PackageName (Set PackageName, DotPayload))
instance ToJSON DependencyTree where
toJSON (DependencyTree _ dependencyMap) =
@@ -171,38 +209,50 @@
foldToList f = Map.foldrWithKey (\k a bs -> bs ++ [f k a]) []
dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
-dependencyToJSON pkg (deps, payload) = let fieldsAlwaysPresent = [ "name" .= packageNameString pkg
- , "license" .= licenseText payload
- , "version" .= versionText payload
- , "dependencies" .= Set.map packageNameString deps
- ]
- loc = catMaybes [("location" .=) . pkgLocToJSON <$> payloadLocation payload]
- in object $ fieldsAlwaysPresent ++ loc
+dependencyToJSON pkg (deps, payload) =
+ let fieldsAlwaysPresent = [ "name" .= packageNameString pkg
+ , "license" .= licenseText payload
+ , "version" .= versionText payload
+ , "dependencies" .= Set.map packageNameString deps
+ ]
+ loc = catMaybes
+ [("location" .=) . pkgLocToJSON <$> payloadLocation payload]
+ in object $ fieldsAlwaysPresent ++ loc
pkgLocToJSON :: PackageLocation -> Value
-pkgLocToJSON (PLMutable (ResolvedPath _ dir)) = object [ "type" .= ("project package" :: Text)
- , "url" .= ("file://" ++ Path.toFilePath dir)]
-pkgLocToJSON (PLImmutable (PLIHackage pkgid _ _)) = object [ "type" .= ("hackage" :: Text)
- , "url" .= ("https://hackage.haskell.org/package/" ++ display pkgid)]
-pkgLocToJSON (PLImmutable (PLIArchive archive _)) = let url = case archiveLocation archive of
- ALUrl u -> u
- ALFilePath (ResolvedPath _ path) -> Text.pack $ "file://" ++ Path.toFilePath path
- in object [ "type" .= ("archive" :: Text)
- , "url" .= url
- , "sha256" .= archiveHash archive
- , "size" .= archiveSize archive ]
-pkgLocToJSON (PLImmutable (PLIRepo repo _)) = object [ "type" .= case repoType repo of
- RepoGit -> "git" :: Text
- RepoHg -> "hg" :: Text
- , "url" .= repoUrl repo
- , "commit" .= repoCommit repo
- , "subdir" .= repoSubdir repo
- ]
+pkgLocToJSON (PLMutable (ResolvedPath _ dir)) = object
+ [ "type" .= ("project package" :: Text)
+ , "url" .= ("file://" ++ Path.toFilePath dir)
+ ]
+pkgLocToJSON (PLImmutable (PLIHackage pkgid _ _)) = object
+ [ "type" .= ("hackage" :: Text)
+ , "url" .= ("https://hackage.haskell.org/package/" ++ display pkgid)
+ ]
+pkgLocToJSON (PLImmutable (PLIArchive archive _)) =
+ let url = case archiveLocation archive of
+ ALUrl u -> u
+ ALFilePath (ResolvedPath _ path) ->
+ Text.pack $ "file://" ++ Path.toFilePath path
+ in object
+ [ "type" .= ("archive" :: Text)
+ , "url" .= url
+ , "sha256" .= archiveHash archive
+ , "size" .= archiveSize archive
+ ]
+pkgLocToJSON (PLImmutable (PLIRepo repo _)) = object
+ [ "type" .= case repoType repo of
+ RepoGit -> "git" :: Text
+ RepoHg -> "hg" :: Text
+ , "url" .= repoUrl repo
+ , "commit" .= repoCommit repo
+ , "subdir" .= repoSubdir repo
+ ]
printJSON :: Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
-printJSON pkgs dependencyMap = LBC8.putStrLn $ encode $ DependencyTree pkgs dependencyMap
+printJSON pkgs dependencyMap =
+ LBC8.putStrLn $ encode $ DependencyTree pkgs dependencyMap
treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots opts projectPackages' =
@@ -220,18 +270,19 @@
-> IO ()
printTree opts dotOpts depth remainingDepsCounts packages dependencyMap =
F.sequence_ $ Seq.mapWithIndex go (toSeq packages)
- where
- toSeq = Seq.fromList . Set.toList
- go index name = let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1]
- in
- case Map.lookup name dependencyMap of
- Just (deps, payload) -> do
- printTreeNode opts dotOpts depth newDepsCounts deps payload name
- if Just depth == dotDependencyDepth dotOpts
- then return ()
- else printTree opts dotOpts (depth + 1) newDepsCounts deps dependencyMap
- -- TODO: Define this behaviour, maybe return an error?
- Nothing -> return ()
+ where
+ toSeq = Seq.fromList . Set.toList
+ go index name =
+ let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1]
+ in case Map.lookup name dependencyMap of
+ Just (deps, payload) -> do
+ printTreeNode opts dotOpts depth newDepsCounts deps payload name
+ if Just depth == dotDependencyDepth dotOpts
+ then pure ()
+ else printTree opts dotOpts (depth + 1) newDepsCounts deps
+ dependencyMap
+ -- TODO: Define this behaviour, maybe pure an error?
+ Nothing -> pure ()
printTreeNode :: ListDepsFormatOpts
-> DotOpts
@@ -244,7 +295,9 @@
printTreeNode opts dotOpts depth remainingDepsCounts deps payload name =
let remainingDepth = fromMaybe 999 (dotDependencyDepth dotOpts) - depth
hasDeps = not $ null deps
- in Text.putStrLn $ treeNodePrefix "" remainingDepsCounts hasDeps remainingDepth <> " " <> listDepsLine opts name payload
+ in Text.putStrLn $
+ treeNodePrefix "" remainingDepsCounts hasDeps remainingDepth <> " " <>
+ listDepsLine opts name payload
treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix t [] _ _ = t
@@ -258,7 +311,9 @@
treeNodePrefix t (_:ns) d remainingDepth = treeNodePrefix (t <> "│ ") ns d remainingDepth
listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
-listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText opts payload
+listDepsLine opts name payload =
+ Text.pack (packageNameString name) <> listDepsSep opts <>
+ payloadText opts payload
payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText opts payload =
@@ -267,10 +322,13 @@
else versionText payload
licenseText :: DotPayload -> Text
-licenseText payload = maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)
+licenseText payload =
+ maybe "" (Text.pack . display . either licenseFromSPDX id)
+ (payloadLicense payload)
versionText :: DotPayload -> Text
-versionText payload = maybe "" (Text.pack . display) (payloadVersion payload)
+versionText payload =
+ maybe "" (Text.pack . display) (payloadVersion payload)
-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in
-- @graph@ with a name in @toPrune@ and removes resulting orphans
@@ -295,105 +353,122 @@
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable dontPrune = fixpoint prune
- where fixpoint :: Eq a => (a -> a) -> a -> a
- fixpoint f v = if f v == v then v else fixpoint f (f v)
- prune graph' = Map.filterWithKey (\k _ -> reachable k) graph'
- where reachable k = k `F.elem` dontPrune || k `Set.member` reachables
- reachables = F.fold (fst <$> graph')
+ where
+ fixpoint :: Eq a => (a -> a) -> a -> a
+ fixpoint f v = if f v == v then v else fixpoint f (f v)
+ prune graph' = Map.filterWithKey (\k _ -> reachable k) graph'
+ where
+ reachable k = k `F.elem` dontPrune || k `Set.member` reachables
+ reachables = F.fold (fst <$> graph')
-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached
-resolveDependencies :: (Applicative m, Monad m)
- => Maybe Int
- -> Map PackageName (Set PackageName, DotPayload)
- -> (PackageName -> m (Set PackageName, DotPayload))
- -> m (Map PackageName (Set PackageName, DotPayload))
-resolveDependencies (Just 0) graph _ = return graph
+resolveDependencies
+ :: (Applicative m, Monad m)
+ => Maybe Int
+ -> Map PackageName (Set PackageName, DotPayload)
+ -> (PackageName -> m (Set PackageName, DotPayload))
+ -> m (Map PackageName (Set PackageName, DotPayload))
+resolveDependencies (Just 0) graph _ = pure graph
resolveDependencies limit graph loadPackageDeps = do
let values = Set.unions (fst <$> Map.elems graph)
keys = Map.keysSet graph
next = Set.difference values keys
if Set.null next
- then return graph
+ then pure graph
else do
x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next)
resolveDependencies (subtract 1 <$> limit)
(Map.unionWith unifier graph (Map.fromList x))
loadPackageDeps
- where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1)
+ where
+ unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1)
--- | Given a SourceMap and a dependency loader, load the set of dependencies for a package
-createDepLoader :: SourceMap
- -> Map PackageName DumpPackage
- -> Map GhcPkgId PackageIdentifier
- -> (PackageName -> Version -> PackageLocationImmutable ->
- Map FlagName Bool -> [Text] -> [Text] -> RIO DotConfig (Set PackageName, DotPayload))
- -> PackageName
- -> RIO DotConfig (Set PackageName, DotPayload)
+-- | Given a SourceMap and a dependency loader, load the set of dependencies for
+-- a package
+createDepLoader
+ :: SourceMap
+ -> Map PackageName DumpPackage
+ -> Map GhcPkgId PackageIdentifier
+ -> (PackageName -> Version -> PackageLocationImmutable ->
+ Map FlagName Bool -> [Text] -> [Text] ->
+ RIO DotConfig (Set PackageName, DotPayload))
+ -> PackageName
+ -> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do
- fromMaybe noDepsErr
+ fromMaybe (throwIO $ PackageNotFoundBug pkgName)
(projectPackageDeps <|> dependencyDeps <|> globalDeps)
- where
- projectPackageDeps =
- loadDeps <$> Map.lookup pkgName (smProject sourceMap)
- where
- loadDeps pp = do
- pkg <- loadCommonPackage (ppCommon pp)
- pure (packageAllDeps pkg, payloadFromLocal pkg Nothing)
-
- dependencyDeps =
- loadDeps <$> Map.lookup pkgName (smDeps sourceMap)
- where
- loadDeps DepPackage{dpLocation=PLMutable dir} = do
- pp <- mkProjectPackage YesPrintWarnings dir False
- pkg <- loadCommonPackage (ppCommon pp)
- pure (packageAllDeps pkg, payloadFromLocal pkg (Just $ PLMutable dir))
+ where
+ projectPackageDeps = loadDeps <$> Map.lookup pkgName (smProject sourceMap)
+ where
+ loadDeps pp = do
+ pkg <- loadCommonPackage (ppCommon pp)
+ pure (packageAllDeps pkg, payloadFromLocal pkg Nothing)
- loadDeps dp@DepPackage{dpLocation=PLImmutable loc} = do
- let common = dpCommon dp
- gpd <- liftIO $ cpGPD common
- let PackageIdentifier name version = PD.package $ PD.packageDescription gpd
- flags = cpFlags common
- ghcOptions = cpGhcOptions common
- cabalConfigOpts = cpCabalConfigOpts common
- assert (pkgName == name) (loadPackageDeps pkgName version loc flags ghcOptions cabalConfigOpts)
+ dependencyDeps =
+ loadDeps <$> Map.lookup pkgName (smDeps sourceMap)
+ where
+ loadDeps DepPackage{dpLocation=PLMutable dir} = do
+ pp <- mkProjectPackage YesPrintWarnings dir False
+ pkg <- loadCommonPackage (ppCommon pp)
+ pure (packageAllDeps pkg, payloadFromLocal pkg (Just $ PLMutable dir))
- -- If package is a global package, use info from ghc-pkg (#4324, #3084)
- globalDeps =
- pure . getDepsFromDump <$> Map.lookup pkgName globalDumpMap
- where
- getDepsFromDump dump =
- (Set.fromList deps, payloadFromDump dump)
- where
- deps = map ghcIdToPackageName (dpDepends dump)
- ghcIdToPackageName depId =
- let errText = "Invariant violated: Expected to find "
- in maybe (error (errText ++ ghcPkgIdString depId ++ " in global DB"))
- Stack.Prelude.pkgName
- (Map.lookup depId globalIdMap)
+ loadDeps dp@DepPackage{dpLocation=PLImmutable loc} = do
+ let common = dpCommon dp
+ gpd <- liftIO $ cpGPD common
+ let PackageIdentifier name version = PD.package $ PD.packageDescription gpd
+ flags = cpFlags common
+ ghcOptions = cpGhcOptions common
+ cabalConfigOpts = cpCabalConfigOpts common
+ assert
+ (pkgName == name)
+ (loadPackageDeps pkgName version loc flags ghcOptions cabalConfigOpts)
- noDepsErr = error ("Invariant violated: The '" ++ packageNameString pkgName
- ++ "' package was not found in any of the dependency sources")
+ -- If package is a global package, use info from ghc-pkg (#4324, #3084)
+ globalDeps =
+ pure . getDepsFromDump <$> Map.lookup pkgName globalDumpMap
+ where
+ getDepsFromDump dump = (Set.fromList deps, payloadFromDump dump)
+ where
+ deps = map ghcIdToPackageName (dpDepends dump)
+ ghcIdToPackageName depId =
+ maybe (impureThrow $ DependencyNotFoundBug depId)
+ Stack.Prelude.pkgName
+ (Map.lookup depId globalIdMap)
- payloadFromLocal pkg loc = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) loc
- payloadFromDump dp = DotPayload (Just $ pkgVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) Nothing
+ payloadFromLocal pkg loc =
+ DotPayload (Just $ packageVersion pkg)
+ (Just $ packageLicense pkg)
+ loc
+ payloadFromDump dp =
+ DotPayload (Just $ pkgVersion $ dpPackageIdent dp)
+ (Right <$> dpLicense dp)
+ Nothing
--- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages)
-projectPackageDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
+-- | Resolve the direct (depth 0) external dependencies of the given local
+-- packages (assumed to come from project packages)
+projectPackageDependencies
+ :: DotOpts
+ -> [LocalPackage]
+ -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies dotOpts locals =
- map (\lp -> let pkg = localPackageToPackage lp
- pkgDir = Path.parent $ lpCabalFile lp
- loc = PLMutable $ ResolvedPath (RelFilePath "N/A") pkgDir
- in (packageName pkg, (deps pkg, lpPayload pkg loc)))
- locals
- where deps pkg =
- if dotIncludeExternal dotOpts
- then Set.delete (packageName pkg) (packageAllDeps pkg)
- else Set.intersection localNames (packageAllDeps pkg)
- localNames = Set.fromList $ map (packageName . lpPackage) locals
- lpPayload pkg loc = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just loc)
+ map (\lp -> let pkg = localPackageToPackage lp
+ pkgDir = Path.parent $ lpCabalFile lp
+ loc = PLMutable $ ResolvedPath (RelFilePath "N/A") pkgDir
+ in (packageName pkg, (deps pkg, lpPayload pkg loc)))
+ locals
+ where
+ deps pkg = if dotIncludeExternal dotOpts
+ then Set.delete (packageName pkg) (packageAllDeps pkg)
+ else Set.intersection localNames (packageAllDeps pkg)
+ localNames = Set.fromList $ map (packageName . lpPackage) locals
+ lpPayload pkg loc =
+ DotPayload (Just $ packageVersion pkg)
+ (Just $ packageLicense pkg)
+ (Just loc)
--- | Print a graphviz graph of the edges in the Map and highlight the given local packages
+-- | Print a graphviz graph of the edges in the Map and highlight the given
+-- local packages
printGraph :: (Applicative m, MonadIO m)
=> DotOpts
-> Set PackageName -- ^ all locals
@@ -405,21 +480,24 @@
printLeaves graph
void (Map.traverseWithKey printEdges (fst <$> graph))
liftIO $ Text.putStrLn "}"
- where filteredLocals = Set.filter (\local' ->
- local' `Set.notMember` dotPrune dotOpts) locals
+ where
+ filteredLocals =
+ Set.filter (\local' -> local' `Set.notMember` dotPrune dotOpts) locals
-- | Print the local nodes with a different style depending on options
printLocalNodes :: (F.Foldable t, MonadIO m)
=> DotOpts
-> t PackageName
-> m ()
-printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes)
- where applyStyle :: Text -> Text
- applyStyle n = if dotIncludeExternal dotOpts
- then n <> " [style=dashed];"
- else n <> " [style=solid];"
- lpNodes :: [Text]
- lpNodes = map (applyStyle . nodeName) (F.toList locals)
+printLocalNodes dotOpts locals =
+ liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes)
+ where
+ applyStyle :: Text -> Text
+ applyStyle n = if dotIncludeExternal dotOpts
+ then n <> " [style=dashed];"
+ else n <> " [style=solid];"
+ lpNodes :: [Text]
+ lpNodes = map (applyStyle . nodeName) (F.toList locals)
-- | Print nodes without dependencies
printLeaves :: MonadIO m
@@ -433,7 +511,11 @@
-- | Print an edge between the two package names
printEdge :: MonadIO m => PackageName -> PackageName -> m ()
-printEdge from to' = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to', ";"])
+printEdge from to' =
+ liftIO $ Text.putStrLn (Text.concat [ nodeName from
+ , " -> "
+ , nodeName to'
+ , ";" ])
-- | Convert a package name to a graph node name.
nodeName :: PackageName -> Text
@@ -464,68 +546,72 @@
if dotGlobalHints opts
then withConfig NoReexec $ withBuildConfig withGlobalHints
else withConfig YesReexec withReal
- where
- withGlobalHints = do
- bconfig <- view buildConfigL
- globals <- globalsFromHints $ smwCompiler $ bcSMWanted bconfig
- fakeGhcPkgId <- parseGhcPkgId "ignored"
- actual <- either throwIO pure $
- wantedToActual $ smwCompiler $
- bcSMWanted bconfig
- let smActual = SMActual
- { smaCompiler = actual
- , smaProject = smwProject $ bcSMWanted bconfig
- , smaDeps = smwDeps $ bcSMWanted bconfig
- , smaGlobal = Map.mapWithKey toDump globals
- }
- toDump :: PackageName -> Version -> DumpPackage
- toDump name version = DumpPackage
- { dpGhcPkgId = fakeGhcPkgId
- , dpPackageIdent = PackageIdentifier name version
- , dpParentLibIdent = Nothing
- , dpLicense = Nothing
- , dpLibDirs = []
- , dpLibraries = []
- , dpHasExposedModules = True
- , dpExposedModules = mempty
- , dpDepends = []
- , dpHaddockInterfaces = []
- , dpHaddockHtml = Nothing
- , dpIsExposed = True
- }
- actualPkgs = Map.keysSet (smaDeps smActual) <>
- Map.keysSet (smaProject smActual)
- prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }
- targets <- parseTargets NeedTargets False boptsCLI prunedActual
- logDebug "Loading source map"
- sourceMap <- loadSourceMap targets boptsCLI smActual
- let dc = DotConfig
- { dcBuildConfig = bconfig
- , dcSourceMap = sourceMap
- , dcGlobalDump = toList $ smaGlobal smActual
- }
- logDebug "DotConfig fully loaded"
- runRIO dc inner
+ where
+ withGlobalHints = do
+ bconfig <- view buildConfigL
+ globals <- globalsFromHints $ smwCompiler $ bcSMWanted bconfig
+ fakeGhcPkgId <- parseGhcPkgId "ignored"
+ actual <- either throwIO pure $
+ wantedToActual $ smwCompiler $
+ bcSMWanted bconfig
+ let smActual = SMActual
+ { smaCompiler = actual
+ , smaProject = smwProject $ bcSMWanted bconfig
+ , smaDeps = smwDeps $ bcSMWanted bconfig
+ , smaGlobal = Map.mapWithKey toDump globals
+ }
+ toDump :: PackageName -> Version -> DumpPackage
+ toDump name version = DumpPackage
+ { dpGhcPkgId = fakeGhcPkgId
+ , dpPackageIdent = PackageIdentifier name version
+ , dpParentLibIdent = Nothing
+ , dpLicense = Nothing
+ , dpLibDirs = []
+ , dpLibraries = []
+ , dpHasExposedModules = True
+ , dpExposedModules = mempty
+ , dpDepends = []
+ , dpHaddockInterfaces = []
+ , dpHaddockHtml = Nothing
+ , dpIsExposed = True
+ }
+ actualPkgs = Map.keysSet (smaDeps smActual) <>
+ Map.keysSet (smaProject smActual)
+ prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }
+ targets <- parseTargets NeedTargets False boptsCLI prunedActual
+ logDebug "Loading source map"
+ sourceMap <- loadSourceMap targets boptsCLI smActual
+ let dc = DotConfig
+ { dcBuildConfig = bconfig
+ , dcSourceMap = sourceMap
+ , dcGlobalDump = toList $ smaGlobal smActual
+ }
+ logDebug "DotConfig fully loaded"
+ runRIO dc inner
- withReal = withEnvConfig NeedTargets boptsCLI $ do
- envConfig <- ask
- let sourceMap = envConfigSourceMap envConfig
- installMap <- toInstallMap sourceMap
- (_, globalDump, _, _) <- getInstalled installMap
- let dc = DotConfig
- { dcBuildConfig = envConfigBuildConfig envConfig
- , dcSourceMap = sourceMap
- , dcGlobalDump = globalDump
- }
- runRIO dc inner
+ withReal = withEnvConfig NeedTargets boptsCLI $ do
+ envConfig <- ask
+ let sourceMap = envConfigSourceMap envConfig
+ installMap <- toInstallMap sourceMap
+ (_, globalDump, _, _) <- getInstalled installMap
+ let dc = DotConfig
+ { dcBuildConfig = envConfigBuildConfig envConfig
+ , dcSourceMap = sourceMap
+ , dcGlobalDump = globalDump
+ }
+ runRIO dc inner
- boptsCLI = defaultBuildOptsCLI
- { boptsCLITargets = dotTargets opts
- , boptsCLIFlags = dotFlags opts
- }
- modifyGO =
- (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) .
- (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id)
+ boptsCLI = defaultBuildOptsCLI
+ { boptsCLITargets = dotTargets opts
+ , boptsCLIFlags = dotFlags opts
+ }
+ modifyGO =
+ (if dotTestTargets opts
+ then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True)
+ else id) .
+ (if dotBenchTargets opts
+ then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True)
+ else id)
data DotConfig = DotConfig
{ dcBuildConfig :: !BuildConfig
diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs
--- a/src/Stack/FileWatch.hs
+++ b/src/Stack/FileWatch.hs
@@ -3,19 +3,19 @@
{-# LANGUAGE TupleSections #-}
module Stack.FileWatch
- ( fileWatch
- , fileWatchPoll
- ) where
+ ( WatchMode (WatchModePoll)
+ , fileWatch
+ , fileWatchPoll
+ ) where
-import Control.Concurrent.STM (check)
-import Stack.Prelude
+import Control.Concurrent.STM ( check )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
-import GHC.IO.Exception
-import Path
-import System.FSNotify
-import System.IO (getLine)
-import RIO.PrettyPrint hiding (line)
+import GHC.IO.Exception
+import Path
+import Stack.Prelude
+import System.FSNotify
+import System.IO ( getLine )
fileWatch
:: (HasLogFunc env, HasTerm env)
@@ -27,7 +27,8 @@
:: (HasLogFunc env, HasTerm env)
=> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
-fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True }
+fileWatchPoll =
+ fileWatchConf $ defaultConfig { confWatchMode = WatchModePoll 1000000 }
-- | Run an action, watching for file changes
--
@@ -59,7 +60,7 @@
newDirs
watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do
mv <- mmv
- return $
+ pure $
case mv of
Nothing -> Map.empty
Just v -> Map.singleton k v
@@ -69,24 +70,24 @@
$ Set.toList
$ Set.map parent files
- keepListening _dir listen () = Just $ return $ Just listen
+ keepListening _dir listen () = Just $ pure $ Just listen
stopListening = Map.map $ \f -> do
() <- f `catch` \ioe ->
-- Ignore invalid argument error - it can happen if
-- the directory is removed.
case ioe_type ioe of
- InvalidArgument -> return ()
+ InvalidArgument -> pure ()
_ -> throwIO ioe
- return Nothing
+ pure Nothing
startListening = Map.mapWithKey $ \dir () -> do
let dir' = fromString $ toFilePath dir
listen <- watchDir manager dir' (const True) onChange
- return $ Just listen
+ pure $ Just listen
let watchInput = do
- line <- getLine
- unless (line == "quit") $ do
- run $ case line of
+ l <- getLine
+ unless (l == "quit") $ do
+ run $ case l of
"help" -> do
logInfo ""
logInfo "help: display this help"
@@ -100,7 +101,7 @@
"" -> atomically $ writeTVar dirtyVar True
_ -> logInfo $
"Unknown command: " <>
- displayShow line <>
+ displayShow l <>
". Try 'help'"
watchInput
@@ -126,7 +127,7 @@
let theStyle = case fromException e of
Just ExitSuccess -> Good
_ -> Error
- in style theStyle $ fromString $ show e
+ in style theStyle $ fromString $ displayException e
_ -> style Good "Success! Waiting for next file change."
logInfo "Type help for available commands. Press enter to force a rebuild."
diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
--- a/src/Stack/GhcPkg.hs
+++ b/src/Stack/GhcPkg.hs
@@ -6,98 +6,102 @@
-- | Functions for the GHC package database.
module Stack.GhcPkg
- (getGlobalDB
- ,findGhcPkgField
- ,createDatabase
- ,unregisterGhcPkgIds
- ,ghcPkgPathEnvVar
- ,mkGhcPackagePath)
- where
+ ( createDatabase
+ , findGhcPkgField
+ , getGlobalDB
+ , ghcPkgPathEnvVar
+ , mkGhcPackagePath
+ , unregisterGhcPkgIds
+ ) where
-import Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
-import Data.List
+import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import Path (parent, ())
-import Path.Extra (toFilePathNoTrailingSep)
+import Path ( (), parent )
+import Path.Extra ( toFilePathNoTrailingSep )
import Path.IO
-import Stack.Constants
-import Stack.Types.Config (GhcPkgExe (..))
-import Stack.Types.GhcPkgId
-import Stack.Types.Compiler
-import System.FilePath (searchPathSeparator)
-import RIO.Process
+ ( doesDirExist, doesFileExist, ensureDir, resolveDir' )
+import RIO.Process ( HasProcessContext, proc, readProcess_ )
+import Stack.Constants ( relFilePackageCache )
+import Stack.Prelude
+import Stack.Types.Config ( GhcPkgExe (..) )
+import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
+import Stack.Types.Compiler ( WhichCompiler (..) )
+import System.FilePath ( searchPathSeparator )
-- | Get the global package database
-getGlobalDB
- :: (HasProcessContext env, HasLogFunc env)
+getGlobalDB ::
+ (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> RIO env (Path Abs Dir)
getGlobalDB pkgexe = do
- logDebug "Getting global package database location"
- -- This seems like a strange way to get the global package database
- -- location, but I don't know of a better one
- bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO return
- let fp = S8.unpack $ stripTrailingColon $ firstLine bs
- liftIO $ resolveDir' fp
- where
- stripTrailingColon bs
- | S8.null bs = bs
- | S8.last bs == ':' = S8.init bs
- | otherwise = bs
- firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
+ logDebug "Getting global package database location"
+ -- This seems like a strange way to get the global package database
+ -- location, but I don't know of a better one
+ bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO pure
+ let fp = S8.unpack $ stripTrailingColon $ firstLine bs
+ liftIO $ resolveDir' fp
+ where
+ stripTrailingColon bs
+ | S8.null bs = bs
+ | S8.last bs == ':' = S8.init bs
+ | otherwise = bs
+ firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
-- | Run the ghc-pkg executable
-ghcPkg
- :: (HasProcessContext env, HasLogFunc env)
+ghcPkg ::
+ (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException S8.ByteString)
ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do
- eres <- go
- case eres of
- Left _ -> do
- mapM_ (createDatabase pkgexe) pkgDbs
- go
- Right _ -> return eres
- where
- pkg = toFilePath pkgPath
- go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
- args' = packageDbFlags pkgDbs ++ args
+ eres <- go
+ case eres of
+ Left _ -> do
+ mapM_ (createDatabase pkgexe) pkgDbs
+ go
+ Right _ -> pure eres
+ where
+ pkg = toFilePath pkgPath
+ go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
+ args' = packageDbFlags pkgDbs ++ args
-- | Create a package database in the given directory, if it doesn't exist.
-createDatabase
- :: (HasProcessContext env, HasLogFunc env)
+createDatabase ::
+ (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir
-> RIO env ()
createDatabase (GhcPkgExe pkgPath) db = do
- exists <- doesFileExist (db relFilePackageCache)
- unless exists $ do
- -- ghc-pkg requires that the database directory does not exist
- -- yet. If the directory exists but the package.cache file
- -- does, we're in a corrupted state. Check for that state.
- dirExists <- doesDirExist db
- args <- if dirExists
- then do
- logWarn $
- "The package database located at " <>
- fromString (toFilePath db) <>
- " is corrupted (missing its package.cache file)."
- logWarn "Proceeding with a recache"
- return ["--package-db", toFilePath db, "recache"]
- else 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
- ensureDir (parent db)
- return ["init", toFilePath db]
- void $ proc (toFilePath pkgPath) args $ \pc ->
- readProcess_ pc `onException`
- logError ("Unable to create package database at " <> fromString (toFilePath db))
+ exists <- doesFileExist (db relFilePackageCache)
+ unless exists $ do
+ -- ghc-pkg requires that the database directory does not exist
+ -- yet. If the directory exists but the package.cache file
+ -- does, we're in a corrupted state. Check for that state.
+ dirExists <- doesDirExist db
+ args <- if dirExists
+ then do
+ logWarn $
+ "The package database located at " <>
+ fromString (toFilePath db) <>
+ " is corrupted (missing its package.cache file)."
+ logWarn "Proceeding with a recache"
+ pure ["--package-db", toFilePath db, "recache"]
+ else 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
+ ensureDir (parent db)
+ pure ["init", toFilePath db]
+ void $ proc (toFilePath pkgPath) args $ \pc ->
+ onException (readProcess_ pc) $
+ logError $
+ "Error: [S-9735]\n" <>
+ "Unable to create package database at " <>
+ fromString (toFilePath db)
-- | Get the environment variable to use for the package DB paths.
ghcPkgPathEnvVar :: WhichCompiler -> Text
@@ -106,53 +110,53 @@
-- | Get the necessary ghc-pkg flags for setting up the given package database
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
- "--no-user-package-db"
- : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
+ "--no-user-package-db"
+ : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
-- | Get the value of a field of the package.
-findGhcPkgField
- :: (HasProcessContext env, HasLogFunc env)
- => GhcPkgExe
- -> [Path Abs Dir] -- ^ package databases
- -> String -- ^ package identifier, or GhcPkgId
- -> Text
- -> RIO env (Maybe Text)
+findGhcPkgField ::
+ (HasProcessContext env, HasLogFunc env)
+ => GhcPkgExe
+ -> [Path Abs Dir] -- ^ package databases
+ -> String -- ^ package identifier, or GhcPkgId
+ -> Text
+ -> RIO env (Maybe Text)
findGhcPkgField pkgexe pkgDbs name field = do
- result <-
- ghcPkg
- pkgexe
- pkgDbs
- ["field", "--simple-output", name, T.unpack field]
- return $
- case result of
- Left{} -> Nothing
- Right bs ->
- fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
+ result <-
+ ghcPkg
+ pkgexe
+ pkgDbs
+ ["field", "--simple-output", name, T.unpack field]
+ pure $
+ case result of
+ Left{} -> Nothing
+ Right bs ->
+ fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
-- | unregister list of package ghcids, batching available from GHC 8.2.1,
-- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402
-- using GHC package id where available (from GHC 7.9)
-unregisterGhcPkgIds
- :: (HasProcessContext env, HasLogFunc env)
+unregisterGhcPkgIds ::
+ (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir -- ^ package database
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds pkgexe pkgDb epgids = do
- eres <- ghcPkg pkgexe [pkgDb] args
- case eres of
- Left e -> logWarn $ displayShow e
- Right _ -> return ()
- where
- (idents, gids) = partitionEithers $ toList epgids
- args = "unregister" : "--user" : "--force" :
- map packageIdentifierString idents ++
- if null gids then [] else "--ipid" : map ghcPkgIdString gids
+ eres <- ghcPkg pkgexe [pkgDb] args
+ case eres of
+ Left e -> logWarn $ displayShow e
+ Right _ -> pure ()
+ where
+ (idents, gids) = partitionEithers $ toList epgids
+ args = "unregister" : "--user" : "--force" :
+ map packageIdentifierString idents ++
+ if null gids then [] else "--ipid" : map ghcPkgIdString gids
-- | Get the value for GHC_PACKAGE_PATH
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath locals localdb deps extras globaldb =
- T.pack $ intercalate [searchPathSeparator] $ concat
+ T.pack $ L.intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSep localdb | locals]
, [toFilePathNoTrailingSep deps]
, [toFilePathNoTrailingSep db | db <- reverse extras]
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
--- a/src/Stack/Ghci.hs
+++ b/src/Stack/Ghci.hs
@@ -9,18 +9,18 @@
-- | Run a GHCi configured with the user's package(s).
module Stack.Ghci
- ( GhciOpts(..)
- , GhciPkgInfo(..)
- , GhciException(..)
- , ghci
- ) where
+ ( GhciOpts (..)
+ , GhciPkgInfo (..)
+ , GhciException (..)
+ , ghci
+ ) where
-import Stack.Prelude hiding (Display (..))
-import Control.Monad.State.Strict (State, execState, get, modify)
-import Data.ByteString.Builder (byteString)
+import Control.Monad.State.Strict ( State, execState, get, modify )
+import Data.ByteString.Builder ( byteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
-import Data.List
+import Data.Foldable ( foldl )
+import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Set as S
@@ -29,11 +29,12 @@
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Distribution.PackageDescription as C
import Path
-import Path.Extra (toFilePathNoTrailingSep)
-import Path.IO hiding (withSystemTempDir)
-import qualified RIO
-import RIO.PrettyPrint
-import RIO.Process (HasProcessContext, exec, proc, readProcess_, withWorkingDir)
+import Path.Extra ( toFilePathNoTrailingSep )
+import Path.IO hiding ( withSystemTempDir )
+import RIO.Process
+ ( HasProcessContext, exec, proc, readProcess_
+ , withWorkingDir
+ )
import Stack.Build
import Stack.Build.Installed
import Stack.Build.Source
@@ -42,15 +43,54 @@
import Stack.Constants.Config
import Stack.Ghci.Script
import Stack.Package
+import Stack.Prelude
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Package
+import Stack.Types.PackageFile
import Stack.Types.SourceMap
-import System.IO (putStrLn)
-import System.IO.Temp (getCanonicalTemporaryDirectory)
-import System.Permissions (setScriptPerms)
+import System.IO ( putStrLn )
+import System.IO.Temp ( getCanonicalTemporaryDirectory )
+import System.Permissions ( setScriptPerms )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Ghci" module.
+data GhciException
+ = InvalidPackageOption String
+ | LoadingDuplicateModules
+ | MissingFileTarget String
+ | Can'tSpecifyFilesAndTargets
+ | Can'tSpecifyFilesAndMainIs
+ | GhciTargetParseException [Text]
+ deriving (Show, Typeable)
+
+instance Exception GhciException where
+ displayException (InvalidPackageOption name) =
+ "Error: [S-6716]\n"
+ ++ "Failed to parse '--package' option " ++ name ++ "."
+ displayException LoadingDuplicateModules = unlines
+ [ "Error: [S-9632]"
+ , "Not attempting to start ghci due to these duplicate modules."
+ , "Use '--no-load' to try to start it anyway, without loading any \
+ \modules (but these are still likely to cause errors)."
+ ]
+ displayException (MissingFileTarget name) =
+ "Error: [S-3600]\n"
+ ++ "Cannot find file target " ++ name ++ "."
+ displayException Can'tSpecifyFilesAndTargets =
+ "Error: [S-9906]\n"
+ ++ "Cannot use 'stack ghci' with both file targets and package targets."
+ displayException Can'tSpecifyFilesAndMainIs =
+ "Error: [S-5188]\n"
+ ++ "Cannot use 'stack ghci' with both file targets and '--main-is' \
+ \flag."
+ displayException (GhciTargetParseException xs) =
+ "Error: [S-6948]\n"
+ ++ show (TargetParseException xs)
+ ++ "\nNote that to specify options to be passed to GHCi, use the \
+ \'--ghci-options' flag."
+
-- | Command-line options for GHC.
data GhciOpts = GhciOpts
{ ghciTargets :: ![Text]
@@ -99,34 +139,6 @@
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps = M.unionsWith (M.unionWith S.union)
-data GhciException
- = InvalidPackageOption String
- | LoadingDuplicateModules
- | MissingFileTarget String
- | Can'tSpecifyFilesAndTargets
- | Can'tSpecifyFilesAndMainIs
- | GhciTargetParseException [Text]
- deriving (Typeable)
-
-instance Exception GhciException
-
-instance Show GhciException where
- show (InvalidPackageOption name) =
- "Failed to parse --package option " ++ name
- show LoadingDuplicateModules = unlines
- [ "Not attempting to start ghci due to these duplicate modules."
- , "Use --no-load to try to start it anyway, without loading any modules (but these are still likely to cause errors)"
- ]
- show (MissingFileTarget name) =
- "Cannot find file target " ++ name
- show Can'tSpecifyFilesAndTargets =
- "Cannot use 'stack ghci' with both file targets and package targets"
- show Can'tSpecifyFilesAndMainIs =
- "Cannot use 'stack ghci' with both file targets and --main-is flag"
- show (GhciTargetParseException xs) =
- show (TargetParseException xs) ++
- "\nNote that to specify options to be passed to GHCi, use the --ghci-options flag"
-
-- | Launch a GHCi session for the given local package targets with the
-- given options and configure it with the load paths and extensions
-- of those targets.
@@ -154,14 +166,14 @@
-- Parse to either file targets or build targets
etargets <- preprocessTargets buildOptsCLI sma ghciTargets
(inputTargets, mfileTargets) <- case etargets of
- Right packageTargets -> return (packageTargets, Nothing)
+ Right packageTargets -> pure (packageTargets, Nothing)
Left rawFileTargets -> do
case mainIsTargets of
- Nothing -> return ()
+ Nothing -> pure ()
Just _ -> throwM Can'tSpecifyFilesAndMainIs
-- Figure out targets based on filepath targets
(targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets
- return (targetMap, Just (fileInfo, extraFiles))
+ pure (targetMap, Just (fileInfo, extraFiles))
-- Get a list of all the local target packages.
localTargets <- getAllLocalTargets opts inputTargets mainIsTargets localMap
-- Get a list of all the non-local target packages.
@@ -174,7 +186,7 @@
bopts <- view buildOptsL
mainFile <-
if ghciNoLoadModules
- then return Nothing
+ then pure Nothing
else do
-- Figure out package files, in order to ask the user
-- about which main module to load. See the note below for
@@ -198,15 +210,15 @@
-- Finally, do the invocation of ghci
runGhci opts localTargets mainFile pkgs (maybe [] snd mfileTargets) (nonLocalTargets ++ addPkgs)
-preprocessTargets
- :: HasEnvConfig env
+preprocessTargets ::
+ HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets buildOptsCLI sma rawTargets = do
let (fileTargetsRaw, normalTargetsRaw) =
- partition (\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t)
+ L.partition (\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t)
rawTargets
-- Only use file targets if we have no normal targets.
if not (null fileTargetsRaw) && null normalTargetsRaw
@@ -216,8 +228,8 @@
mpath <- liftIO $ forgivingAbsence (resolveFile' fp)
case mpath of
Nothing -> throwM (MissingFileTarget fp)
- Just path -> return path
- return (Left fileTargets)
+ Just path -> pure path
+ pure (Left fileTargets)
else do
-- Try parsing targets before checking if both file and
-- module targets are specified (see issue#3342).
@@ -227,10 +239,10 @@
TargetParseException xs -> throwM (GhciTargetParseException xs)
_ -> throwM ex
unless (null fileTargetsRaw) $ throwM Can'tSpecifyFilesAndTargets
- return (Right $ smtTargets normalTargets)
+ pure (Right $ smtTargets normalTargets)
-parseMainIsTargets
- :: HasEnvConfig env
+parseMainIsTargets ::
+ HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
@@ -238,24 +250,24 @@
parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do
let boptsCLI = buildOptsCLI { boptsCLITargets = [target] }
targets <- parseTargets AllowNoTargets False boptsCLI sma
- return $ smtTargets targets
+ pure $ smtTargets targets
-- | Display PackageName + NamedComponent
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent = style PkgComponent . fromString . T.unpack . renderPkgComponent
-findFileTargets
- :: HasEnvConfig env
+findFileTargets ::
+ HasEnvConfig env
=> [LocalPackage]
-> [Path Abs File]
-> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File])
findFileTargets locals fileTargets = do
filePackages <- forM locals $ \lp -> do
(_,compFiles,_,_) <- getPackageFiles (packageFiles (lpPackage lp)) (lpCabalFile lp)
- return (lp, M.map (map dotCabalGetPath) compFiles)
+ pure (lp, M.map (map dotCabalGetPath) compFiles)
let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents =
- map (\fp -> (fp, ) $ sort $
+ map (\fp -> (fp, ) $ L.sort $
concatMap (\(lp, files) -> map ((packageName (lpPackage lp), ) . fst)
(filter (elem fp . snd) (M.toList files))
) filePackages
@@ -269,19 +281,19 @@
". This means that the correct ghc options might not be used."
, "Attempting to load the file anyway."
]
- return $ Left fp
+ pure $ Left fp
[x] -> do
prettyInfo $
"Using configuration for" <+> displayPkgComponent x <+>
"to load" <+> pretty fp
- return $ Right (fp, x)
+ pure $ Right (fp, x)
(x:_) -> do
prettyWarn $
"Multiple components contain file target" <+>
pretty fp <> ":" <+>
- mconcat (intersperse ", " (map displayPkgComponent xs)) <> line <>
+ mconcat (L.intersperse ", " (map displayPkgComponent xs)) <> line <>
"Guessing the first one," <+> displayPkgComponent x <> "."
- return $ Right (fp, x)
+ pure $ Right (fp, x)
let (extraFiles, associatedFiles) = partitionEithers results
targetMap =
foldl unionTargets M.empty $
@@ -291,10 +303,10 @@
foldl (M.unionWith (<>)) M.empty $
map (\(fp, (name, _)) -> M.singleton name [fp])
associatedFiles
- return (targetMap, infoMap, extraFiles)
+ pure (targetMap, infoMap, extraFiles)
-getAllLocalTargets
- :: HasEnvConfig env
+getAllLocalTargets ::
+ HasEnvConfig env
=> GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
@@ -317,10 +329,10 @@
-- Figure out
let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps localMap directlyWanted
if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps
- then return directlyWanted
+ then pure directlyWanted
else do
let extraList =
- mconcat $ intersperse ", " (map (fromString . packageNameString . fst) extraLoadDeps)
+ mconcat $ L.intersperse ", " (map (fromString . packageNameString . fst) extraLoadDeps)
if ghciLoadLocalDeps
then logInfo $
"The following libraries will also be loaded into GHCi because " <>
@@ -331,15 +343,15 @@
"they are intermediate dependencies of your targets:\n " <>
extraList <>
"\n(Use --skip-intermediate-deps to omit these)"
- return (directlyWanted ++ extraLoadDeps)
+ pure (directlyWanted ++ extraLoadDeps)
-getAllNonLocalTargets
- :: Map PackageName Target
- -> RIO env [PackageName]
+getAllNonLocalTargets ::
+ Map PackageName Target
+ -> RIO env [PackageName]
getAllNonLocalTargets targets = do
let isNonLocal (TargetAll PTDependency) = True
isNonLocal _ = False
- return $ map fst $ filter (isNonLocal . snd) (M.toList targets)
+ pure $ map fst $ filter (isNonLocal . snd) (M.toList targets)
buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts{..} localTargets = do
@@ -351,21 +363,21 @@
Just nonEmptyTargets | not ghciNoBuild -> do
eres <- buildLocalTargets nonEmptyTargets
case eres of
- Right () -> return ()
+ Right () -> pure ()
Left err -> do
- prettyError $ fromString (show err)
+ prettyError $ fromString (displayException err)
prettyWarn "Build failed, but trying to launch GHCi anyway"
_ ->
- return ()
+ pure ()
checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages pkgs = forM pkgs $ \name -> do
let mres = (pkgName <$> parsePackageIdentifier name)
<|> parsePackageNameThrowing name
- maybe (throwM $ InvalidPackageOption name) return mres
+ maybe (throwM $ InvalidPackageOption name) pure mres
-runGhci
- :: HasEnvConfig env
+runGhci ::
+ HasEnvConfig env
=> GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
@@ -393,25 +405,25 @@
| shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio
| otherwise = bioOneWordOpts bio
genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs)
- (omittedOpts, ghcOpts) = partition badForGhci $
+ (omittedOpts, ghcOpts) = L.partition badForGhci $
concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ map T.unpack
( fold (configGhcOptionsByCat config) -- include everything, locals, and targets
++ concatMap (getUserOptions . ghciPkgName) pkgs
)
getUserOptions pkg = M.findWithDefault [] pkg (configGhcOptionsByName config)
badForGhci x =
- isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror")
+ L.isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror")
unless (null omittedOpts) $
logWarn
("The following GHC options are incompatible with GHCi and have not been passed to it: " <>
- mconcat (intersperse " " (fromString <$> nubOrd omittedOpts)))
+ mconcat (L.intersperse " " (fromString <$> nubOrd omittedOpts)))
oiDir <- view objectInterfaceDirL
let odir =
[ "-odir=" <> toFilePathNoTrailingSep oiDir
, "-hidir=" <> toFilePathNoTrailingSep oiDir ]
logInfo $
"Configuring GHCi with the following packages: " <>
- mconcat (intersperse ", " (map (fromString . packageNameString . ghciPkgName) pkgs))
+ mconcat (L.intersperse ", " (map (fromString . packageNameString . ghciPkgName) pkgs))
compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath
let execGhci extras = do
menv <- liftIO $ configProcessContextSettings config defaultEnvSettings
@@ -438,9 +450,9 @@
menv <- liftIO $ configProcessContextSettings config defaultEnvSettings
output <- withProcessContext menv
$ runGrabFirstLine (fromMaybe compilerExeName ghciGhcCommand) ["--version"]
- return $ "Intero" `isPrefixOf` output
- _ -> return False
- -- Since usage of 'exec' does not return, we cannot do any cleanup
+ pure $ "Intero" `L.isPrefixOf` output
+ _ -> pure False
+ -- Since usage of 'exec' does not pure, we cannot do any cleanup
-- on ghci exit. So, instead leave the generated files. To make this
-- more efficient and avoid gratuitous generation of garbage, the
-- file names are determined by hashing. This also has the nice side
@@ -461,22 +473,26 @@
scriptOptions <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles)
execGhci (macrosOptions ++ scriptOptions)
-writeMacrosFile :: HasTerm env => Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
+writeMacrosFile ::
+ HasTerm env
+ => Path Abs Dir
+ -> [GhciPkgInfo]
+ -> RIO env [String]
writeMacrosFile outputDirectory pkgs = do
fps <- fmap (nubOrd . catMaybes . concat) $
forM pkgs $ \pkg -> forM (ghciPkgOpts pkg) $ \(_, bio) -> do
let cabalMacros = bioCabalMacros bio
exists <- liftIO $ doesFileExist cabalMacros
if exists
- then return $ Just cabalMacros
+ then pure $ Just cabalMacros
else do
prettyWarnL ["Didn't find expected autogen file:", pretty cabalMacros]
- return Nothing
+ pure Nothing
files <- liftIO $ mapM (S8.readFile . toFilePath) fps
- if null files then return [] else do
+ if null files then pure [] else do
out <- liftIO $ writeHashedFile outputDirectory relFileCabalMacrosH $
S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files
- return ["-optP-include", "-optP" <> toFilePath out]
+ pure ["-optP-include", "-optP" <> toFilePath out]
writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String]
writeGhciScript outputDirectory script = do
@@ -484,9 +500,13 @@
LBS.toStrict $ scriptToLazyByteString script
let scriptFilePath = toFilePath scriptPath
setScriptPerms scriptFilePath
- return ["-ghci-script=" <> scriptFilePath]
+ pure ["-ghci-script=" <> scriptFilePath]
-writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
+writeHashedFile ::
+ Path Abs Dir
+ -> Path Rel File
+ -> ByteString
+ -> IO (Path Abs File)
writeHashedFile outputDirectory relFile contents = do
relSha <- shaPathForBytes contents
let outDir = outputDirectory relSha
@@ -495,9 +515,15 @@
unless alreadyExists $ do
ensureDir outDir
writeBinaryFileAtomic outFile $ byteString contents
- return outFile
+ pure outFile
-renderScript :: Bool -> [GhciPkgInfo] -> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
+renderScript ::
+ Bool
+ -> [GhciPkgInfo]
+ -> Maybe (Path Abs File)
+ -> Bool
+ -> [Path Abs File]
+ -> GhciScript
renderScript isIntero pkgs mainFile onlyMain extraFiles = do
let cdPhase = case (isIntero, pkgs) of
-- If only loading one package, set the cwd properly.
@@ -525,8 +551,8 @@
-- | Figure out the main-is file to load based on the targets. Asks the
-- user for input if there is more than one candidate main-is file.
-figureOutMainFile
- :: HasRunner env
+figureOutMainFile ::
+ HasRunner env
=> BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
@@ -534,24 +560,24 @@
-> RIO env (Maybe (Path Abs File))
figureOutMainFile bopts mainIsTargets targets0 packages = do
case candidates of
- [] -> return Nothing
- [c@(_,_,fp)] -> do logInfo ("Using main module: " <> RIO.display (renderCandidate c))
- return (Just fp)
+ [] -> pure Nothing
+ [c@(_,_,fp)] -> do logInfo ("Using main module: " <> display (renderCandidate c))
+ pure (Just fp)
candidate:_ -> do
borderedWarning $ do
logWarn "The main module to load is ambiguous. Candidates are: "
- forM_ (map renderCandidate candidates) (logWarn . RIO.display)
+ forM_ (map renderCandidate candidates) (logWarn . display)
logWarn
"You can specify which one to pick by: "
logWarn
(" * Specifying targets to stack ghci e.g. stack ghci " <>
- RIO.display ( sampleTargetArg candidate))
+ display ( sampleTargetArg candidate))
logWarn
(" * Specifying what the main is e.g. stack ghci " <>
- RIO.display (sampleMainIsArg candidate))
+ display (sampleMainIsArg candidate))
logWarn
(" * Choosing from the candidate above [1.." <>
- RIO.display (length candidates) <> "]")
+ display (length candidates) <> "]")
liftIO userOption
where
targets = fromMaybe (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0)
@@ -566,12 +592,12 @@
M.filterWithKey (\k _ -> k `S.member` wantedComponents)
(ghciPkgMainIs pkg)
main <- mains
- return (ghciPkgName pkg, component, main)
+ pure (ghciPkgName pkg, component, main)
where
wantedComponents =
wantedPackageComponents bopts target (ghciPkgPackage pkg)
renderCandidate c@(pkgName,namedComponent,mainIs) =
- let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . elemIndex c
+ let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . L.elemIndex c
pkgNameText = T.pack (packageNameString pkgName)
in candidateIndex candidates <> ". Package `" <>
pkgNameText <>
@@ -587,20 +613,20 @@
let selected = fromMaybe
((+1) $ length candidateIndices)
(readMaybe (T.unpack option) :: Maybe Int)
- case elemIndex selected candidateIndices of
+ case L.elemIndex selected candidateIndices of
Nothing -> do
putStrLn
"Not loading any main modules, as no valid module selected"
putStrLn ""
- return Nothing
+ pure Nothing
Just op -> do
- let (_,_,fp) = candidates !! op
+ let (_,_,fp) = candidates L.!! op
putStrLn
("Loading main module from candidate " <>
show (op + 1) <> ", --main-is " <>
toFilePath fp)
putStrLn ""
- return $ Just fp
+ pure $ Just fp
renderComp c =
case c of
CLib -> "lib"
@@ -613,8 +639,8 @@
sampleMainIsArg (pkg,comp,_) =
"--main-is " <> T.pack (packageNameString pkg) <> ":" <> renderComp comp
-loadGhciPkgDescs
- :: HasEnvConfig env
+loadGhciPkgDescs ::
+ HasEnvConfig env
=> BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
@@ -623,8 +649,8 @@
loadGhciPkgDesc buildOptsCLI name cabalfp target
-- | Load package description information for a ghci target.
-loadGhciPkgDesc
- :: HasEnvConfig env
+loadGhciPkgDesc ::
+ HasEnvConfig env
=> BuildOptsCLI
-> PackageName
-> Path Abs File
@@ -659,7 +685,8 @@
-- wouldn't have figured out the cabalfp already. In the future:
-- retain that GenericPackageDescription in the relevant data
-- structures to avoid reparsing.
- (gpdio, _name, _cabalfp) <- loadCabalFilePath (parent cabalfp)
+ (gpdio, _name, _cabalfp) <-
+ loadCabalFilePath (Just stackProgName') (parent cabalfp)
gpkgdesc <- liftIO $ gpdio YesPrintWarnings
-- Source the package's *.buildinfo file created by configure if any. See
@@ -681,14 +708,14 @@
(C.updatePackageDescription bi x)
(C.updatePackageDescription bi y))
mbuildinfo
- return GhciPkgDesc
+ pure GhciPkgDesc
{ ghciDescPkg = pkg
, ghciDescCabalFp = cabalfp
, ghciDescTarget = target
}
-getGhciPkgInfos
- :: HasEnvConfig env
+getGhciPkgInfos ::
+ HasEnvConfig env
=> InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
@@ -705,8 +732,8 @@
makeGhciPkgInfo installMap installedMap localLibs addPkgs mfileTargets pkgDesc
-- | Make information necessary to load the given package in GHCi.
-makeGhciPkgInfo
- :: HasEnvConfig env
+makeGhciPkgInfo ::
+ HasEnvConfig env
=> InstallMap
-> InstalledMap
-> [PackageName]
@@ -724,7 +751,7 @@
let filteredOpts = filterWanted opts
filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted)
allWanted = wantedPackageComponents bopts target pkg
- return
+ pure
GhciPkgInfo
{ ghciPkgName = name
, ghciPkgOpts = M.toList filteredOpts
@@ -761,9 +788,9 @@
logWarn "Warning: There are cabal flags for this project which may prevent GHCi from loading your code properly."
logWarn "In some cases it can also load some projects which would otherwise fail to build."
logWarn ""
- mapM_ (logWarn . RIO.display) $ intercalate [""] cabalFlagIssues
+ mapM_ (logWarn . display) $ L.intercalate [""] cabalFlagIssues
logWarn ""
- logWarn "To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files."
+ logWarn "To resolve, remove the flag(s) from the Cabal file(s) and instead put them at the top of the haskell files."
logWarn ""
logWarn "It isn't yet possible to load multiple packages into GHCi in all cases - see"
logWarn "https://ghc.haskell.org/trac/ghc/ticket/10827"
@@ -823,7 +850,7 @@
]
partitionComps f = (map fst xs, map fst ys)
where
- (xs, ys) = partition (any f . snd) compsWithOpts
+ (xs, ys) = L.partition (any f . snd) compsWithOpts
compsWithOpts = map (\(k, bio) -> (k, bioOneWordOpts bio ++ bioOpts bio)) compsWithBios
compsWithBios =
[ ((ghciPkgName pkg, c), bio)
@@ -838,7 +865,7 @@
x <- f
logWarn "* * * * * * * *"
logWarn ""
- return x
+ pure x
-- TODO: Should this also tell the user the filepaths, not just the
-- module name?
@@ -865,8 +892,8 @@
fileDuplicate (fp, comps) =
pretty fp <+> parens (fillSep (punctuate "," (map displayPkgComponent (S.toList comps))))
-targetWarnings
- :: HasBuildConfig env
+targetWarnings ::
+ HasBuildConfig env
=> [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
@@ -877,7 +904,7 @@
[ flow "Some targets"
, parens $ fillSep $ punctuate "," $ map (style Good . fromString . packageNameString) nonLocalTargets
, flow "are not local packages, and so cannot be directly loaded."
- , flow "In future versions of stack, this might be supported - see"
+ , flow "In future versions of Stack, this might be supported - see"
, style Url "https://github.com/commercialhaskell/stack/issues/1441"
, "."
, flow "It can still be useful to specify these, as they will be passed to ghci via -package flags."
@@ -890,7 +917,7 @@
, ""
, flow $ T.unpack $ utf8BuilderToText $
"You are using snapshot: " <>
- RIO.display (smwSnapshotLocation smWanted)
+ display (smwSnapshotLocation smWanted)
, ""
, flow "If you want to use package hiding and options, then you can try one of the following:"
, ""
@@ -913,8 +940,8 @@
--
-- If 'True' is passed for loadAllDeps, this loads all local deps, even
-- if they aren't intermediate.
-getExtraLoadDeps
- :: Bool
+getExtraLoadDeps ::
+ Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
@@ -934,19 +961,19 @@
go name = do
cache <- get
case (M.lookup name cache, M.lookup name localMap) of
- (Just (Just _), _) -> return True
- (Just Nothing, _) | not loadAllDeps -> return False
+ (Just (Just _), _) -> pure True
+ (Just Nothing, _) | not loadAllDeps -> pure False
(_, Just lp) -> do
let deps = M.keys (packageDeps (lpPackage lp))
shouldLoad <- liftM or $ mapM go deps
if shouldLoad
then do
modify (M.insert name (Just (lpCabalFile lp, TargetComps (S.singleton CLib))))
- return True
+ pure True
else do
modify (M.insert name Nothing)
- return False
- (_, _) -> return False
+ pure False
+ (_, _) -> pure False
unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets = M.unionWith $ \l r ->
@@ -966,11 +993,15 @@
-- | Run a command and grab the first line of stdout, dropping
-- stderr's contexts completely.
-runGrabFirstLine :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env String
+runGrabFirstLine ::
+ (HasProcessContext env, HasLogFunc env)
+ => String
+ -> [String]
+ -> RIO env String
runGrabFirstLine cmd0 args =
proc cmd0 args $ \pc -> do
(out, _err) <- readProcess_ pc
- return
+ pure
$ TL.unpack
$ TL.filter (/= '\r')
$ TL.concat
diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs
--- a/src/Stack/Ghci/Script.hs
+++ b/src/Stack/Ghci/Script.hs
@@ -14,14 +14,14 @@
, scriptToFile
) where
-import Data.ByteString.Builder (toLazyByteString)
-import Data.List
+import Data.ByteString.Builder ( toLazyByteString )
+import qualified Data.List as L
import qualified Data.Set as S
+import Distribution.ModuleName hiding ( toFilePath )
import Path
-import Stack.Prelude
-import System.IO (hSetBinaryMode)
+import Stack.Prelude hiding ( Module )
+import System.IO ( hSetBinaryMode )
-import Distribution.ModuleName hiding (toFilePath)
newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] }
@@ -71,8 +71,8 @@
| S.null modules = mempty
| otherwise =
":add "
- <> mconcat (intersperse " " $
- fmap (fromString . quoteFileName . either (mconcat . intersperse "." . components) toFilePath)
+ <> mconcat (L.intersperse " " $
+ fmap (fromString . quoteFileName . either (mconcat . L.intersperse "." . components) toFilePath)
(S.toAscList modules))
<> "\n"
@@ -83,8 +83,8 @@
| S.null modules = ":module +\n"
| otherwise =
":module + "
- <> mconcat (intersperse " "
- $ fromString . quoteFileName . mconcat . intersperse "." . components <$> S.toAscList modules)
+ <> mconcat (L.intersperse " "
+ $ fromString . quoteFileName . mconcat . L.intersperse "." . components <$> S.toAscList modules)
<> "\n"
-- | Make sure that a filename with spaces in it gets the proper quotes.
diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs
--- a/src/Stack/Hoogle.hs
+++ b/src/Stack/Hoogle.hs
@@ -4,27 +4,47 @@
-- | A wrapper around hoogle.
module Stack.Hoogle
- ( hoogleCmd
- ) where
+ ( hoogleCmd
+ ) where
-import Stack.Prelude
import qualified Data.ByteString.Lazy.Char8 as BL8
-import Data.Char (isSpace)
+import Data.Char ( isSpace )
import qualified Data.Text as T
-import Distribution.PackageDescription (packageDescription, package)
-import Distribution.Types.PackageName (mkPackageName)
-import Distribution.Version (mkVersion)
-import Lens.Micro ((?~))
-import Path (parseAbsFile)
-import Path.IO hiding (findExecutable)
+import Distribution.PackageDescription ( packageDescription, package )
+import Distribution.Types.PackageName ( mkPackageName )
+import Distribution.Version ( mkVersion )
+import Lens.Micro ( (?~) )
+import Path ( parseAbsFile )
+import Path.IO hiding ( findExecutable )
import qualified Stack.Build
-import Stack.Build.Target (NeedTargets(NeedTargets))
+import Stack.Build.Target ( NeedTargets (NeedTargets) )
+import Stack.Prelude
import Stack.Runners
import Stack.Types.Config
import Stack.Types.SourceMap
import qualified RIO.Map as Map
import RIO.Process
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Hoogle" module.
+data HoogleException
+ = HoogleDatabaseNotFound
+ | HoogleNotFound !Text
+ | HoogleOnPathNotFoundBug
+ deriving (Show, Typeable)
+
+instance Exception HoogleException where
+ displayException HoogleDatabaseNotFound =
+ "Error: [S-3025]\n"
+ ++ "No Hoogle database. Not building one due to '--no-setup'."
+ displayException (HoogleNotFound e) =
+ "Error: [S-1329]\n"
+ ++ T.unpack e
+ ++ "\n"
+ ++ "Not installing Hoogle due to '--no-setup'."
+ displayException HoogleOnPathNotFoundBug = bugReport "[S-9669]"
+ "Cannot find Hoogle executable on PATH, after installing."
+
-- | Helper type to duplicate log messages
data Muted = Muted | NotMuted
@@ -50,7 +70,7 @@
generateDbIfNeeded hooglePath = do
databaseExists <- checkDatabaseExists
if databaseExists && not rebuild
- then return ()
+ then pure ()
else if setup || rebuild
then do
logWarn
@@ -61,10 +81,7 @@
logInfo "Built docs."
generateDb hooglePath
logInfo "Generated DB."
- else do
- logError
- "No Hoogle database. Not building one due to --no-setup"
- bail
+ else throwIO HoogleDatabaseNotFound
generateDb :: Path Abs File -> RIO EnvConfig ()
generateDb hooglePath = do
do dir <- hoogleRoot
@@ -75,7 +92,7 @@
config <- view configL
runRIO config $ -- a bit weird that we have to drop down like this
catch (withDefaultEnvConfig $ Stack.Build.build Nothing)
- (\(_ :: ExitCode) -> return ())
+ (\(_ :: ExitCode) -> pure ())
hooglePackageName = mkPackageName "hoogle"
hoogleMinVersion = mkVersion [5, 0]
hoogleMinIdent =
@@ -86,9 +103,7 @@
mhooglePath' <- findExecutable "hoogle"
case mhooglePath' of
Right hooglePath -> parseAbsFile hooglePath
- Left _ -> do
- logWarn "Couldn't find hoogle in path after installing. This shouldn't happen, may be a bug."
- bail
+ Left _ -> throwIO HoogleOnPathNotFoundBug
requiringHoogle :: Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle muted f = do
hoogleTarget <- do
@@ -101,7 +116,7 @@
restrictMinHoogleVersion muted (packageLocationIdent pli)
plm@(PLMutable _) -> do
T.pack . packageIdentifierString . package . packageDescription
- <$> loadCabalFile plm
+ <$> loadCabalFile (Just stackProgName') plm
Nothing -> do
-- not muted because this should happen only once
logWarn "No hoogle version was found, trying to install the latest version"
@@ -151,8 +166,6 @@
(toFilePath hooglePath)
(hoogleArgs ++ databaseArg)
runProcess_
- bail :: RIO EnvConfig a
- bail = exitWith (ExitFailure (-1))
checkDatabaseExists = do
path <- hoogleDatabasePath
liftIO (doesFileExist path)
@@ -163,7 +176,7 @@
mhooglePath <- runRIO menv (findExecutable "hoogle") <>
requiringHoogle NotMuted (findExecutable "hoogle")
eres <- case mhooglePath of
- Left _ -> return $ Left "Hoogle isn't installed."
+ Left _ -> pure $ Left "Hoogle isn't installed."
Right hooglePath -> do
result <- withProcessContext menv
$ proc hooglePath ["--numeric-version"]
@@ -174,8 +187,8 @@
, " --numeric-version' did not respond with expected value. Got: "
, got
]
- return $ case result of
- Left err -> unexpectedResult $ T.pack (show err)
+ pure $ case result of
+ Left err -> unexpectedResult $ T.pack (displayException err)
Right bs -> case parseVersion (takeWhile (not . isSpace) (BL8.unpack bs)) of
Nothing -> unexpectedResult $ T.pack (BL8.unpack bs)
Just ver
@@ -193,9 +206,7 @@
| setup -> do
logWarn $ display err <> " Automatically installing (use --no-setup to disable) ..."
installHoogle
- | otherwise -> do
- logWarn $ display err <> " Not installing it due to --no-setup."
- bail
+ | otherwise -> throwIO $ HoogleNotFound err
envSettings =
EnvSettings
{ esIncludeLocals = True
diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs
--- a/src/Stack/IDE.hs
+++ b/src/Stack/IDE.hs
@@ -7,8 +7,8 @@
-- | Functions for IDEs.
module Stack.IDE
- ( OutputStream(..)
- , ListPackagesCmd(..)
+ ( OutputStream (..)
+ , ListPackagesCmd (..)
, listPackages
, listTargets
) where
diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs
--- a/src/Stack/Init.hs
+++ b/src/Stack/Init.hs
@@ -8,44 +8,115 @@
{-# LANGUAGE TypeOperators #-}
module Stack.Init
- ( initProject
- , InitOpts (..)
- ) where
+ ( initProject
+ , InitOpts (..)
+ ) where
-import Stack.Prelude
-import qualified Data.Aeson.KeyMap as KeyMap
-import qualified Data.ByteString.Builder as B
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.Foldable as F
-import qualified Data.IntMap as IntMap
-import Data.List.Extra (groupSortOn)
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import qualified Data.Text.Normalize as T (normalize , NormalizationMode(NFC))
-import qualified Data.Yaml as Yaml
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.ByteString.Builder as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.Foldable as F
+import qualified Data.IntMap as IntMap
+import Data.List.Extra ( groupSortOn )
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
-import qualified Distribution.Text as C
-import qualified Distribution.Version as C
+import qualified Distribution.Text as C
+import qualified Distribution.Version as C
import Path
-import Path.Extra (toFilePathNoTrailingSep)
-import Path.Find (findFiles)
-import Path.IO hiding (findFiles)
-import qualified Paths_stack as Meta
-import qualified RIO.FilePath as FP
-import RIO.List ((\\), intercalate, intersperse,
- isSuffixOf, isPrefixOf)
-import RIO.List.Partial (minimumBy)
+import Path.Extra ( toFilePathNoTrailingSep )
+import Path.Find ( findFiles )
+import Path.IO hiding ( findFiles )
+import qualified RIO.FilePath as FP
+import RIO.List ( (\\), intercalate, isSuffixOf, isPrefixOf )
+import RIO.List.Partial ( minimumBy )
import Stack.BuildPlan
-import Stack.Config (getSnapshots,
- makeConcreteResolver)
+import Stack.Config ( getSnapshots, makeConcreteResolver )
import Stack.Constants
+import Stack.Prelude
import Stack.SourceMap
import Stack.Types.Config
import Stack.Types.Resolver
-import Stack.Types.Version
+import Stack.Types.Version ( stackMajorVersion )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Init" module.
+data InitException
+ = NoPackagesToIgnoreBug
+ deriving (Show, Typeable)
+
+instance Exception InitException where
+ displayException NoPackagesToIgnoreBug = bugReport "[S-2747]"
+ "No packages to ignore."
+
+data InitPrettyException
+ = SnapshotDownloadFailure SomeException
+ | ConfigFileAlreadyExists FilePath
+ | PackageNameInvalid [(Path Abs File, PackageName)]
+ deriving (Show, Typeable)
+
+instance Pretty InitPrettyException where
+ pretty (ConfigFileAlreadyExists reldest) =
+ "[S-8009]"
+ <> line
+ <> flow "Stack declined to create a project-level YAML configuration \
+ \file."
+ <> blankLine
+ <> fillSep
+ [ flow "The file"
+ , style File (fromString reldest)
+ , "already exists. To overwrite it, pass the flag"
+ , style Shell "--force" <> "."
+ ]
+ pretty (PackageNameInvalid rels) =
+ "[S-5267]"
+ <> line
+ <> flow "Stack did not create project-level YAML configuration, as \
+ \(like Hackage) it requires a Cabal file name to match the \
+ \package it defines."
+ <> blankLine
+ <> flow "Please rename the following Cabal files:"
+ <> line
+ <> bulletedList
+ ( map
+ ( \(fp, name) -> fillSep
+ [ style File (pretty fp)
+ , "as"
+ , style
+ File
+ (fromString (packageNameString name) <> ".cabal")
+ ]
+ )
+ rels
+ )
+ pretty (SnapshotDownloadFailure e) =
+ "[S-8332]"
+ <> line
+ <> flow "Stack failed to create project-level YAML configuration, as \
+ \it was unable to download the index of available snapshots."
+ <> blankLine
+ <> fillSep
+ [ flow "This sometimes happens because Certificate Authorities \
+ \are missing on your system. You can try the Stack command \
+ \again or manually create the configuration file. For help \
+ \about the content of Stack's YAML configuration files, \
+ \see (for the most recent release of Stack)"
+ , style
+ Url
+ "http://docs.haskellstack.org/en/stable/yaml_configuration/"
+ <> "."
+ ]
+ <> blankLine
+ <> flow "While downloading the snapshot index, Stack encountered the \
+ \following error:"
+ <> blankLine
+ <> string (displayException e)
+
+instance Exception InitPrettyException
+
-- | Generate stack.yaml
initProject
:: (HasConfig env, HasGHCVariant env)
@@ -60,16 +131,21 @@
exists <- doesFileExist dest
when (not (forceOverwrite initOpts) && exists) $
- throwString
- ("Error: Stack configuration file " <> reldest <>
- " exists, use '--force' to overwrite it.")
+ throwIO $ PrettyException $ ConfigFileAlreadyExists reldest
dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)
let find = findCabalDirs (includeSubDirs initOpts)
dirs' = if null dirs then [currDir] else dirs
- logInfo "Looking for .cabal or package.yaml files to use to init the project."
+ prettyInfo $
+ fillSep
+ [ flow "Looking for Cabal or"
+ , style File "package.yaml"
+ , flow "files to use to initialise Stack's project-level YAML \
+ \configuration file."
+ ]
+ <> line
cabaldirs <- Set.toList . Set.unions <$> mapM find dirs'
- (bundle, dupPkgs) <- cabalPackagesCheck cabaldirs Nothing
+ (bundle, dupPkgs) <- cabalPackagesCheck cabaldirs
let makeRelDir dir =
case stripProperPrefix currDir dir of
Nothing
@@ -134,38 +210,63 @@
makeRel = fmap toFilePath . makeRelativeToCurrentDir
- indent t = T.unlines $ fmap (" " <>) (T.lines t)
-
- logInfo $ "Initialising configuration using resolver: " <> display snapshotLoc
- logInfo $ "Total number of user packages considered: "
- <> display (Map.size bundle + length dupPkgs)
+ prettyInfo $
+ fillSep
+ [ flow "Initialising Stack's project-level YAML configuration file \
+ \using snapshot"
+ , pretty (PrettyRawSnapshotLocation snapshotLoc) <> "."
+ ]
+ prettyInfo $
+ let n = Map.size bundle + length dupPkgs
+ in fillSep
+ [ "Considered"
+ , fromString $ show n
+ , "user"
+ , if n == 1 then "package." else "packages."
+ ]
when (dupPkgs /= []) $ do
- logWarn $ "Warning! Ignoring "
- <> displayShow (length dupPkgs)
- <> " duplicate packages:"
rels <- mapM makeRel dupPkgs
- logWarn $ display $ indent $ showItems rels
+ prettyWarn $
+ fillSep
+ [ flow "Ignoring these"
+ , fromString $ show (length dupPkgs)
+ , flow "duplicate packages:"
+ ]
+ <> line
+ <> bulletedList (map (style File . fromString) rels)
when (Map.size ignored > 0) $ do
- logWarn $ "Warning! Ignoring "
- <> displayShow (Map.size ignored)
- <> " packages due to dependency conflicts:"
rels <- mapM makeRel (Map.elems (fmap fst ignored))
- logWarn $ display $ indent $ showItems rels
+ prettyWarn $
+ fillSep
+ [ flow "Ignoring these"
+ , fromString $ show (Map.size ignored)
+ , flow "packages due to dependency conflicts:"
+ ]
+ <> line
+ <> bulletedList (map (style File . fromString) rels)
when (Map.size extraDeps > 0) $ do
- logWarn $ "Warning! " <> displayShow (Map.size extraDeps)
- <> " external dependencies were added."
- logInfo $
- (if exists then "Overwriting existing configuration file: "
- else "Writing configuration to file: ")
- <> fromString reldest
+ prettyWarn $
+ fillSep
+ [ fromString $ show (Map.size extraDeps)
+ , flow "external dependencies were added."
+ ]
+ prettyInfo $
+ fillSep
+ [ flow $ if exists
+ then "Overwriting existing configuration file"
+ else "Writing configuration to"
+ , style File (fromString reldest) <> "."
+ ]
writeBinaryFileAtomic dest
$ renderStackYaml p
(Map.elems $ fmap (makeRelDir . parent . fst) ignored)
(map (makeRelDir . parent) dupPkgs)
- logInfo "All done."
+ prettyInfo $
+ flow "Stack's project-level YAML configuration file has been \
+ \initialised."
-- | Render a stack.yaml file with comments, see:
-- https://github.com/commercialhaskell/stack/issues/226
@@ -293,22 +394,20 @@
, ""
]
- footerHelp =
- let major = toMajorVersion $ C.mkVersion' Meta.version
- in commentHelp
+ footerHelp = commentHelp
[ "Control whether we use the GHC we find on the path"
, "system-ghc: true"
, ""
- , "Require a specific version of stack, using version ranges"
+ , "Require a specific version of Stack, using version ranges"
, "require-stack-version: -any # Default"
, "require-stack-version: \""
- ++ C.display (C.orLaterVersion major) ++ "\""
+ ++ C.display (C.orLaterVersion stackMajorVersion) ++ "\""
, ""
- , "Override the architecture used by stack, especially useful on Windows"
+ , "Override the architecture used by Stack, especially useful on Windows"
, "arch: i386"
, "arch: x86_64"
, ""
- , "Extra directories used by stack for building"
+ , "Extra directories used by Stack for building"
, "extra-include-dirs: [/path/to/dir]"
, "extra-lib-dirs: [/path/to/dir]"
, ""
@@ -317,23 +416,9 @@
]
getSnapshots' :: HasConfig env => RIO env Snapshots
-getSnapshots' = do
- getSnapshots `catchAny` \e -> do
- logError $
- "Unable to download snapshot list, and therefore could " <>
- "not generate a stack.yaml file automatically"
- logError $
- "This sometimes happens due to missing Certificate Authorities " <>
- "on your system. For more information, see:"
- logError ""
- logError " https://github.com/commercialhaskell/stack/issues/234"
- logError ""
- logError "You can try again, or create your stack.yaml file by hand. See:"
- logError ""
- logError " http://docs.haskellstack.org/en/stable/yaml_configuration/"
- logError ""
- logError $ "Exception was: " <> displayShow e
- throwString ""
+getSnapshots' = catchAny
+ getSnapshots
+ (\e -> throwIO $ PrettyException $ SnapshotDownloadFailure e)
-- | Get the default resolver value
getDefaultResolver
@@ -357,7 +442,7 @@
Just ar -> do
sl <- makeConcreteResolver ar
c <- loadProjectSnapshotCandidate sl NoPrintWarnings False
- return (c, sl)
+ pure (c, sl)
getWorkingResolverPlan initOpts pkgDirs candidate loc
where
-- TODO support selecting best across regular and custom snapshots
@@ -366,8 +451,9 @@
(c, l, r) <- selectBestSnapshot (Map.elems pkgDirs) snaps
case r of
BuildPlanCheckFail {} | not (omitPackages initOpts)
- -> throwM (NoMatchingSnapshot snaps)
- _ -> return (c, l)
+ -> throwM $ PrettyException $
+ NoMatchingSnapshot snaps
+ _ -> pure (c, l)
getWorkingResolverPlan
:: (HasConfig env, HasGHCVariant env)
@@ -386,37 +472,53 @@
-- , Extra dependencies
-- , Src packages actually considered)
getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do
- logInfo $ "Selected resolver: " <> display snapLoc
+ prettyInfo $
+ fillSep
+ [ flow "Selected the snapshot"
+ , pretty (PrettyRawSnapshotLocation snapLoc) <> "."
+ ]
go pkgDirs0
where
go pkgDirs = do
eres <- checkBundleResolver initOpts snapLoc snapCandidate (Map.elems pkgDirs)
-- if some packages failed try again using the rest
case eres of
- Right (f, edeps)-> return (snapLoc, f, edeps, pkgDirs)
+ Right (f, edeps)-> pure (snapLoc, f, edeps, pkgDirs)
Left ignored
| Map.null available -> do
- logWarn $ "*** Could not find a working plan for any of " <>
- "the user packages.\nProceeding to create a " <>
- "config anyway."
- return (snapLoc, Map.empty, Map.empty, Map.empty)
+ prettyWarn $
+ flow "Could not find a working plan for any of the \
+ \user packages. Proceeding to create a YAML \
+ \configuration file anyway."
+ pure (snapLoc, Map.empty, Map.empty, Map.empty)
| otherwise -> do
when (Map.size available == Map.size pkgDirs) $
- error "Bug: No packages to ignore"
-
- if length ignored > 1 then do
- logWarn "*** Ignoring packages:"
- logWarn $ display $ indent $ showItems $ map packageNameString ignored
- else
- logWarn $ "*** Ignoring package: "
- <> fromString
- (case ignored of
- [] -> error "getWorkingResolverPlan.head"
- x:_ -> packageNameString x)
+ throwM NoPackagesToIgnoreBug
+ if length ignored > 1
+ then
+ prettyWarn
+ ( flow "Ignoring the following packages:"
+ <> line
+ <> bulletedList
+ ( map
+ (fromString . packageNameString)
+ ignored
+ )
+ )
+ else
+ prettyWarn
+ ( fillSep
+ [ flow "Ignoring package:"
+ , fromString
+ ( case ignored of
+ [] -> throwM NoPackagesToIgnoreBug
+ x:_ -> packageNameString x
+ )
+ ]
+ )
go available
where
- indent t = T.unlines $ fmap (" " <>) (T.lines t)
isAvailable k _ = k `notElem` ignored
available = Map.filterWithKey isAvailable pkgDirs
@@ -433,27 +535,29 @@
checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do
result <- checkSnapBuildPlan pkgDirs Nothing snapCandidate
case result of
- BuildPlanCheckOk f -> return $ Right (f, Map.empty)
+ BuildPlanCheckOk f -> pure $ Right (f, Map.empty)
BuildPlanCheckPartial _f e -> do -- FIXME:qrilka unused f
if omitPackages initOpts
then do
warnPartial result
logWarn "*** Omitting packages with unsatisfied dependencies"
- return $ Left $ failedUserPkgs e
- else throwM $ ResolverPartial snapshotLoc (show result)
+ pure $ Left $ failedUserPkgs e
+ else throwM $ PrettyException $
+ ResolverPartial snapshotLoc (show result)
BuildPlanCheckFail _ e _
| omitPackages initOpts -> do
logWarn $ "*** Resolver compiler mismatch: "
<> display snapshotLoc
- logWarn $ display $ indent $ T.pack $ show result
- return $ Left $ failedUserPkgs e
- | otherwise -> throwM $ ResolverMismatch snapshotLoc (show result)
+ logWarn $ display $ ind $ T.pack $ show result
+ pure $ Left $ failedUserPkgs e
+ | otherwise -> throwM $ PrettyException $
+ ResolverMismatch snapshotLoc (show result)
where
- indent t = T.unlines $ fmap (" " <>) (T.lines t)
+ ind t = T.unlines $ fmap (" " <>) (T.lines t)
warnPartial res = do
logWarn $ "*** Resolver " <> display snapshotLoc
<> " will need external packages: "
- logWarn $ display $ indent $ T.pack $ show res
+ logWarn $ display $ ind $ T.pack $ show res
failedUserPkgs e = Map.keys $ Map.unions (Map.elems (fmap deNeededBy e))
@@ -470,10 +574,10 @@
supportedLtss = filter (>= minSupportedLts) ltss
nightly = Nightly (snapshotsNightly snapshots)
--- |Yields the minimum LTS supported by stack.
+-- |Yields the minimum LTS supported by Stack.
minSupportedLts :: SnapName
minSupportedLts = LTS 3 0 -- See https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md
- -- under stack version 2.1.1.
+ -- under Stack version 2.1.1.
data InitOpts = InitOpts
{ searchDirs :: ![T.Text]
@@ -511,44 +615,49 @@
cabalPackagesCheck
:: (HasConfig env, HasGHCVariant env)
=> [Path Abs Dir]
- -> Maybe String
-> RIO env
( Map PackageName (Path Abs File, C.GenericPackageDescription)
, [Path Abs File])
-cabalPackagesCheck cabaldirs dupErrMsg = do
- when (null cabaldirs) $ do
- logWarn "We didn't find any local package directories"
- logWarn "You may want to create a package with \"stack new\" instead"
- logWarn "Create an empty project for now"
- logWarn "If this isn't what you want, please delete the generated \"stack.yaml\""
-
+cabalPackagesCheck cabaldirs = do
+ when (null cabaldirs) $
+ prettyWarn $
+ fillSep
+ [ flow "Stack did not find any local package directories. You may \
+ \want to create a package with"
+ , style Shell (flow "stack new")
+ , flow "instead."
+ ]
+ <> blankLine
+ <> fillSep
+ [ flow "Stack will create an empty project. If this is not what \
+ \you want, please delete the generated"
+ , style File "stack.yaml"
+ , "file."
+ ]
relpaths <- mapM prettyPath cabaldirs
- logInfo "Using cabal packages:"
- logInfo $ formatGroup relpaths
-
- packages <- for cabaldirs $ \dir -> do
- (gpdio, _name, cabalfp) <- loadCabalFilePath dir
- gpd <- liftIO $ gpdio YesPrintWarnings
- pure (cabalfp, gpd)
-
- -- package name cannot be empty or missing otherwise
- -- it will result in cabal solver failure.
- -- stack requires packages name to match the cabal file name
- -- Just the latter check is enough to cover both the cases
-
- let normalizeString = T.unpack . T.normalize T.NFC . T.pack
- getNameMismatchPkg (fp, gpd)
- | (normalizeString . packageNameString . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp
- = Just fp
- | otherwise = Nothing
- nameMismatchPkgs = mapMaybe getNameMismatchPkg packages
+ unless (null relpaths) $
+ prettyInfo $
+ flow "Using the Cabal packages:"
+ <> line
+ <> bulletedList (map (style File . fromString) relpaths)
+ <> line
- when (nameMismatchPkgs /= []) $ do
- rels <- mapM prettyPath nameMismatchPkgs
- error $ "Package name as defined in the .cabal file must match the " <>
- ".cabal file name.\n" <>
- "Please fix the following packages and try again:\n"
- <> T.unpack (utf8BuilderToText (formatGroup rels))
+ -- A package name cannot be empty or missing otherwise it will result in
+ -- Cabal solver failure. Stack requires packages name to match the Cabal
+ -- file name. Just the latter check is enough to cover both the cases.
+ ePackages <- for cabaldirs $ \dir -> do
+ -- Pantry's 'loadCabalFilePath' throws 'MismatchedCabalName' (error
+ -- [S-910]) if the Cabal file name does not match the package it
+ -- defines.
+ (gpdio, _name, cabalfp) <- loadCabalFilePath (Just stackProgName') dir
+ eres <- liftIO $ try (gpdio YesPrintWarnings)
+ case eres :: Either PantryException C.GenericPackageDescription of
+ Right gpd -> pure $ Right (cabalfp, gpd)
+ Left (MismatchedCabalName fp name) -> pure $ Left (fp, name)
+ Left e -> throwIO e
+ let (nameMismatchPkgs, packages) = partitionEithers ePackages
+ when (nameMismatchPkgs /= []) $
+ throwIO $ PrettyException $ PackageNameInvalid nameMismatchPkgs
let dupGroups = filter ((> 1) . length)
. groupSortOn (gpdPackageName . snd)
@@ -563,28 +672,29 @@
when (dupIgnored /= []) $ do
dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages)
- logWarn $
- "Following packages have duplicate package names:\n" <>
- mconcat (intersperse "\n" (map formatGroup dups))
- case dupErrMsg of
- Nothing -> logWarn $
- "Packages with duplicate names will be ignored.\n"
- <> "Packages in upper level directories will be preferred.\n"
- Just msg -> error msg
+ prettyWarn $
+ flow "The following packages have duplicate package names:"
+ <> line
+ <> foldMap
+ ( \dup -> bulletedList (map fromString dup)
+ <> line
+ )
+ dups
+ <> line
+ <> flow "Packages with duplicate names will be ignored. Packages \
+ \in upper level directories will be preferred."
+ <> line
- return (Map.fromList
+ pure (Map.fromList
$ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique
, map fst dupIgnored)
-formatGroup :: [String] -> Utf8Builder
-formatGroup = foldMap (\path -> "- " <> fromString path <> "\n")
-
prettyPath ::
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))
=> Path r t
-> m FilePath
prettyPath path = do
eres <- liftIO $ try $ makeRelativeToCurrentDir path
- return $ case eres of
+ pure $ case eres of
Left (_ :: PathException) -> toFilePath path
Right res -> toFilePath res
diff --git a/src/Stack/List.hs b/src/Stack/List.hs
--- a/src/Stack/List.hs
+++ b/src/Stack/List.hs
@@ -6,17 +6,21 @@
( listPackages
) where
-import Stack.Prelude
+import RIO.List ( intercalate )
import qualified RIO.Map as Map
-import RIO.List (intercalate)
-import RIO.Process (HasProcessContext)
+import RIO.Process ( HasProcessContext )
+import Stack.Prelude
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.List" module.
newtype ListException
= CouldNotParsePackageSelectors [String]
- deriving Typeable
-instance Exception ListException
-instance Show ListException where
- show (CouldNotParsePackageSelectors strs) = unlines $ map ("- " ++) strs
+ deriving (Show, Typeable)
+
+instance Exception ListException where
+ displayException (CouldNotParsePackageSelectors strs) = unlines $
+ "Error: [S-4926]"
+ : map ("- " ++) strs
-- | Intended to work for the command line command.
listPackages
diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs
--- a/src/Stack/Lock.hs
+++ b/src/Stack/Lock.hs
@@ -5,24 +5,40 @@
{-# LANGUAGE RecordWildCards #-}
module Stack.Lock
- ( lockCachedWanted
- , LockedLocation(..)
- , Locked(..)
- ) where
+ ( lockCachedWanted
+ , LockedLocation (..)
+ , Locked (..)
+ ) where
-import Pantry.Internal.AesonExtended
-import Data.ByteString.Builder (byteString)
+import Data.ByteString.Builder ( byteString )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
+import qualified Data.Text as T
import qualified Data.Yaml as Yaml
-import Path (parent)
-import Path.Extended (addExtension)
-import Path.IO (doesFileExist)
-import Stack.Prelude
-import Stack.SourceMap
-import Stack.Types.Config
-import Stack.Types.SourceMap
+import Pantry.Internal.AesonExtended
+import Path ( parent )
+import Path.Extended ( addExtension )
+import Path.IO ( doesFileExist )
+import Stack.Prelude
+import Stack.SourceMap
+import Stack.Types.Config
+import Stack.Types.SourceMap
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Lock" module.
+data LockException
+ = WritingLockFileError (Path Abs File) Locked
+ deriving (Show, Typeable)
+
+instance Exception LockException where
+ displayException (WritingLockFileError lockFile newLocked) = unlines
+ [ "Error: [S-1353]"
+ , "You indicated that Stack should error out on writing a lock file"
+ , "Stack just tried to write the following lock file contents to "
+ ++ toFilePath lockFile
+ , T.unpack $ decodeUtf8With lenientDecode $ Yaml.encode newLocked
+ ]
+
data LockedLocation a b = LockedLocation
{ llOriginal :: a
, llCompleted :: b
@@ -85,7 +101,7 @@
Left err -> throwIO $ Yaml.AesonException err
Right (WithJSONWarnings res warnings) -> do
logJSONWarnings (toFilePath path) warnings
- return res
+ pure res
lockCachedWanted ::
(HasPantryConfig env, HasRunner env)
@@ -139,13 +155,7 @@
writeBinaryFileAtomic lockFile $
header <>
byteString (Yaml.encode newLocked)
- LFBErrorOnWrite -> do
- logError "You indicated that Stack should error out on writing a lock file"
- logError $
- "I just tried to write the following lock file contents to " <>
- fromString (toFilePath lockFile)
- logError $ display $ decodeUtf8With lenientDecode $ Yaml.encode newLocked
- exitFailure
+ LFBErrorOnWrite -> throwIO $ WritingLockFileError lockFile newLocked
LFBIgnore -> pure ()
LFBReadOnly -> pure ()
pure wanted
diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs
--- a/src/Stack/Ls.hs
+++ b/src/Stack/Ls.hs
@@ -8,38 +8,50 @@
, lsParser
) where
-import Control.Exception (throw)
-import Data.Aeson
-import Data.Array.IArray ((//), elems)
-import Distribution.Package (mkPackageName)
-import Stack.Prelude hiding (Snapshot (..), SnapName (..))
+import Data.Aeson
+import Data.Array.IArray ( (//), elems )
+import Distribution.Package ( mkPackageName )
import qualified Data.Aeson.Types as A
import qualified Data.List as L
-import Data.Text hiding (filter, intercalate, pack, reverse)
+import Data.Text hiding ( filter, intercalate, pack, reverse )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Vector as V
-import Network.HTTP.StackClient (httpJSON, addRequestHeader, getResponseBody, parseRequest, hAccept)
+import Network.HTTP.StackClient
+ ( httpJSON, addRequestHeader, getResponseBody, parseRequest
+ , hAccept
+ )
import qualified Options.Applicative as OA
-import Options.Applicative (idm)
-import Options.Applicative.Builder.Extra (boolFlags)
-import Path
-import RIO.List (sort)
-import RIO.PrettyPrint (useColorL)
-import RIO.PrettyPrint.DefaultStyles (defaultStyles)
-import RIO.PrettyPrint.Types (StyleSpec)
-import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), stylesUpdateL)
-import Stack.Constants (osIsWindows)
-import Stack.Dot
-import Stack.Runners
-import Stack.Options.DotParser (listDepsOptsParser)
-import Stack.Setup.Installed (Tool (..), filterTools, listInstalled, toolString)
-import Stack.Types.Config
-import System.Console.ANSI.Codes (SGR (Reset), setSGRCode, sgrToCode)
-import System.Process.Pager (pageText)
-import System.Directory (listDirectory)
-import System.IO (putStrLn)
+import Options.Applicative ( idm )
+import Options.Applicative.Builder.Extra ( boolFlags )
+import Path
+import RIO.List ( sort )
+import Stack.Constants ( osIsWindows, globalFooter )
+import Stack.Dot
+import Stack.Prelude hiding ( Snapshot (..), SnapName (..) )
+import Stack.Runners
+import Stack.Options.DotParser ( listDepsOptsParser )
+import Stack.Setup.Installed
+ ( Tool (..), filterTools, listInstalled, toolString )
+import Stack.Types.Config
+import System.Console.ANSI.Codes
+ ( SGR (Reset), setSGRCode, sgrToCode )
+import System.Process.Pager ( pageText )
+import System.Directory ( listDirectory )
+import System.IO ( putStrLn )
+-- | Type representing exceptions thrown by functions exported by the "Stack.Ls"
+-- module.
+newtype LsException
+ = ParseFailure [Value]
+ deriving (Show, Typeable)
+
+instance Exception LsException where
+ displayException (ParseFailure val) =
+ "Error: [S-3421]\n"
+ ++ "Failure to parse values as a snapshot: "
+ ++ show val
+
data LsView
= Local
| Remote
@@ -138,29 +150,29 @@
<> OA.footer localSnapshotMsg
lsDepsCmd :: OA.Mod OA.CommandFields LsCmds
-lsDepsCmd =
- OA.command
- "dependencies"
- (OA.info lsDepOptsParser (OA.progDesc "View the dependencies"))
+lsDepsCmd = OA.command "dependencies" $
+ OA.info lsDepOptsParser $
+ OA.progDesc "View the dependencies"
+ <> OA.footer globalFooter
lsStylesCmd :: OA.Mod OA.CommandFields LsCmds
lsStylesCmd =
OA.command
"stack-colors"
(OA.info lsStylesOptsParser
- (OA.progDesc "View stack's output styles"))
+ (OA.progDesc "View Stack's output styles"))
<>
OA.command
"stack-colours"
(OA.info lsStylesOptsParser
- (OA.progDesc "View stack's output styles (alias for \
+ (OA.progDesc "View Stack's output styles (alias for \
\'stack-colors')"))
lsToolsCmd :: OA.Mod OA.CommandFields LsCmds
lsToolsCmd =
OA.command
"tools"
- (OA.info lsToolsOptsParser (OA.progDesc "View stack's installed tools"))
+ (OA.info lsToolsOptsParser (OA.progDesc "View Stack's installed tools"))
data Snapshot = Snapshot
{ snapId :: Text
@@ -189,16 +201,10 @@
, snapTitle = stitle
, snapTime = stime
}
-toSnapshot val = throw $ ParseFailure val
-
-newtype LsException =
- ParseFailure [Value]
- deriving (Show, Typeable)
-
-instance Exception LsException
+toSnapshot val = impureThrow $ ParseFailure val
parseSnapshot :: Value -> A.Parser Snapshot
-parseSnapshot = A.withArray "array of snapshot" (return . toSnapshot . V.toList)
+parseSnapshot = A.withArray "array of snapshot" (pure . toSnapshot . V.toList)
displayTime :: Snapshot -> [Text]
displayTime Snapshot {..} = [snapTime]
@@ -224,7 +230,7 @@
displaySnapshotData :: Bool -> SnapshotData -> IO ()
displaySnapshotData term sdata =
case L.reverse $ snaps sdata of
- [] -> return ()
+ [] -> pure ()
xs ->
let snaps = T.concat $ L.map displaySingleSnap xs
in renderData term snaps
@@ -270,9 +276,9 @@
displayLocalSnapshot isStdoutTerminal $
L.filter (L.isPrefixOf "night") snapData
_ -> liftIO $ displayLocalSnapshot isStdoutTerminal snapData
- LsDependencies _ -> return ()
- LsStyles _ -> return ()
- LsTools _ -> return ()
+ LsDependencies _ -> pure ()
+ LsStyles _ -> pure ()
+ LsTools _ -> pure ()
handleRemote
:: HasRunner env
@@ -295,9 +301,9 @@
displaySnapshotData isStdoutTerminal $
filterSnapshotData snapData Nightly
_ -> liftIO $ displaySnapshotData isStdoutTerminal snapData
- LsDependencies _ -> return ()
- LsStyles _ -> return ()
- LsTools _ -> return ()
+ LsDependencies _ -> pure ()
+ LsStyles _ -> pure ()
+ LsTools _ -> pure ()
where
urlInfo = "https://www.stackage.org/snapshots"
@@ -333,7 +339,7 @@
localSnapshotMsg =
"A local snapshot is identified by a hash code. " <> pagerMsg
--- | List stack's output styles
+-- | List Stack's output styles
listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd opts = do
lc <- ask
@@ -359,7 +365,7 @@
ansi = fromString $ setSGRCode sgrs
reset = fromString $ setSGRCode [Reset]
--- | List stack's installed tools, sorted (see instance of 'Ord' for 'Tool').
+-- | List Stack's installed tools, sorted (see instance of 'Ord' for 'Tool').
listToolsCmd :: ListToolsOpts -> RIO Config ()
listToolsCmd opts = do
localPrograms <- view $ configL.to configLocalPrograms
diff --git a/src/Stack/New.hs b/src/Stack/New.hs
--- a/src/Stack/New.hs
+++ b/src/Stack/New.hs
@@ -1,52 +1,234 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
-- | Create new a new project directory populated with a basic working
-- project.
module Stack.New
( new
- , NewOpts(..)
+ , NewOpts (..)
, TemplateName
, templatesHelp
) where
-import Stack.Prelude
import Control.Monad.Trans.Writer.Strict
import Data.Aeson as A
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Base64 as B64
-import Data.ByteString.Builder (lazyByteString)
+import Data.ByteString.Builder ( lazyByteString )
import qualified Data.ByteString.Lazy as LB
import Data.Conduit
-import Data.List
+import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Calendar
import Data.Time.Clock
-import Network.HTTP.StackClient (VerifiedDownloadException (..), Request, HttpException,
- getResponseBody, httpLbs, mkDownloadRequest, parseRequest, parseUrlThrow,
- setForceDownload, setGitHubHeaders, setRequestCheckStatus, verifiedDownloadWithProgress)
+import Network.HTTP.StackClient
+ ( HttpException (..), HttpExceptionContent (..)
+ , Response (..), VerifiedDownloadException (..)
+ , getResponseBody, httpLbs, mkDownloadRequest, notFound404
+ , parseRequest, parseUrlThrow, setForceDownload
+ , setGitHubHeaders, setRequestCheckStatus
+ , verifiedDownloadWithProgress
+ )
import Path
import Path.IO
+import RIO.Process
import Stack.Constants
import Stack.Constants.Config
+import Stack.Prelude
import Stack.Types.Config
import Stack.Types.TemplateName
-import RIO.Process
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import Text.ProjectTemplate
--------------------------------------------------------------------------------
+-- Exceptions
+
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
+-- "Stack.New" module.
+data NewPrettyException
+ = ProjectDirAlreadyExists !String !(Path Abs Dir)
+ | DownloadTemplateFailed !Text !String !VerifiedDownloadException
+ | forall b. LoadTemplateFailed !TemplateName !(Path b File)
+ | forall b. ExtractTemplateFailed !TemplateName !(Path b File) !String
+ | TemplateInvalid !TemplateName !StyleDoc
+ | MagicPackageNameInvalid !String
+ | AttemptedOverwrites !Text ![Path Abs File]
+ | DownloadTemplatesHelpFailed !HttpException
+ | TemplatesHelpEncodingInvalid !String !UnicodeException
+ deriving Typeable
+
+deriving instance Show NewPrettyException
+
+instance Pretty NewPrettyException where
+ pretty (ProjectDirAlreadyExists name path) =
+ "[S-2135]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to create a new directory for project"
+ , style Current (fromString name) <> ","
+ , flow "as the directory"
+ , style Dir (pretty path)
+ , flow "already exists."
+ ]
+ pretty (DownloadTemplateFailed name url err) =
+ "[S-1688]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to download the template"
+ , style Current (fromString . T.unpack $ name)
+ , "from"
+ , style Url (fromString url) <> "."
+ ]
+ <> blankLine
+ <> ( if isNotFound
+ then flow "Please check that the template exists at that \
+ \location."
+ <> blankLine
+ else mempty
+ )
+ <> fillSep
+ [ flow "While downloading, Stack encountered"
+ , msg
+ ]
+ where
+ (msg, isNotFound) = case err of
+ DownloadHttpError (HttpExceptionRequest req content) ->
+ let msg' = flow "an HTTP error. Stack made the request:"
+ <> blankLine
+ <> fromString (show req)
+ <> blankLine
+ <> flow "and the content of the error was:"
+ <> blankLine
+ <> fromString (show content)
+ isNotFound404 = case content of
+ StatusCodeException res _ ->
+ responseStatus res == notFound404
+ _ -> False
+ in (msg', isNotFound404)
+ DownloadHttpError (InvalidUrlException url' reason) ->
+ let msg' = fillSep
+ [ flow "an HTTP error. The URL"
+ , style Url (fromString url')
+ , flow "was considered invalid because"
+ , fromString reason <> "."
+ ]
+ in (msg', False)
+ _ -> let msg' = flow "the following error:"
+ <> blankLine
+ <> fromString (displayException err)
+ in (msg', False)
+ pretty (LoadTemplateFailed name path) =
+ "[S-3650]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to load the downloaded template"
+ , style Current (fromString $ T.unpack $ templateName name)
+ , "from"
+ , style File (pretty path) <> "."
+ ]
+ pretty (ExtractTemplateFailed name path err) =
+ "[S-9582]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to extract the loaded template"
+ , style Current (fromString $ T.unpack $ templateName name)
+ , "at"
+ , style File (pretty path) <> "."
+ ]
+ <> blankLine
+ <> flow "While extracting, Stack encountered the following error:"
+ <> blankLine
+ <> string err
+ pretty (TemplateInvalid name why) =
+ "[S-9490]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to use the template"
+ , style Current (fromString $ T.unpack $ templateName name) <> ","
+ , "as"
+ , why
+ ]
+ pretty (MagicPackageNameInvalid name) =
+ "[S-5682]"
+ <> line
+ <> fillSep
+ [ flow "Stack declined to create a new directory for project"
+ , style Current (fromString name) <> ","
+ , flow "as package"
+ , fromString name
+ , flow "is 'wired-in' to a version of GHC. That can cause build \
+ \errors."
+ ]
+ <> blankLine
+ <> fillSep
+ ( flow "The names blocked by Stack are:"
+ : mkNarrativeList Nothing False
+ ( map toStyleDoc (L.sort $ S.toList wiredInPackages)
+ )
+ )
+ where
+ toStyleDoc :: PackageName -> StyleDoc
+ toStyleDoc = fromString . packageNameString
+ pretty (AttemptedOverwrites name fps) =
+ "[S-3113]"
+ <> line
+ <> fillSep
+ [ flow "Stack declined to apply the template"
+ , style Current (fromString . T.unpack $ name) <> ","
+ , flow "as it would create files that already exist."
+ ]
+ <> blankLine
+ <> flow "The template would create the following existing files:"
+ <> line
+ <> bulletedList (map (style File . pretty) fps)
+ <> blankLine
+ <> fillSep
+ [ "Use the"
+ , style Shell "--force"
+ , "flag to ignore this and overwrite those files."
+ ]
+ pretty (DownloadTemplatesHelpFailed err) =
+ "[S-8143]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to download the help for"
+ , style Shell "stack templates" <> "."
+ ]
+ <> blankLine
+ <> flow "While downloading, Stack encountered the following error:"
+ <> blankLine
+ <> string (displayException err)
+ pretty (TemplatesHelpEncodingInvalid url err) =
+ "[S-6670]"
+ <> line
+ <> fillSep
+ [ flow "Stack failed to decode the help for"
+ , style Shell "stack templates"
+ , flow "downloaded from"
+ , style Url (fromString url) <> "."
+ ]
+ <> blankLine
+ <> flow "While decoding, Stack encountered the following error:"
+ <> blankLine
+ <> string (displayException err)
+
+
+instance Exception NewPrettyException
+
+--------------------------------------------------------------------------------
-- Main project creation
-- | Options for creating a new project.
@@ -64,19 +246,20 @@
-- | Create a new project with the given options.
new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir)
new opts forceOverwrite = do
- when (newOptsProjectName opts `elem` wiredInPackages) $
- throwM $ Can'tUseWiredInName (newOptsProjectName opts)
+ when (project `elem` wiredInPackages) $
+ throwM $ PrettyException $ MagicPackageNameInvalid projectName
pwd <- getCurrentDir
- absDir <- if bare then return pwd
+ absDir <- if bare then pure pwd
else do relDir <- parseRelDir (packageNameString project)
- liftM (pwd ) (return relDir)
+ liftM (pwd ) (pure relDir)
exists <- doesDirExist absDir
configTemplate <- view $ configL.to configDefaultTemplate
let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate
, configTemplate
]
if exists && not bare
- then throwM (AlreadyExists absDir)
+ then throwM $ PrettyException $
+ ProjectDirAlreadyExists projectName absDir
else do
templateText <- loadTemplate template (logUsing absDir template)
files <-
@@ -86,27 +269,40 @@
(newOptsNonceParams opts)
absDir
templateText
- when (not forceOverwrite && bare) $ checkForOverwrite (M.keys files)
+ when (not forceOverwrite && bare) $
+ checkForOverwrite (templateName template) (M.keys files)
writeTemplateFiles files
runTemplateInits absDir
- return absDir
+ pure absDir
where
cliOptionTemplate = newOptsTemplate opts
project = newOptsProjectName opts
+ projectName = packageNameString project
bare = newOptsCreateBare opts
logUsing absDir template templateFrom =
let loading = case templateFrom of
- LocalTemp -> "Loading local"
+ LocalTemp -> flow "Loading local"
RemoteTemp -> "Downloading"
- in
- logInfo
- (loading <> " template \"" <> display (templateName template) <>
- "\" to create project \"" <>
- fromString (packageNameString project) <>
- "\" in " <>
- if bare then "the current directory"
- else fromString (toFilePath (dirname absDir)) <>
- " ...")
+ in prettyInfo
+ ( fillSep
+ [ loading
+ , "template"
+ , style
+ Current
+ (fromString $ T.unpack $ templateName template)
+ , flow "to create project"
+ , style Current (fromString projectName)
+ , "in"
+ , ( if bare
+ then flow "the current directory"
+ else fillSep
+ [ "directory"
+ , style Dir (pretty $ dirname absDir)
+ ]
+ )
+ <> "..."
+ ]
+ )
data TemplateFrom = LocalTemp | RemoteTemp
@@ -119,7 +315,8 @@
loadTemplate name logIt = do
templateDir <- view $ configL.to templatesDir
case templatePath name of
- AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile eitherByteStringToText
+ AbsPath absFile ->
+ logIt LocalTemp >> loadLocalFile absFile eitherByteStringToText
UrlPath s -> do
let settings = asIsFromUrl s
downloadFromUrl settings templateDir
@@ -127,13 +324,13 @@
catch
(do f <- loadLocalFile relFile eitherByteStringToText
logIt LocalTemp
- return f)
- (\(e :: NewException) -> do
+ pure f)
+ (\(e :: PrettyException) -> do
case relSettings rawParam of
Just settings -> do
- req <- parseRequest (tplDownloadUrl settings)
- let extract = tplExtract settings
- downloadTemplate req extract (templateDir relFile)
+ let url = tplDownloadUrl settings
+ extract = tplExtract settings
+ downloadTemplate url extract (templateDir relFile)
Nothing -> throwM e
)
RepoPath rtp -> do
@@ -141,7 +338,9 @@
downloadFromUrl settings templateDir
where
- loadLocalFile :: Path b File -> (ByteString -> Either String Text) -> RIO env Text
+ loadLocalFile :: Path b File
+ -> (ByteString -> Either String Text)
+ -> RIO env Text
loadLocalFile path extract = do
logDebug ("Opening local template: \"" <> fromString (toFilePath path)
<> "\"")
@@ -150,41 +349,59 @@
then do
bs <- readFileBinary (toFilePath path) --readFileUtf8 (toFilePath path)
case extract bs of
- Left err -> do
- logWarn $ "Template extraction error: " <> display (T.pack err)
- throwM (FailedToLoadTemplate name (toFilePath path))
+ Left err -> throwM $ PrettyException $
+ ExtractTemplateFailed name path err
Right template ->
pure template
- else throwM (FailedToLoadTemplate name (toFilePath path))
+ else throwM $ PrettyException $
+ LoadTemplateFailed name path
+
relSettings :: String -> Maybe TemplateDownloadSettings
relSettings req = do
rtp <- parseRepoPathWithService defaultRepoService (T.pack req)
pure (settingsFromRepoTemplatePath rtp)
+
downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl settings templateDir = do
let url = tplDownloadUrl settings
+ rel = fromMaybe backupUrlRelPath (parseRelFile url)
+ downloadTemplate url (tplExtract settings) (templateDir rel)
+
+ downloadTemplate :: String
+ -> (ByteString
+ -> Either String Text)
+ -> Path Abs File
+ -> RIO env Text
+ downloadTemplate url extract path = do
req <- parseRequest url
- let rel = fromMaybe backupUrlRelPath (parseRelFile url)
- downloadTemplate req (tplExtract settings) (templateDir rel)
- downloadTemplate :: Request -> (ByteString -> Either String Text) -> Path Abs File -> RIO env Text
- downloadTemplate req extract path = do
- let dReq = setForceDownload True $ mkDownloadRequest (setRequestCheckStatus req)
+ let dReq = setForceDownload True $
+ mkDownloadRequest (setRequestCheckStatus req)
logIt RemoteTemp
catch
- (void $ do
- verifiedDownloadWithProgress dReq path (T.pack $ toFilePath path) Nothing
+ ( do let label = T.pack $ toFilePath path
+ res <- verifiedDownloadWithProgress dReq path label Nothing
+ if res
+ then logStickyDone ("Downloaded " <> display label <> ".")
+ else logStickyDone "Already downloaded."
)
- (useCachedVersionOrThrow path)
-
+ (useCachedVersionOrThrow url path)
loadLocalFile path extract
- useCachedVersionOrThrow :: Path Abs File -> VerifiedDownloadException -> RIO env ()
- useCachedVersionOrThrow path exception = do
+
+ useCachedVersionOrThrow :: String
+ -> Path Abs File
+ -> VerifiedDownloadException
+ -> RIO env ()
+ useCachedVersionOrThrow url path exception = do
exists <- doesFileExist path
if exists
- then do logWarn "Tried to download the template but an error was found."
- logWarn "Using cached local version. It may not be the most recent version though."
- else throwM (FailedToDownloadTemplate name exception)
+ then prettyWarn
+ ( flow "Tried to download the template but an error was \
+ \found. Using cached local version. It may not be the \
+ \most recent version though."
+ )
+ else throwM $ PrettyException $
+ DownloadTemplateFailed (templateName name) url exception
data TemplateDownloadSettings = TemplateDownloadSettings
{ tplDownloadUrl :: String
@@ -205,7 +422,12 @@
settingsFromRepoTemplatePath (RepoTemplatePath GitHub user name) =
-- T.concat ["https://raw.githubusercontent.com", "/", user, "/stack-templates/master/", name]
TemplateDownloadSettings
- { tplDownloadUrl = concat ["https://api.github.com/repos/", T.unpack user, "/stack-templates/contents/", T.unpack name]
+ { tplDownloadUrl = concat
+ [ "https://api.github.com/repos/"
+ , T.unpack user
+ , "/stack-templates/contents/"
+ , T.unpack name
+ ]
, tplExtract = \bs -> do
decodedJson <- eitherDecode (LB.fromStrict bs)
case decodedJson of
@@ -218,9 +440,21 @@
}
settingsFromRepoTemplatePath (RepoTemplatePath GitLab user name) =
- asIsFromUrl $ concat ["https://gitlab.com", "/", T.unpack user, "/stack-templates/raw/master/", T.unpack name]
+ asIsFromUrl $ concat
+ [ "https://gitlab.com"
+ , "/"
+ , T.unpack user
+ , "/stack-templates/raw/master/"
+ , T.unpack name
+ ]
settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) =
- asIsFromUrl $ concat ["https://bitbucket.org", "/", T.unpack user, "/stack-templates/raw/master/", T.unpack name]
+ asIsFromUrl $ concat
+ [ "https://bitbucket.org"
+ , "/"
+ , T.unpack user
+ , "/stack-templates/raw/master/"
+ , T.unpack name
+ ]
-- | Apply and unpack a template into a directory.
applyTemplate
@@ -236,30 +470,41 @@
currentYear <- do
now <- liftIO getCurrentTime
let (year, _, _) = toGregorian (utctDay now)
- return $ T.pack . show $ year
+ pure $ T.pack . show $ year
let context = M.unions [nonceParams, nameParams, configParams, yearParam]
where
nameAsVarId = T.replace "-" "_" $ T.pack $ packageNameString project
- nameAsModule = T.filter (/= ' ') $ T.toTitle $ T.replace "-" " " $ T.pack $ packageNameString project
+ nameAsModule = T.filter (/= ' ') $ T.toTitle $ T.replace "-" " " $
+ T.pack $ packageNameString project
nameParams = M.fromList [ ("name", T.pack $ packageNameString project)
, ("name-as-varid", nameAsVarId)
, ("name-as-module", nameAsModule) ]
configParams = configTemplateParams config
yearParam = M.singleton "year" currentYear
files :: Map FilePath LB.ByteString <-
- catch (execWriterT $ runConduit $
- yield (T.encodeUtf8 templateText) .|
- unpackTemplate receiveMem id
- )
- (\(e :: ProjectTemplateException) ->
- throwM (InvalidTemplate template (show e)))
+ catch
+ ( execWriterT $ runConduit $
+ yield (T.encodeUtf8 templateText) .|
+ unpackTemplate receiveMem id
+ )
+ ( \(e :: ProjectTemplateException) ->
+ throwM $ PrettyException $
+ TemplateInvalid template (string $ displayException e)
+ )
when (M.null files) $
- throwM (InvalidTemplate template "Template does not contain any files")
+ throwM $ PrettyException $
+ TemplateInvalid
+ template
+ (flow "the template does not contain any files.")
- let isPkgSpec f = ".cabal" `isSuffixOf` f || f == "package.yaml"
+ let isPkgSpec f = ".cabal" `L.isSuffixOf` f || f == "package.yaml"
unless (any isPkgSpec . M.keys $ files) $
- throwM (InvalidTemplate template
- "Template does not contain a .cabal or package.yaml file")
+ throwM $ PrettyException $
+ TemplateInvalid
+ template
+ ( flow "the template does not contain a Cabal or package.yaml \
+ \file."
+ )
-- Apply Mustache templating to a single file within the project template.
let applyMustache bytes
@@ -271,8 +516,16 @@
, Right text <- TLE.decodeUtf8' bytes = do
let etemplateCompiled = Mustache.compileTemplate (T.unpack (templateName template)) $ TL.toStrict text
templateCompiled <- case etemplateCompiled of
- Left e -> throwM $ InvalidTemplate template (show e)
- Right t -> return t
+ Left e -> throwM $ PrettyException $
+ TemplateInvalid
+ template
+ ( flow "Stack encountered the following error:"
+ <> blankLine
+ -- Text.Parsec.Error.ParseError is not an instance
+ -- of Control.Exception.
+ <> string (show e)
+ )
+ Right t -> pure t
let (substitutionErrors, applied) = Mustache.checkedSubstitute templateCompiled context
missingKeys = S.fromList $ concatMap onlyMissingKeys substitutionErrors
pure (LB.fromStrict $ encodeUtf8 applied, missingKeys)
@@ -287,33 +540,86 @@
(fp, mks1) <- applyMustache $ TLE.encodeUtf8 $ TL.pack fpOrig
path <- parseRelFile $ TL.unpack $ TLE.decodeUtf8 fp
(bytes', mks2) <- applyMustache bytes
- return (mks <> mks1 <> mks2, (dir path, bytes'))
+ pure (mks <> mks1 <> mks2, (dir path, bytes'))
(missingKeys, results) <- mapAccumLM processFile S.empty (M.toList files)
unless (S.null missingKeys) $ do
- let missingParameters = MissingParameters
- project
- template
- missingKeys
- (configUserConfigPath config)
- logInfo ("\n" <> displayShow missingParameters <> "\n")
- return $ M.fromList results
+ prettyNote $
+ missingParameters
+ missingKeys
+ (configUserConfigPath config)
+ pure $ M.fromList results
where
onlyMissingKeys (Mustache.VariableNotFound ks) = map T.unpack ks
onlyMissingKeys _ = []
mapAccumLM :: Monad m => (a -> b -> m(a, c)) -> a -> [b] -> m(a, [c])
- mapAccumLM _ a [] = return (a, [])
+ mapAccumLM _ a [] = pure (a, [])
mapAccumLM f a (x:xs) = do
(a', c) <- f a x
(a'', cs) <- mapAccumLM f a' xs
- return (a'', c:cs)
+ pure (a'', c:cs)
+ missingParameters
+ :: Set String
+ -> Path Abs File
+ -> StyleDoc
+ missingParameters missingKeys userConfigPath =
+ fillSep
+ ( flow "The following parameters were needed by the template but \
+ \not provided:"
+ : mkNarrativeList
+ Nothing
+ False
+ (map toStyleDoc (S.toList missingKeys))
+ )
+ <> blankLine
+ <> fillSep
+ [ flow "You can provide them in Stack's global YAML configuration \
+ \file"
+ , "(" <> style File (pretty userConfigPath) <> ")"
+ , "like this:"
+ ]
+ <> blankLine
+ <> "templates:"
+ <> line
+ <> " params:"
+ <> line
+ <> vsep
+ ( map
+ (\key -> " " <> fromString key <> ": value")
+ (S.toList missingKeys)
+ )
+ <> blankLine
+ <> flow "Or you can pass each one on the command line as parameters \
+ \like this:"
+ <> blankLine
+ <> style Shell
+ ( fillSep
+ [ flow "stack new"
+ , fromString (packageNameString project)
+ , fromString $ T.unpack (templateName template)
+ , hsep $
+ map
+ ( \key ->
+ fillSep [ "-p"
+ , "\"" <> fromString key <> ":value\""
+ ]
+ )
+ (S.toList missingKeys)
+ ]
+ )
+ <> line
+ where
+ toStyleDoc :: String -> StyleDoc
+ toStyleDoc = fromString
+
-- | Check if we're going to overwrite any existing files.
-checkForOverwrite :: (MonadIO m, MonadThrow m) => [Path Abs File] -> m ()
-checkForOverwrite files = do
+checkForOverwrite :: (MonadIO m, MonadThrow m) => Text -> [Path Abs File] -> m ()
+checkForOverwrite name files = do
overwrites <- filterM doesFileExist files
- unless (null overwrites) $ throwM (AttemptedOverwrites overwrites)
+ unless (null overwrites) $
+ throwM $ PrettyException $ AttemptedOverwrites name overwrites
-- | Write files to the new project directory.
writeTemplateFiles
@@ -335,20 +641,28 @@
runTemplateInits dir = do
config <- view configL
case configScmInit config of
- Nothing -> return ()
- Just Git ->
- withWorkingDir (toFilePath dir) $
- catchAny (proc "git" ["init"] runProcess_)
- (\_ -> logInfo "git init failed to run, ignoring ...")
+ Nothing -> pure ()
+ Just Git -> withWorkingDir (toFilePath dir) $
+ catchAny
+ (proc "git" ["init"] runProcess_)
+ ( \_ -> prettyWarn $
+ fillSep
+ [ flow "Stack failed to run a"
+ , style Shell (flow "git init")
+ , flow "command. Ignoring..."
+ ]
+ )
-- | Display help for the templates command.
templatesHelp :: HasLogFunc env => RIO env ()
templatesHelp = do
let url = defaultTemplatesHelpUrl
req <- liftM setGitHubHeaders (parseUrlThrow url)
- resp <- httpLbs req `catch` (throwM . FailedToDownloadTemplatesHelp)
+ resp <- catch
+ (httpLbs req)
+ (throwM . PrettyException. DownloadTemplatesHelpFailed)
case decodeUtf8' $ LB.toStrict $ getResponseBody resp of
- Left err -> throwM $ BadTemplatesHelpEncoding url err
+ Left err -> throwM $ PrettyException $ TemplatesHelpEncodingInvalid url err
Right txt -> logInfo $ display txt
--------------------------------------------------------------------------------
@@ -362,79 +676,3 @@
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl =
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"
-
---------------------------------------------------------------------------------
--- Exceptions
-
--- | Exception that might occur when making a new project.
-data NewException
- = FailedToLoadTemplate !TemplateName
- !FilePath
- | FailedToDownloadTemplate !TemplateName
- !VerifiedDownloadException
- | AlreadyExists !(Path Abs Dir)
- | MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)
- | InvalidTemplate !TemplateName !String
- | AttemptedOverwrites [Path Abs File]
- | FailedToDownloadTemplatesHelp !HttpException
- | BadTemplatesHelpEncoding
- !String -- URL it's downloaded from
- !UnicodeException
- | Can'tUseWiredInName !PackageName
- deriving (Typeable)
-
-instance Exception NewException
-
-instance Show NewException where
- show (FailedToLoadTemplate name path) =
- "Failed to load download template " <> T.unpack (templateName name) <>
- " from " <>
- path
- show (FailedToDownloadTemplate name (DownloadHttpError httpError)) =
- "There was an unexpected HTTP error while downloading template " <>
- T.unpack (templateName name) <> ": " <> show httpError
- show (FailedToDownloadTemplate name _) =
- "Failed to download template " <> T.unpack (templateName name) <>
- ": unknown reason"
-
- show (AlreadyExists path) =
- "Directory " <> toFilePath path <> " already exists. Aborting."
- show (MissingParameters name template missingKeys userConfigPath) =
- intercalate
- "\n"
- [ "The following parameters were needed by the template but not provided: " <>
- intercalate ", " (S.toList missingKeys)
- , "You can provide them in " <>
- toFilePath userConfigPath <>
- ", 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))]
- show (InvalidTemplate name why) =
- "The template \"" <> T.unpack (templateName name) <>
- "\" is invalid and could not be used. " <>
- "The error was: " <> why
- show (AttemptedOverwrites fps) =
- "The template would create the following files, but they already exist:\n" <>
- unlines (map ((" " ++) . toFilePath) fps) <>
- "Use --force to ignore this, and overwrite these files."
- show (FailedToDownloadTemplatesHelp ex) =
- "Failed to download `stack templates` help. The HTTP error was: " <> show ex
- show (BadTemplatesHelpEncoding url err) =
- "UTF-8 decoding error on template info from\n " <> url <> "\n\n" <> show err
- show (Can'tUseWiredInName name) =
- "The name \"" <> packageNameString name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name"
diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs
--- a/src/Stack/Nix.hs
+++ b/src/Stack/Nix.hs
@@ -7,113 +7,152 @@
-- | Run commands in a nix-shell
module Stack.Nix
- (nixCmdName
- ,nixHelpOptName
- ,runShellAndExit
+ ( nixCmdName
+ , nixHelpOptName
+ , runShellAndExit
) where
-import Stack.Prelude
import qualified Data.Text as T
-import Data.Version (showVersion)
-import Path.IO
-import qualified Paths_stack as Meta
-import Stack.Config (getInContainer, withBuildConfig)
-import Stack.Config.Nix (nixCompiler, nixCompilerVersion)
-import Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar)
+import Path.IO ( resolveFile )
+import RIO.Process ( exec, processContextL )
+import Stack.Config ( getInContainer, withBuildConfig )
+import Stack.Config.Nix ( nixCompiler, nixCompilerVersion )
+import Stack.Constants
+ ( inContainerEnvVar, inNixShellEnvVar
+ , platformVariantEnvVar
+ )
+import Stack.Prelude
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Nix
-import System.Environment (getArgs,getExecutablePath,lookupEnv)
-import qualified System.FilePath as F
-import RIO.Process (processContextL, exec)
+import Stack.Types.Version ( showStackVersion )
+import System.Environment ( getArgs, getExecutablePath, lookupEnv )
+import qualified System.FilePath as F
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Nix" module.
+data NixException
+ = CannotDetermineProjectRoot
+ -- ^ Can't determine the project root (location of the shell file if any).
+ deriving (Show, Typeable)
+
+instance Exception NixException where
+ displayException CannotDetermineProjectRoot =
+ "Error: [S-7384]\n"
+ ++ "Cannot determine project root directory."
+
runShellAndExit :: RIO Config void
runShellAndExit = do
- inContainer <- getInContainer -- TODO we can probably assert that this is False based on Stack.Runners now
- origArgs <- liftIO getArgs
- let args | inContainer = origArgs -- internal-re-exec version already passed
- -- first stack when restarting in the container
- | otherwise =
- ("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) : origArgs
- exePath <- liftIO getExecutablePath
- config <- view configL
- envOverride <- view processContextL
- local (set processContextL envOverride) $ do
- let cmnd = escape exePath
- args' = map escape args
+ inContainer <- getInContainer -- TODO we can probably assert that this is False based on Stack.Runners now
+ origArgs <- liftIO getArgs
+ let args | inContainer = origArgs -- internal-re-exec version already passed
+ -- first stack when restarting in the container
+ | otherwise =
+ ("--" ++ reExecArgName ++ "=" ++ showStackVersion) : origArgs
+ exePath <- liftIO getExecutablePath
+ config <- view configL
+ envOverride <- view processContextL
+ local (set processContextL envOverride) $ do
+ let cmnd = escape exePath
+ args' = map escape args
- mshellFile <- case configProjectRoot config of
- Just projectRoot ->
- traverse (resolveFile projectRoot) $ nixInitFile (configNix config)
- Nothing -> pure Nothing
+ mshellFile <- case configProjectRoot config of
+ Just projectRoot ->
+ traverse (resolveFile projectRoot) $ nixInitFile (configNix config)
+ Nothing -> pure Nothing
- -- This will never result in double loading the build config, since:
- --
- -- 1. This function explicitly takes a Config, not a HasConfig
- --
- -- 2. This function ends up exiting before running other code
- -- (thus the void return type)
- compilerVersion <- withBuildConfig $ view wantedCompilerVersionL
+ -- This will never result in double loading the build config, since:
+ --
+ -- 1. This function explicitly takes a Config, not a HasConfig
+ --
+ -- 2. This function ends up exiting before running other code
+ -- (thus the void return type)
+ compilerVersion <- withBuildConfig $ view wantedCompilerVersionL
- ghc <- either throwIO return $ nixCompiler compilerVersion
- ghcVersion <- either throwIO return $ nixCompilerVersion compilerVersion
- let pkgsInConfig = nixPackages (configNix config)
- pkgs = pkgsInConfig ++ [ghc, "git", "gcc", "gmp"]
- pkgsStr = "[" <> T.intercalate " " pkgs <> "]"
- pureShell = nixPureShell (configNix config)
- addGCRoots = nixAddGCRoots (configNix config)
- nixopts = case mshellFile of
- Just fp -> [toFilePath fp
- ,"--arg", "ghc", "with (import {}); " ++ T.unpack ghc
- ,"--argstr", "ghcVersion", T.unpack ghcVersion]
- Nothing -> ["-E", T.unpack $ T.concat
- ["with (import {}); "
- ,"let inputs = ",pkgsStr,"; "
- , "libPath = lib.makeLibraryPath inputs; "
- , "stackExtraArgs = lib.concatMap (pkg: "
- , "[ ''--extra-lib-dirs=${lib.getLib pkg}/lib'' "
- , " ''--extra-include-dirs=${lib.getDev pkg}/include'' ]"
- , ") inputs; in "
- ,"runCommand ''myEnv'' { "
- ,"buildInputs = lib.optional stdenv.isLinux glibcLocales ++ inputs; "
- ,T.pack platformVariantEnvVar <> "=''nix''; "
- ,T.pack inNixShellEnvVar <> "=1; "
- ,if inContainer
- -- If shell is pure, this env var would not
- -- be seen by stack inside nix
- then T.pack inContainerEnvVar <> "=1; "
- else ""
- ,"LD_LIBRARY_PATH = libPath;" -- LD_LIBRARY_PATH is set because for now it's
- -- needed by builds using Template Haskell
- ,"STACK_IN_NIX_EXTRA_ARGS = stackExtraArgs; "
- -- overriding default locale so Unicode output using base won't be broken
- ,"LANG=\"en_US.UTF-8\";"
- ,"} \"\""]]
- -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.
- fullArgs = concat [if pureShell then ["--pure"] else []
- ,if addGCRoots then ["--indirect", "--add-root"
- ,toFilePath (configWorkDir config)
- F. "nix-gc-symlinks" F. "gc-root"] else []
- ,map T.unpack (nixShellOptions (configNix config))
- ,nixopts
- ,["--run", unwords (cmnd:"$STACK_IN_NIX_EXTRA_ARGS":args')]
- ]
- -- Using --run instead of --command so we cannot
- -- end up in the nix-shell if stack build is Ctrl-C'd
- pathVar <- liftIO $ lookupEnv "PATH"
- logDebug $ "PATH is: " <> displayShow pathVar
- logDebug $
- "Using a nix-shell environment " <> (case mshellFile of
- Just path -> "from file: " <> fromString (toFilePath path)
- Nothing -> "with nix packages: " <> display (T.intercalate ", " pkgs))
- exec "nix-shell" fullArgs
+ ghc <- either throwIO pure $ nixCompiler compilerVersion
+ ghcVersion <- either throwIO pure $ nixCompilerVersion compilerVersion
+ let pkgsInConfig = nixPackages (configNix config)
+ pkgs = pkgsInConfig ++ [ghc, "git", "gcc", "gmp"]
+ pkgsStr = "[" <> T.intercalate " " pkgs <> "]"
+ pureShell = nixPureShell (configNix config)
+ addGCRoots = nixAddGCRoots (configNix config)
+ nixopts = case mshellFile of
+ Just fp ->
+ [ toFilePath fp
+ , "--arg"
+ , "ghc"
+ , "with (import {}); " ++ T.unpack ghc
+ , "--argstr", "ghcVersion", T.unpack ghcVersion
+ ]
+ Nothing ->
+ [ "-E"
+ , T.unpack $ T.concat
+ [ "with (import {}); "
+ , "let inputs = ",pkgsStr,"; "
+ , "libPath = lib.makeLibraryPath inputs; "
+ , "stackExtraArgs = lib.concatMap (pkg: "
+ , "[ ''--extra-lib-dirs=${lib.getLib pkg}/lib'' "
+ , " ''--extra-include-dirs=${lib.getDev pkg}/include'' ]"
+ , ") inputs; in "
+ , "runCommand ''myEnv'' { "
+ , "buildInputs = lib.optional stdenv.isLinux glibcLocales ++ inputs; "
+ -- glibcLocales is necessary on Linux to avoid warnings about
+ -- GHC being incapable to set the locale.
+ , T.pack platformVariantEnvVar <> "=''nix''; "
+ , T.pack inNixShellEnvVar <> "=1; "
+ , if inContainer
+ -- If shell is pure, this env var would not
+ -- be seen by stack inside nix
+ then T.pack inContainerEnvVar <> "=1; "
+ else ""
+ , "LD_LIBRARY_PATH = libPath;"
+ -- LD_LIBRARY_PATH is set because for now it's needed by
+ -- builds using Template Haskell
+ , "STACK_IN_NIX_EXTRA_ARGS = stackExtraArgs; "
+ -- overriding default locale so Unicode output using base
+ -- won't be broken
+ , "LANG=\"en_US.UTF-8\";"
+ , "} \"\""
+ ]
+ ]
+ fullArgs = concat
+ [ if pureShell then ["--pure"] else []
+ , if addGCRoots
+ then [ "--indirect"
+ , "--add-root"
+ , toFilePath
+ (configWorkDir config)
+ F. "nix-gc-symlinks"
+ F. "gc-root"
+ ]
+ else []
+ , map T.unpack (nixShellOptions (configNix config))
+ , nixopts
+ , ["--run", unwords (cmnd:"$STACK_IN_NIX_EXTRA_ARGS":args')]
+ -- Using --run instead of --command so we cannot end up in the
+ -- nix-shell if stack build is Ctrl-C'd
+ ]
+ pathVar <- liftIO $ lookupEnv "PATH"
+ logDebug $ "PATH is: " <> displayShow pathVar
+ logDebug $
+ "Using a nix-shell environment "
+ <> ( case mshellFile of
+ Just path ->
+ "from file: "
+ <> fromString (toFilePath path)
+ Nothing ->
+ "with nix packages: "
+ <> display (T.intercalate ", " pkgs)
+ )
+ exec "nix-shell" fullArgs
+
-- | Shell-escape quotes inside the string and enclose it in quotes.
escape :: String -> String
-escape str = "'" ++ foldr (\c -> if c == '\'' then
- ("'\"'\"'"++)
- else (c:)) "" str
- ++ "'"
+escape str =
+ "'"
+ ++ foldr (\c -> if c == '\'' then ("'\"'\"'"++) else (c:)) "" str
+ ++ "'"
-- | Command-line argument for "nix"
nixCmdName :: String
@@ -121,15 +160,3 @@
nixHelpOptName :: String
nixHelpOptName = nixCmdName ++ "-help"
-
--- | Exceptions thrown by "Stack.Nix".
-data StackNixException
- = CannotDetermineProjectRoot
- -- ^ Can't determine the project root (location of the shell file if any).
- deriving (Typeable)
-
-instance Exception StackNixException
-
-instance Show StackNixException where
- show CannotDetermineProjectRoot =
- "Cannot determine project root directory."
diff --git a/src/Stack/Options/BenchParser.hs b/src/Stack/Options/BenchParser.hs
--- a/src/Stack/Options/BenchParser.hs
+++ b/src/Stack/Options/BenchParser.hs
@@ -1,25 +1,34 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-module Stack.Options.BenchParser where
+module Stack.Options.BenchParser
+ ( benchOptsParser
+ ) where
import Options.Applicative
-import Options.Applicative.Builder.Extra
+ ( Parser, flag', help, long, metavar, strOption )
+import Options.Applicative.Builder.Extra ( optionalFirst )
import Stack.Prelude
-import Stack.Options.Utils
-import Stack.Types.Config
+import Stack.Options.Utils ( hideMods )
+import Stack.Types.Config ( BenchmarkOptsMonoid (..) )
-- | Parser for bench arguments.
-- FIXME hiding options
benchOptsParser :: Bool -> Parser BenchmarkOptsMonoid
benchOptsParser hide0 = BenchmarkOptsMonoid
- <$> optionalFirst (strOption (long "benchmark-arguments" <>
- long "ba" <>
- metavar "BENCH_ARGS" <>
- help ("Forward BENCH_ARGS to the benchmark suite. " <>
- "Supports templates from `cabal bench`") <>
- hide))
- <*> optionalFirst (flag' True (long "no-run-benchmarks" <>
- help "Disable running of benchmarks. (Benchmarks will still be built.)" <>
- hide))
- where hide = hideMods hide0
+ <$> optionalFirst (strOption
+ ( long "benchmark-arguments"
+ <> long "ba"
+ <> metavar "BENCH_ARGS"
+ <> help "Forward BENCH_ARGS to the benchmark suite. Supports templates \
+ \from `cabal bench`"
+ <> hide
+ ))
+ <*> optionalFirst (flag' True
+ ( long "no-run-benchmarks"
+ <> help "Disable running of benchmarks. (Benchmarks will still be \
+ \built.)"
+ <> hide
+ ))
+ where
+ hide = hideMods hide0
diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs
--- a/src/Stack/Options/BuildMonoidParser.hs
+++ b/src/Stack/Options/BuildMonoidParser.hs
@@ -1,185 +1,206 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.BuildMonoidParser where
+module Stack.Options.BuildMonoidParser
+ ( buildOptsMonoidParser
+ , cabalVerboseParser
+ , cabalVerbosityOptsParser
+ , cabalVerbosityParser
+ ) where
import qualified Data.Text as T
-import Distribution.Parsec (eitherParsec)
+import Distribution.Parsec ( eitherParsec )
import Options.Applicative
+ ( Parser, eitherReader, flag, help, long, metavar, option
+ , strOption
+ )
import Options.Applicative.Builder.Extra
-import Stack.Build (splitObjsWarning)
+ ( firstBoolFlagsFalse, firstBoolFlagsNoDefault
+ , firstBoolFlagsTrue, optionalFirst
+ )
+import Stack.Build ( splitObjsWarning )
import Stack.Prelude
-import Stack.Options.BenchParser
-import Stack.Options.TestParser
-import Stack.Options.HaddockParser
-import Stack.Options.Utils
+import Stack.Options.BenchParser ( benchOptsParser )
+import Stack.Options.TestParser ( testOptsParser )
+import Stack.Options.HaddockParser ( haddockOptsParser )
+import Stack.Options.Utils ( GlobalOptsContext (..), hideMods )
import Stack.Types.Config.Build
+ ( BuildOptsMonoid (..), CabalVerbosity
+ , toFirstCabalVerbosity
+ )
buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid
-buildOptsMonoidParser hide0 =
- BuildOptsMonoid <$> trace' <*> profile <*> noStrip <*>
- libProfiling <*> exeProfiling <*> libStripping <*>
- exeStripping <*> haddock <*> haddockOptsParser hideBool <*>
- openHaddocks <*> haddockDeps <*> haddockInternal <*>
- haddockHyperlinkSource <*> copyBins <*> copyCompilerTool <*>
- preFetch <*> keepGoing <*> keepTmpFiles <*> forceDirty <*>
- tests <*> testOptsParser hideBool <*> benches <*>
- benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents <*>
- interleavedOutput <*> ddumpDir
- where
- hideBool = hide0 /= BuildCmdGlobalOpts
- hide =
- hideMods hideBool
- hideExceptGhci =
- hideMods (hide0 `notElem` [BuildCmdGlobalOpts, GhciCmdGlobalOpts])
+buildOptsMonoidParser hide0 = BuildOptsMonoid
+ <$> trace'
+ <*> profile
+ <*> noStrip
+ <*> libProfiling
+ <*> exeProfiling
+ <*> libStripping
+ <*> exeStripping
+ <*> haddock
+ <*> haddockOptsParser hideBool
+ <*> openHaddocks
+ <*> haddockDeps
+ <*> haddockInternal
+ <*> haddockHyperlinkSource
+ <*> copyBins
+ <*> copyCompilerTool
+ <*> preFetch
+ <*> keepGoing
+ <*> keepTmpFiles
+ <*> forceDirty
+ <*> tests
+ <*> testOptsParser hideBool
+ <*> benches
+ <*> benchOptsParser hideBool
+ <*> reconfigure
+ <*> cabalVerbose
+ <*> splitObjs
+ <*> skipComponents
+ <*> interleavedOutput
+ <*> ddumpDir
+ where
+ hideBool = hide0 /= BuildCmdGlobalOpts
+ hide = hideMods hideBool
+ hideExceptGhci =
+ hideMods (hide0 `notElem` [BuildCmdGlobalOpts, GhciCmdGlobalOpts])
- -- These use 'Any' because they are not settable in stack.yaml, so
- -- there is no need for options like --no-profile.
- trace' = Any <$>
- flag
- False
- True
- (long "trace" <>
- help
- "Enable profiling in libraries, executables, etc. \
- \for all expressions and generate a backtrace on \
- \exception" <>
- hideExceptGhci)
- profile = Any <$>
- flag
- False
- True
- (long "profile" <>
- help
- "profiling in libraries, executables, etc. \
- \for all expressions and generate a profiling report\
- \ in tests or benchmarks" <>
- hideExceptGhci)
- noStrip = Any <$>
- flag
- False
- True
- (long "no-strip" <>
- help
- "Disable DWARF debugging symbol stripping in libraries, \
- \executables, etc. for all expressions, producing \
- \larger executables but allowing the use of standard \
- \debuggers/profiling tools/other utilities that use \
- \debugging symbols." <>
- hideExceptGhci)
- libProfiling =
- firstBoolFlagsFalse
- "library-profiling"
- "library profiling for TARGETs and all its dependencies"
- hide
- exeProfiling =
- firstBoolFlagsFalse
- "executable-profiling"
- "executable profiling for TARGETs and all its dependencies"
- hide
- libStripping =
- firstBoolFlagsTrue
- "library-stripping"
- "library stripping for TARGETs and all its dependencies"
- hide
- exeStripping =
- firstBoolFlagsTrue
- "executable-stripping"
- "executable stripping for TARGETs and all its dependencies"
- hide
- haddock =
- firstBoolFlagsFalse
- "haddock"
- "generating Haddocks the package(s) in this directory/configuration"
- hide
- openHaddocks =
- firstBoolFlagsFalse
- "open"
- "opening the local Haddock documentation in the browser"
- hide
- haddockDeps =
- firstBoolFlagsNoDefault
- "haddock-deps"
- "building Haddocks for dependencies (default: true if building Haddocks, false otherwise)"
- hide
- haddockInternal =
- firstBoolFlagsFalse
- "haddock-internal"
- "building Haddocks for internal modules (like cabal haddock --internal)"
- hide
- haddockHyperlinkSource =
- firstBoolFlagsTrue
- "haddock-hyperlink-source"
- "building hyperlinked source for Haddock (like haddock --hyperlinked-source)"
- hide
- copyBins =
- firstBoolFlagsFalse
- "copy-bins"
- "copying binaries to local-bin (see 'stack path')"
- hide
- copyCompilerTool =
- firstBoolFlagsFalse
- "copy-compiler-tool"
- "copying binaries of targets to compiler-tools-bin (see 'stack path')"
- hide
- keepGoing =
- firstBoolFlagsNoDefault
- "keep-going"
- "continue running after a step fails (default: false for build, true for test/bench)"
- hide
- keepTmpFiles =
- firstBoolFlagsFalse
- "keep-tmp-files"
- "keep intermediate files and build directories"
- hide
- preFetch =
- firstBoolFlagsFalse
- "prefetch"
- "Fetch packages necessary for the build immediately, useful with --dry-run"
- hide
- forceDirty =
- firstBoolFlagsFalse
- "force-dirty"
- "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change"
- hide
- tests =
- firstBoolFlagsFalse
- "test"
- "testing the package(s) in this directory/configuration"
- hideExceptGhci
- benches =
- firstBoolFlagsFalse
- "bench"
- "benchmarking the package(s) in this directory/configuration"
- hideExceptGhci
- reconfigure =
- firstBoolFlagsFalse
- "reconfigure"
- "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files"
- hide
- cabalVerbose = cabalVerbosityOptsParser hideBool
- splitObjs =
- firstBoolFlagsFalse
- "split-objs"
- ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning)
- hide
- skipComponents = many
- (fmap
- T.pack
- (strOption
- (long "skip" <>
- help "Skip given component (can be specified multiple times)" <>
- hide)))
- interleavedOutput =
- firstBoolFlagsTrue
- "interleaved-output"
- "Print concurrent GHC output to the console with a prefix for the package name"
- hide
- ddumpDir =
- optionalFirst
- (strOption
- (long "ddump-dir" <>
- help "Specify output ddump-files" <>
- hide))
+ -- These use 'Any' because they are not settable in stack.yaml, so
+ -- there is no need for options like --no-profile.
+ trace' = Any <$>
+ flag
+ False
+ True
+ ( long "trace"
+ <> help
+ "Enable profiling in libraries, executables, etc. for all \
+ \expressions and generate a backtrace on exception"
+ <> hideExceptGhci
+ )
+ profile = Any <$>
+ flag
+ False
+ True
+ ( long "profile"
+ <> help
+ "Enable profiling in libraries, executables, etc. for all \
+ \expressions and generate a profiling report in tests or \
+ \benchmarks"
+ <> hideExceptGhci
+ )
+ noStrip = Any <$>
+ flag
+ False
+ True
+ ( long "no-strip"
+ <> help
+ "Disable DWARF debugging symbol stripping in libraries, \
+ \executables, etc. for all expressions, producing larger \
+ \executables but allowing the use of standard \
+ \debuggers/profiling tools/other utilities that use \
+ \debugging symbols."
+ <> hideExceptGhci
+ )
+ libProfiling = firstBoolFlagsFalse
+ "library-profiling"
+ "library profiling for TARGETs and all its dependencies"
+ hide
+ exeProfiling = firstBoolFlagsFalse
+ "executable-profiling"
+ "executable profiling for TARGETs and all its dependencies"
+ hide
+ libStripping = firstBoolFlagsTrue
+ "library-stripping"
+ "library stripping for TARGETs and all its dependencies"
+ hide
+ exeStripping = firstBoolFlagsTrue
+ "executable-stripping"
+ "executable stripping for TARGETs and all its dependencies"
+ hide
+ haddock = firstBoolFlagsFalse
+ "haddock"
+ "generating Haddocks the package(s) in this directory/configuration"
+ hide
+ openHaddocks = firstBoolFlagsFalse
+ "open"
+ "opening the local Haddock documentation in the browser"
+ hide
+ haddockDeps = firstBoolFlagsNoDefault
+ "haddock-deps"
+ "building Haddocks for dependencies (default: true if building Haddocks, \
+ \false otherwise)"
+ hide
+ haddockInternal = firstBoolFlagsFalse
+ "haddock-internal"
+ "building Haddocks for internal modules (like cabal haddock --internal)"
+ hide
+ haddockHyperlinkSource = firstBoolFlagsTrue
+ "haddock-hyperlink-source"
+ "building hyperlinked source for Haddock (like haddock \
+ \--hyperlinked-source)"
+ hide
+ copyBins = firstBoolFlagsFalse
+ "copy-bins"
+ "copying binaries to local-bin (see 'stack path')"
+ hide
+ copyCompilerTool = firstBoolFlagsFalse
+ "copy-compiler-tool"
+ "copying binaries of targets to compiler-tools-bin (see 'stack path')"
+ hide
+ keepGoing = firstBoolFlagsNoDefault
+ "keep-going"
+ "continue running after a step fails (default: false for build, true for \
+ \test/bench)"
+ hide
+ keepTmpFiles = firstBoolFlagsFalse
+ "keep-tmp-files"
+ "keep intermediate files and build directories"
+ hide
+ preFetch = firstBoolFlagsFalse
+ "prefetch"
+ "fetching packages necessary for the build immediately, useful with \
+ \--dry-run"
+ hide
+ forceDirty = firstBoolFlagsFalse
+ "force-dirty"
+ "forcing the treatment of all local packages as having dirty files, \
+ \useful for cases where Stack can't detect a file change"
+ hide
+ tests = firstBoolFlagsFalse
+ "test"
+ "testing the package(s) in this directory/configuration"
+ hideExceptGhci
+ benches = firstBoolFlagsFalse
+ "bench"
+ "benchmarking the package(s) in this directory/configuration"
+ hideExceptGhci
+ reconfigure = firstBoolFlagsFalse
+ "reconfigure"
+ "performing the configure step, even if unnecessary. Useful in some \
+ \corner cases with custom Setup.hs files"
+ hide
+ cabalVerbose = cabalVerbosityOptsParser hideBool
+ splitObjs = firstBoolFlagsFalse
+ "split-objs"
+ ( "split-objs, to reduce output size (at the cost of build time). "
+ ++ splitObjsWarning
+ )
+ hide
+ skipComponents = many (fmap T.pack (strOption
+ ( long "skip"
+ <> help "Skip given component (can be specified multiple times)"
+ <> hide
+ )))
+ interleavedOutput = firstBoolFlagsTrue
+ "interleaved-output"
+ "printing concurrent GHC output to the console with a prefix for the \
+ \package name"
+ hide
+ ddumpDir = optionalFirst (strOption
+ ( long "ddump-dir"
+ <> help "Specify output ddump-files"
+ <> hide
+ ))
-- | Parser for Cabal verbosity options
cabalVerbosityOptsParser :: Bool -> Parser (First CabalVerbosity)
@@ -190,10 +211,10 @@
cabalVerbosityParser :: Bool -> Parser (First CabalVerbosity)
cabalVerbosityParser hide =
let pCabalVerbosity = option (eitherReader eitherParsec)
- ( long "cabal-verbosity"
- <> metavar "VERBOSITY"
- <> help "Cabal verbosity (accepts Cabal's numerical and extended syntax)"
- <> hideMods hide)
+ ( long "cabal-verbosity"
+ <> metavar "VERBOSITY"
+ <> help "Cabal verbosity (accepts Cabal's numerical and extended syntax)"
+ <> hideMods hide)
in First . Just <$> pCabalVerbosity
-- | Parser for the Cabal verbose flag, retained for backward compatibility
@@ -201,6 +222,6 @@
cabalVerboseParser hide =
let pVerboseFlag = firstBoolFlagsFalse
"cabal-verbose"
- "Ask Cabal to be verbose in its output"
+ "asking Cabal to be verbose in its output"
(hideMods hide)
in toFirstCabalVerbosity <$> pVerboseFlag
diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs
--- a/src/Stack/Options/BuildParser.hs
+++ b/src/Stack/Options/BuildParser.hs
@@ -1,111 +1,122 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-module Stack.Options.BuildParser where
+module Stack.Options.BuildParser
+ ( buildOptsParser
+ , flagsParser
+ , targetsParser
+ ) where
import qualified Data.Map as Map
import Options.Applicative
import Options.Applicative.Args
import Options.Applicative.Builder.Extra
import Stack.Options.Completion
-import Stack.Options.PackageParser (readFlag)
+import Stack.Options.PackageParser ( readFlag )
import Stack.Prelude
import Stack.Types.Config
-- | Parser for CLI-only build arguments
buildOptsParser :: BuildCommand
-> Parser BuildOptsCLI
-buildOptsParser cmd =
- BuildOptsCLI <$>
- targetsParser <*>
- switch
- (long "dry-run" <>
- help "Don't build anything, just prepare to") <*>
- ((\x y z ->
- concat [x, y, z]) <$>
- flag
- []
- ["-Wall", "-Werror"]
- (long "pedantic" <>
- help "Turn on -Wall and -Werror") <*>
- flag
- []
- ["-O0"]
- (long "fast" <>
- help "Turn off optimizations (-O0)") <*>
- many
- (textOption
- (long "ghc-options" <>
- metavar "OPTIONS" <>
- completer ghcOptsCompleter <>
- help "Additional options passed to GHC"))) <*>
- flagsParser <*>
- (flag'
- BSOnlyDependencies
- (long "dependencies-only" <>
- help "A synonym for --only-dependencies") <|>
- flag'
- BSOnlySnapshot
- (long "only-snapshot" <>
- help
- "Only build packages for the snapshot database, not the local database") <|>
- flag'
- BSOnlyDependencies
- (long "only-dependencies" <>
- help
- "Only build packages that are dependencies of targets on the command line") <|>
- flag'
- BSOnlyLocals
- (long "only-locals" <>
- help
- "Only build packages in the local database, fail if the build plan includes the snapshot database") <|>
- pure BSAll) <*>
- (flag'
- FileWatch
- (long "file-watch" <>
- help
- "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file") <|>
- flag'
- FileWatchPoll
- (long "file-watch-poll" <>
- help
- "Like --file-watch, but polling the filesystem instead of using events") <|>
- pure NoFileWatch) <*>
- switch
- (long "watch-all" <>
- help "Watch all local files not taking targets into account") <*>
- many (cmdOption
- (long "exec" <>
- metavar "COMMAND [ARGUMENT(S)]" <>
- help "Command and argument(s) to run after a successful build")) <*>
- switch
- (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!") <*>
- pure cmd <*>
- switch
- (long "initial-build-steps" <>
- help "For target packages, only run initial build steps needed for GHCi" <>
- internal)
+buildOptsParser cmd = BuildOptsCLI
+ <$> targetsParser
+ <*> switch
+ ( long "dry-run"
+ <> help "Don't build anything, just prepare to"
+ )
+ <*> ( (\x y z -> concat [x, y, z])
+ <$> flag
+ []
+ ["-Wall", "-Werror"]
+ ( long "pedantic"
+ <> help "Turn on -Wall and -Werror"
+ )
+ <*> flag
+ []
+ ["-O0"]
+ ( long "fast"
+ <> help "Turn off optimizations (-O0)"
+ )
+ <*> many (textOption
+ ( long "ghc-options"
+ <> metavar "OPTIONS"
+ <> completer ghcOptsCompleter
+ <> help "Additional options passed to GHC"
+ ))
+ )
+ <*> flagsParser
+ <*> ( flag' BSOnlyDependencies
+ ( long "dependencies-only"
+ <> help "A synonym for --only-dependencies"
+ )
+ <|> flag' BSOnlySnapshot
+ ( long "only-snapshot"
+ <> help "Only build packages for the snapshot database, not the \
+ \local database"
+ )
+ <|> flag' BSOnlyDependencies
+ ( long "only-dependencies"
+ <> help "Only build packages that are dependencies of targets on \
+ \the command line"
+ )
+ <|> flag' BSOnlyLocals
+ ( long "only-locals"
+ <> help "Only build packages in the local database, fail if the \
+ \build plan includes the snapshot database"
+ )
+ <|> pure BSAll
+ )
+ <*> ( flag' FileWatch
+ ( long "file-watch"
+ <> help "Watch for changes in local files and automatically \
+ \rebuild. Ignores files in VCS boring/ignore file"
+ )
+ <|> flag' FileWatchPoll
+ ( long "file-watch-poll"
+ <> help "Like --file-watch, but polling the filesystem instead of \
+ \using events"
+ )
+ <|> pure NoFileWatch
+ )
+ <*> switch
+ ( long "watch-all"
+ <> help "Watch all local files not taking targets into account"
+ )
+ <*> many (cmdOption
+ ( long "exec"
+ <> metavar "COMMAND [ARGUMENT(S)]"
+ <> help "Command and argument(s) to run after a successful build"
+ ))
+ <*> switch
+ ( 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!"
+ )
+ <*> pure cmd
+ <*> switch
+ ( long "initial-build-steps"
+ <> help "For target packages, only run initial build steps needed for \
+ \GHCi"
+ <> internal
+ )
targetsParser :: Parser [Text]
targetsParser =
- many
- (textArgument
- (metavar "TARGET" <>
- completer targetCompleter <>
- help ("If none specified, use all local packages. " <>
- "See https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details.")))
+ many (textArgument
+ ( metavar "TARGET"
+ <> completer targetCompleter
+ <> help "If none specified, use all local packages. See \
+ \https://docs.haskellstack.org/en/stable/build_command/#target-syntax \
+ \for details."
+ ))
flagsParser :: Parser (Map.Map ApplyCLIFlag (Map.Map FlagName Bool))
-flagsParser =
- Map.unionsWith Map.union <$>
- many
- (option
- readFlag
- (long "flag" <>
- completer flagCompleter <>
- metavar "PACKAGE:[-]FLAG" <>
- help
- ("Override flags set in stack.yaml " <>
- "(applies to local packages and extra-deps)")))
+flagsParser = Map.unionsWith Map.union
+ <$> many (option readFlag
+ ( long "flag"
+ <> completer flagCompleter
+ <> metavar "PACKAGE:[-]FLAG"
+ <> help "Override flags set in stack.yaml (applies to local packages \
+ \and extra-deps)"
+ ))
diff --git a/src/Stack/Options/CleanParser.hs b/src/Stack/Options/CleanParser.hs
--- a/src/Stack/Options/CleanParser.hs
+++ b/src/Stack/Options/CleanParser.hs
@@ -1,25 +1,28 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.CleanParser where
+module Stack.Options.CleanParser
+ ( cleanOptsParser
+ ) where
-import Options.Applicative
-import Stack.Clean (CleanCommand(..), CleanOpts (..))
+import Options.Applicative ( Parser, flag', help, long, metavar )
+import Stack.Clean ( CleanCommand (..), CleanOpts (..) )
import Stack.Prelude
-import Stack.Types.PackageName
+import Stack.Types.PackageName ( packageNameArgument )
-- | Command-line parser for the clean command.
cleanOptsParser :: CleanCommand -> Parser CleanOpts
-cleanOptsParser Clean = CleanShallow <$> packages <|> doFullClean
- where
- packages =
- many
- (packageNameArgument
- (metavar "PACKAGE" <>
- help "If none specified, clean all project packages"))
- doFullClean =
- flag'
- CleanFull
- (long "full" <>
- help "Delete the project’s stack working directories (.stack-work by default).")
+cleanOptsParser Clean = CleanShallow
+ <$> packages
+ <|> doFullClean
+ where
+ packages = many (packageNameArgument
+ ( metavar "PACKAGE"
+ <> help "If none specified, clean all project packages"
+ ))
+ doFullClean = flag' CleanFull
+ ( long "full"
+ <> help "Delete the project's Stack working directories (.stack-work by \
+ \default)."
+ )
cleanOptsParser Purge = pure CleanFull
diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs
--- a/src/Stack/Options/Completion.hs
+++ b/src/Stack/Options/Completion.hs
@@ -9,8 +9,8 @@
, projectExeCompleter
) where
-import Data.Char (isSpace)
-import Data.List (isPrefixOf)
+import Data.Char ( isSpace )
+import Data.List ( isPrefixOf )
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
@@ -18,8 +18,8 @@
import qualified Distribution.PackageDescription as C
import Options.Applicative
import Options.Applicative.Builder.Extra
-import Stack.Constants (ghcShowOptionsOutput)
-import Stack.Options.GlobalParser (globalOptsFromMonoid)
+import Stack.Constants ( ghcShowOptionsOutput )
+import Stack.Options.GlobalParser ( globalOptsFromMonoid )
import Stack.Runners
import Stack.Prelude
import Stack.Types.Config
@@ -27,7 +27,7 @@
import Stack.Types.SourceMap
ghcOptsCompleter :: Completer
-ghcOptsCompleter = mkCompleter $ \inputRaw -> return $
+ghcOptsCompleter = mkCompleter $ \inputRaw -> pure $
let input = unescapeBashArg inputRaw
(curArgReversed, otherArgsReversed) = break isSpace (reverse input)
curArg = reverse curArgReversed
@@ -46,7 +46,7 @@
let input = unescapeBashArg inputRaw
case input of
-- If it looks like a flag, skip this more costly completion.
- ('-': _) -> return []
+ ('-': _) -> pure []
_ -> do
go' <- globalOptsFromMonoid False mempty
let go = go' { globalLogLevel = LevelOther "silent" }
@@ -90,7 +90,7 @@
fromMaybe (C.flagDefault fl) $
Map.lookup (C.flagName fl) $
Map.findWithDefault Map.empty name prjFlags
- return $ filter (input `isPrefixOf`) $
+ pure $ filter (input `isPrefixOf`) $
case input of
('*' : ':' : _) -> wildcardFlags
('*' : _) -> wildcardFlags
diff --git a/src/Stack/Options/ConfigParser.hs b/src/Stack/Options/ConfigParser.hs
--- a/src/Stack/Options/ConfigParser.hs
+++ b/src/Stack/Options/ConfigParser.hs
@@ -1,190 +1,211 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.ConfigParser where
+module Stack.Options.ConfigParser
+ ( configOptsParser
+ ) where
-import Data.Char
+import Data.Char ( toUpper )
import Options.Applicative
+ ( Parser, auto, completer, completeWith, eitherReader, help
+ , long, metavar, option, short, strOption
+ )
import Options.Applicative.Builder.Extra
-import Path
-import Stack.Constants
-import Stack.Options.BuildMonoidParser
-import Stack.Options.DockerParser
-import Stack.Options.GhcBuildParser
-import Stack.Options.GhcVariantParser
-import Stack.Options.NixParser
-import Stack.Options.Utils
+ ( PathCompleterOpts (..), absDirOption, absFileOption
+ , defaultPathCompleterOpts, dirCompleter, firstBoolFlagsFalse
+ , firstBoolFlagsNoDefault, firstBoolFlagsTrue, optionalFirst
+ , pathCompleterWith
+ )
+import Path ( parseRelDir )
+import Stack.Constants ( stackRootOptionName )
+import Stack.Options.BuildMonoidParser ( buildOptsMonoidParser )
+import Stack.Options.DockerParser ( dockerOptsParser )
+import Stack.Options.GhcBuildParser ( ghcBuildParser )
+import Stack.Options.GhcVariantParser ( ghcVariantParser )
+import Stack.Options.NixParser ( nixOptsParser )
+import Stack.Options.Utils ( GlobalOptsContext (..), hideMods )
import Stack.Prelude
import Stack.Types.Config
+ ( ConfigMonoid (..), DumpLogs (..), readColorWhen )
import qualified System.FilePath as FilePath
-- | Command-line arguments parser for configuration.
configOptsParser :: FilePath -> GlobalOptsContext -> Parser ConfigMonoid
configOptsParser currentDir hide0 =
- (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch
- ghcVariant ghcBuild jobs includes libs preprocs overrideGccPath overrideHpack
- skipGHCCheck skipMsys localBin setupInfoLocations modifyCodePage
- allowDifferentUser dumpLogs colorWhen snapLoc noRunCompile -> mempty
- { configMonoidStackRoot = stackRoot
- , configMonoidWorkDir = workDir
- , configMonoidBuildOpts = buildOpts
- , configMonoidDockerOpts = dockerOpts
- , configMonoidNixOpts = nixOpts
- , configMonoidSystemGHC = systemGHC
- , configMonoidInstallGHC = installGHC
- , configMonoidSkipGHCCheck = skipGHCCheck
- , configMonoidArch = arch
- , configMonoidGHCVariant = ghcVariant
- , configMonoidGHCBuild = ghcBuild
- , configMonoidJobs = jobs
- , configMonoidExtraIncludeDirs = includes
- , configMonoidExtraLibDirs = libs
- , configMonoidCustomPreprocessorExts = preprocs
- , configMonoidOverrideGccPath = overrideGccPath
- , configMonoidOverrideHpack = overrideHpack
- , configMonoidSkipMsys = skipMsys
- , configMonoidLocalBinPath = localBin
- , configMonoidSetupInfoLocations = setupInfoLocations
- , configMonoidModifyCodePage = modifyCodePage
- , configMonoidAllowDifferentUser = allowDifferentUser
- , configMonoidDumpLogs = dumpLogs
- , configMonoidColorWhen = colorWhen
- , configMonoidSnapshotLocation = snapLoc
- , configMonoidNoRunCompile = noRunCompile
- })
- <$> optionalFirst (absDirOption
- ( long stackRootOptionName
- <> metavar (map toUpper stackRootOptionName)
- <> help ("Absolute path to the global stack root directory " ++
- "(Overrides any STACK_ROOT environment variable)")
- <> hide
- ))
- <*> optionalFirst (option (eitherReader (mapLeft showWorkDirError . parseRelDir))
- ( long "work-dir"
- <> metavar "WORK-DIR"
- <> completer (pathCompleterWith (defaultPathCompleterOpts { pcoAbsolute = False, pcoFileFilter = const False }))
- <> help ("Relative path of work directory " ++
- "(Overrides any STACK_WORK environment variable, default is '.stack-work')")
- <> hide
- ))
- <*> buildOptsMonoidParser hide0
- <*> dockerOptsParser True
- <*> nixOptsParser True
- <*> firstBoolFlagsNoDefault
- "system-ghc"
- "using the system installed GHC (on the PATH) if it is available and its version matches. Disabled by default."
- hide
- <*> firstBoolFlagsTrue
- "install-ghc"
- "downloading and installing GHC if necessary (can be done manually with stack setup)"
- hide
- <*> optionalFirst (strOption
- ( long "arch"
- <> metavar "ARCH"
- <> help "System architecture, e.g. i386, x86_64"
- <> hide
- ))
- <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts))
- <*> optionalFirst (ghcBuildParser (hide0 /= OuterGlobalOpts))
- <*> optionalFirst (option auto
- ( long "jobs"
- <> short 'j'
- <> metavar "JOBS"
- <> help "Number of concurrent jobs to run"
- <> hide
- ))
- <*> many ((currentDir FilePath.) <$> strOption
- ( long "extra-include-dirs"
- <> metavar "DIR"
- <> completer dirCompleter
- <> help "Extra directories to check for C header files"
- <> hide
- ))
- <*> many ((currentDir FilePath.) <$> strOption
- ( long "extra-lib-dirs"
- <> metavar "DIR"
- <> completer dirCompleter
- <> help "Extra directories to check for libraries"
- <> hide
- ))
- <*> many (strOption
- ( long "custom-preprocessor-extensions"
- <> metavar "EXT"
- <> help "Extensions used for custom preprocessors"
- <> hide
- ))
- <*> optionalFirst (absFileOption
- ( long "with-gcc"
- <> metavar "PATH-TO-GCC"
- <> help "Use gcc found at PATH-TO-GCC"
- <> hide
- ))
- <*> optionalFirst (strOption
- ( long "with-hpack"
- <> metavar "HPACK"
- <> help "Use HPACK executable (overrides bundled Hpack)"
- <> hide
- ))
- <*> firstBoolFlagsFalse
- "skip-ghc-check"
- "skipping the GHC version and architecture check"
- hide
- <*> firstBoolFlagsFalse
- "skip-msys"
- "skipping the local MSYS installation (Windows only)"
- hide
- <*> optionalFirst ((currentDir FilePath.) <$> strOption
- ( long "local-bin-path"
- <> metavar "DIR"
- <> completer dirCompleter
- <> help "Install binaries to DIR"
- <> hide
- ))
- <*> many (
- strOption
- ( long "setup-info-yaml"
- <> help "Alternate URL or relative / absolute path for stack dependencies"
- <> metavar "URL" ))
- <*> firstBoolFlagsTrue
- "modify-code-page"
- "setting the codepage to support UTF-8 (Windows only)"
- hide
- <*> firstBoolFlagsNoDefault
- "allow-different-user"
- ("permission for users other than the owner of the stack root " ++
- "directory to use a stack installation (POSIX only) " ++
- "(default: true inside Docker, otherwise false)")
- hide
- <*> fmap toDumpLogs
- (firstBoolFlagsNoDefault
- "dump-logs"
- "dump the build output logs for local packages to the console (default: dump warning logs)"
- hide)
- <*> optionalFirst (option readColorWhen
- ( long "color"
- <> long "colour"
- <> metavar "WHEN"
- <> completeWith ["always", "never", "auto"]
- <> help "Specify when to use color in output; WHEN is 'always', \
- \'never', or 'auto'. On Windows versions before Windows \
- \10, for terminals that do not support color codes, the \
- \default is 'never'; color may work on terminals that \
- \support color codes"
- <> hide
- ))
- <*> optionalFirst (strOption
- ( long "snapshot-location-base"
- <> help "The base location of LTS/Nightly snapshots"
- <> metavar "URL"
- ))
- <*> firstBoolFlagsFalse
- "script-no-run-compile"
- "the use of options `--no-run --compile` with `stack script`"
- hide
- where
- hide = hideMods (hide0 /= OuterGlobalOpts)
- toDumpLogs (First (Just True)) = First (Just DumpAllLogs)
- toDumpLogs (First (Just False)) = First (Just DumpNoLogs)
- toDumpLogs (First Nothing) = First Nothing
- showWorkDirError err = show err ++
- "\nNote that --work-dir must be a relative child directory, because work-dirs outside of the package are not supported by Cabal." ++
- "\nSee https://github.com/commercialhaskell/stack/issues/2954"
+ ( \stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch
+ ghcVariant ghcBuild jobs includes libs preprocs overrideGccPath overrideHpack
+ skipGHCCheck skipMsys localBin setupInfoLocations modifyCodePage
+ allowDifferentUser dumpLogs colorWhen snapLoc noRunCompile -> mempty
+ { configMonoidStackRoot = stackRoot
+ , configMonoidWorkDir = workDir
+ , configMonoidBuildOpts = buildOpts
+ , configMonoidDockerOpts = dockerOpts
+ , configMonoidNixOpts = nixOpts
+ , configMonoidSystemGHC = systemGHC
+ , configMonoidInstallGHC = installGHC
+ , configMonoidSkipGHCCheck = skipGHCCheck
+ , configMonoidArch = arch
+ , configMonoidGHCVariant = ghcVariant
+ , configMonoidGHCBuild = ghcBuild
+ , configMonoidJobs = jobs
+ , configMonoidExtraIncludeDirs = includes
+ , configMonoidExtraLibDirs = libs
+ , configMonoidCustomPreprocessorExts = preprocs
+ , configMonoidOverrideGccPath = overrideGccPath
+ , configMonoidOverrideHpack = overrideHpack
+ , configMonoidSkipMsys = skipMsys
+ , configMonoidLocalBinPath = localBin
+ , configMonoidSetupInfoLocations = setupInfoLocations
+ , configMonoidModifyCodePage = modifyCodePage
+ , configMonoidAllowDifferentUser = allowDifferentUser
+ , configMonoidDumpLogs = dumpLogs
+ , configMonoidColorWhen = colorWhen
+ , configMonoidSnapshotLocation = snapLoc
+ , configMonoidNoRunCompile = noRunCompile
+ }
+ )
+ <$> optionalFirst (absDirOption
+ ( long stackRootOptionName
+ <> metavar (map toUpper stackRootOptionName)
+ <> help "Absolute path to the global Stack root directory (Overrides \
+ \any STACK_ROOT environment variable)"
+ <> hide
+ ))
+ <*> optionalFirst (option (eitherReader (mapLeft showWorkDirError . parseRelDir))
+ ( long "work-dir"
+ <> metavar "WORK-DIR"
+ <> completer
+ ( pathCompleterWith
+ ( defaultPathCompleterOpts
+ { pcoAbsolute = False, pcoFileFilter = const False }
+ )
+ )
+ <> help "Relative path of work directory (Overrides any STACK_WORK \
+ \environment variable, default is '.stack-work')"
+ <> hide
+ ))
+ <*> buildOptsMonoidParser hide0
+ <*> dockerOptsParser True
+ <*> nixOptsParser True
+ <*> firstBoolFlagsNoDefault
+ "system-ghc"
+ "using the system installed GHC (on the PATH) if it is available and \
+ \its version matches. Disabled by default."
+ hide
+ <*> firstBoolFlagsTrue
+ "install-ghc"
+ "downloading and installing GHC if necessary (can be done manually \
+ \with 'stack setup')"
+ hide
+ <*> optionalFirst (strOption
+ ( long "arch"
+ <> metavar "ARCH"
+ <> help "System architecture, e.g. i386, x86_64"
+ <> hide
+ ))
+ <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts))
+ <*> optionalFirst (ghcBuildParser (hide0 /= OuterGlobalOpts))
+ <*> optionalFirst (option auto
+ ( long "jobs"
+ <> short 'j'
+ <> metavar "JOBS"
+ <> help "Number of concurrent jobs to run"
+ <> hide
+ ))
+ <*> many ((currentDir FilePath.) <$> strOption
+ ( long "extra-include-dirs"
+ <> metavar "DIR"
+ <> completer dirCompleter
+ <> help "Extra directories to check for C header files"
+ <> hide
+ ))
+ <*> many ((currentDir FilePath.) <$> strOption
+ ( long "extra-lib-dirs"
+ <> metavar "DIR"
+ <> completer dirCompleter
+ <> help "Extra directories to check for libraries"
+ <> hide
+ ))
+ <*> many (strOption
+ ( long "custom-preprocessor-extensions"
+ <> metavar "EXT"
+ <> help "Extensions used for custom preprocessors"
+ <> hide
+ ))
+ <*> optionalFirst (absFileOption
+ ( long "with-gcc"
+ <> metavar "PATH-TO-GCC"
+ <> help "Use gcc found at PATH-TO-GCC"
+ <> hide
+ ))
+ <*> optionalFirst (strOption
+ ( long "with-hpack"
+ <> metavar "HPACK"
+ <> help "Use HPACK executable (overrides bundled Hpack)"
+ <> hide
+ ))
+ <*> firstBoolFlagsFalse
+ "skip-ghc-check"
+ "skipping the GHC version and architecture check"
+ hide
+ <*> firstBoolFlagsFalse
+ "skip-msys"
+ "skipping the local MSYS installation (Windows only)"
+ hide
+ <*> optionalFirst ((currentDir FilePath.) <$> strOption
+ ( long "local-bin-path"
+ <> metavar "DIR"
+ <> completer dirCompleter
+ <> help "Install binaries to DIR"
+ <> hide
+ ))
+ <*> many (strOption
+ ( long "setup-info-yaml"
+ <> help "Alternate URL or relative / absolute path for Stack \
+ \dependencies"
+ <> metavar "URL"
+ ))
+ <*> firstBoolFlagsTrue
+ "modify-code-page"
+ "setting the codepage to support UTF-8 (Windows only)"
+ hide
+ <*> firstBoolFlagsNoDefault
+ "allow-different-user"
+ "permission for users other than the owner of the Stack root directory \
+ \to use a Stack installation (POSIX only) (default: true inside \
+ \Docker, otherwise false)"
+ hide
+ <*> fmap toDumpLogs (firstBoolFlagsNoDefault
+ "dump-logs"
+ "dump the build output logs for local packages to the console \
+ \(default: dump warning logs)"
+ hide)
+ <*> optionalFirst (option readColorWhen
+ ( long "color"
+ <> long "colour"
+ <> metavar "WHEN"
+ <> completeWith ["always", "never", "auto"]
+ <> help "Specify when to use color in output; WHEN is 'always', \
+ \'never', or 'auto'. On Windows versions before Windows \
+ \10, for terminals that do not support color codes, the \
+ \default is 'never'; color may work on terminals that \
+ \support color codes"
+ <> hide
+ ))
+ <*> optionalFirst (strOption
+ ( long "snapshot-location-base"
+ <> help "The base location of LTS/Nightly snapshots"
+ <> metavar "URL"
+ ))
+ <*> firstBoolFlagsFalse
+ "script-no-run-compile"
+ "the use of options `--no-run --compile` with `stack script`"
+ hide
+ where
+ hide = hideMods (hide0 /= OuterGlobalOpts)
+ toDumpLogs (First (Just True)) = First (Just DumpAllLogs)
+ toDumpLogs (First (Just False)) = First (Just DumpNoLogs)
+ toDumpLogs (First Nothing) = First Nothing
+ showWorkDirError err = show err ++
+ "\nNote that --work-dir must be a relative child directory, because \
+ \work-dirs outside of the package are not supported by Cabal." ++
+ "\nSee https://github.com/commercialhaskell/stack/issues/2954"
diff --git a/src/Stack/Options/DockerParser.hs b/src/Stack/Options/DockerParser.hs
--- a/src/Stack/Options/DockerParser.hs
+++ b/src/Stack/Options/DockerParser.hs
@@ -1,108 +1,151 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.DockerParser where
+module Stack.Options.DockerParser
+ ( dockerOptsParser
+ ) where
-import Data.List (intercalate)
-import qualified Data.Text as T
-import Distribution.Version (anyVersion)
+import Data.List ( intercalate )
+import qualified Data.Text as T
+import Distribution.Version ( anyVersion )
import Options.Applicative
-import Options.Applicative.Args
+ ( Parser, auto, completer, help, listCompleter, long, metavar
+ , option, str, value
+ )
+import Options.Applicative.Args ( argsOption )
import Options.Applicative.Builder.Extra
-import Stack.Docker
+ ( dirCompleter, eitherReader', fileCompleter
+ , firstBoolFlagsFalse, firstBoolFlagsNoDefault
+ , firstBoolFlagsTrue, optionalFirst
+ )
+import Stack.Docker ( dockerCmdName )
import Stack.Prelude
-import Stack.Options.Utils
-import Stack.Types.Version
+import Stack.Options.Utils ( hideMods )
+import Stack.Types.Version ( IntersectingVersionRange (..) )
import Stack.Types.Docker
+ ( DockerMonoidRepoOrImage (..), DockerOptsMonoid (..)
+ , dockerAutoPullArgName, dockerImageArgName
+ , dockerContainerNameArgName, dockerDetachArgName
+ , dockerEnvArgName, dockerPersistArgName
+ , dockerRegistryLoginArgName, dockerRegistryPasswordArgName
+ , dockerRegistryUsernameArgName, dockerRepoArgName
+ , dockerRunArgsArgName, dockerMountArgName
+ , dockerMountModeArgName, dockerNetworkArgName
+ , dockerSetUserArgName, dockerStackExeArgName
+ , dockerStackExeDownloadVal, dockerStackExeHostVal
+ , dockerStackExeImageVal, parseDockerStackExe
+ )
-- | Options parser configuration for Docker.
dockerOptsParser :: Bool -> Parser DockerOptsMonoid
-dockerOptsParser hide0 =
- DockerOptsMonoid (Any False)
- <$> firstBoolFlagsNoDefault
- dockerCmdName
- "using a Docker container. --docker implies 'system-ghc: true'"
- hide
- <*> fmap First
- (Just . DockerMonoidRepo <$> option str (long (dockerOptName dockerRepoArgName) <>
- hide <>
- metavar "NAME" <>
- help "Docker repository name") <|>
- Just . DockerMonoidImage <$> option str (long (dockerOptName dockerImageArgName) <>
- hide <>
- metavar "IMAGE" <>
- help "Exact Docker image ID (overrides docker-repo)") <|>
- pure Nothing)
- <*> firstBoolFlagsNoDefault
- (dockerOptName dockerRegistryLoginArgName)
- "registry requires login"
- hide
- <*> firstStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>
- hide <>
- metavar "USERNAME" <>
- help "Docker registry username")
- <*> firstStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>
- hide <>
- metavar "PASSWORD" <>
- help "Docker registry password")
- <*> firstBoolFlagsTrue
- (dockerOptName dockerAutoPullArgName)
- "automatic pulling latest version of image"
- hide
- <*> firstBoolFlagsFalse
- (dockerOptName dockerDetachArgName)
- "running a detached Docker container"
- hide
- <*> firstBoolFlagsFalse
- (dockerOptName dockerPersistArgName)
- "not deleting container after it exits"
- hide
- <*> firstStrOption (long (dockerOptName dockerContainerNameArgName) <>
- hide <>
- metavar "NAME" <>
- help "Docker container name")
- <*> firstStrOption (long (dockerOptName dockerNetworkArgName) <>
- hide <>
- metavar "NETWORK" <>
- help "Docker network")
- <*> argsOption (long (dockerOptName dockerRunArgsArgName) <>
- hide <>
- value [] <>
- metavar "'ARG1 [ARG2 ...]'" <>
- help "Additional options to pass to 'docker run'")
- <*> many (option auto (long (dockerOptName dockerMountArgName) <>
- hide <>
- metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>
- completer dirCompleter <>
- help ("Mount volumes from host in container " ++
- "(can be specified multiple times)")))
- <*> firstStrOption (long (dockerOptName dockerMountModeArgName) <>
- hide <>
- metavar "SUFFIX" <>
- help "Volume mount mode suffix")
- <*> many (option str (long (dockerOptName dockerEnvArgName) <>
- hide <>
- metavar "NAME=VALUE" <>
- help ("Set environment variable in container " ++
- "(can be specified multiple times)")))
- <*> optionalFirst (option (eitherReader' parseDockerStackExe)
- (let specialOpts =
- [ dockerStackExeDownloadVal
- , dockerStackExeHostVal
- , dockerStackExeImageVal
- ] in
- long(dockerOptName dockerStackExeArgName) <>
- hide <>
- metavar (intercalate "|" (specialOpts ++ ["PATH"])) <>
- completer (listCompleter specialOpts <> fileCompleter) <>
- help (concat [ "Location of "
+dockerOptsParser hide0 = DockerOptsMonoid (Any False)
+ <$> firstBoolFlagsNoDefault
+ dockerCmdName
+ "using a Docker container. --docker implies 'system-ghc: true'"
+ hide
+ <*> fmap First
+ ( Just . DockerMonoidRepo <$> option str
+ ( long (dockerOptName dockerRepoArgName)
+ <> hide
+ <> metavar "NAME"
+ <> help "Docker repository name"
+ )
+ <|> Just . DockerMonoidImage <$> option str
+ ( long (dockerOptName dockerImageArgName)
+ <> hide
+ <> metavar "IMAGE"
+ <> help "Exact Docker image ID (overrides docker-repo)"
+ )
+ <|> pure Nothing
+ )
+ <*> firstBoolFlagsNoDefault
+ (dockerOptName dockerRegistryLoginArgName)
+ "registry requires login"
+ hide
+ <*> firstStrOption
+ ( long (dockerOptName dockerRegistryUsernameArgName)
+ <> hide
+ <> metavar "USERNAME"
+ <> help "Docker registry username"
+ )
+ <*> firstStrOption
+ ( long (dockerOptName dockerRegistryPasswordArgName)
+ <> hide
+ <> metavar "PASSWORD"
+ <> help "Docker registry password"
+ )
+ <*> firstBoolFlagsTrue
+ (dockerOptName dockerAutoPullArgName)
+ "automatic pulling latest version of image"
+ hide
+ <*> firstBoolFlagsFalse
+ (dockerOptName dockerDetachArgName)
+ "running a detached Docker container"
+ hide
+ <*> firstBoolFlagsFalse
+ (dockerOptName dockerPersistArgName)
+ "not deleting container after it exits"
+ hide
+ <*> firstStrOption
+ ( long (dockerOptName dockerContainerNameArgName)
+ <> hide
+ <> metavar "NAME"
+ <> help "Docker container name"
+ )
+ <*> firstStrOption
+ ( long (dockerOptName dockerNetworkArgName)
+ <> hide
+ <> metavar "NETWORK"
+ <> help "Docker network"
+ )
+ <*> argsOption
+ ( long (dockerOptName dockerRunArgsArgName)
+ <> hide
+ <> value []
+ <> metavar "'ARG1 [ARG2 ...]'"
+ <> help "Additional options to pass to 'docker run'")
+ <*> many (option auto
+ ( long (dockerOptName dockerMountArgName)
+ <> hide
+ <> metavar "(PATH | HOST-PATH:CONTAINER-PATH)"
+ <> completer dirCompleter
+ <> help "Mount volumes from host in container (can be specified \
+ \multiple times)"
+ ))
+ <*> firstStrOption
+ ( long (dockerOptName dockerMountModeArgName)
+ <> hide
+ <> metavar "SUFFIX"
+ <> help "Volume mount mode suffix"
+ )
+ <*> many (option str
+ ( long (dockerOptName dockerEnvArgName)
+ <> hide
+ <> metavar "NAME=VALUE"
+ <> help "Set environment variable in container (can be specified \
+ \multiple times)"
+ ))
+ <*> optionalFirst (option (eitherReader' parseDockerStackExe)
+ ( let specialOpts = [ dockerStackExeDownloadVal
+ , dockerStackExeHostVal
+ , dockerStackExeImageVal
+ ]
+ in long (dockerOptName dockerStackExeArgName)
+ <> hide
+ <> metavar (intercalate "|" (specialOpts ++ ["PATH"]))
+ <> completer (listCompleter specialOpts <> fileCompleter)
+ <> help ( concat
+ [ "Location of "
, stackProgName
- , " executable used in container" ])))
- <*> firstBoolFlagsNoDefault
- (dockerOptName dockerSetUserArgName)
- "setting user in container to match host"
- hide
- <*> pure (IntersectingVersionRange anyVersion)
- where
- dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName
- firstStrOption = optionalFirst . option str
- hide = hideMods hide0
+ , " executable used in container"
+ ]
+ )
+ ))
+ <*> firstBoolFlagsNoDefault
+ (dockerOptName dockerSetUserArgName)
+ "setting user in container to match host"
+ hide
+ <*> pure (IntersectingVersionRange anyVersion)
+ where
+ dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName
+ firstStrOption = optionalFirst . option str
+ hide = hideMods hide0
diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs
--- a/src/Stack/Options/DotParser.hs
+++ b/src/Stack/Options/DotParser.hs
@@ -1,81 +1,117 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-module Stack.Options.DotParser where
+module Stack.Options.DotParser
+ ( dotOptsParser
+ , formatSubCommand
+ , licenseParser
+ , listDepsConstraintsParser
+ , listDepsFormatOptsParser
+ , listDepsJsonParser
+ , listDepsOptsParser
+ , listDepsTextParser
+ , listDepsTreeParser
+ , separatorParser
+ , toListDepsOptsParser
+ ) where
-import Data.Char (isSpace)
-import Data.List.Split (splitOn)
+import Data.Char ( isSpace )
+import Data.List.Split ( splitOn )
import qualified Data.Set as Set
import qualified Data.Text as T
-import Distribution.Types.PackageName(mkPackageName)
+import Distribution.Types.PackageName ( mkPackageName )
import Options.Applicative
-import Options.Applicative.Builder.Extra
+ ( CommandFields, Mod, Parser, auto, command, help, idm, info
+ , long, metavar, option, progDesc, showDefault, strOption
+ , subparser, switch, value
+ )
+import Options.Applicative.Builder.Extra ( boolFlags, textOption )
import Stack.Dot
-import Stack.Options.BuildParser
+ ( DotOpts (..), ListDepsFormat (..), ListDepsFormatOpts (..)
+ , ListDepsOpts (..)
+ )
+import Stack.Options.BuildParser ( flagsParser, targetsParser )
import Stack.Prelude
-- | Parser for arguments to `stack dot`
dotOptsParser :: Bool -> Parser DotOpts
-dotOptsParser externalDefault =
- DotOpts <$> includeExternal
- <*> includeBase
- <*> depthLimit
- <*> fmap (maybe Set.empty $ Set.fromList . splitNames) prunedPkgs
- <*> targetsParser
- <*> flagsParser
- <*> testTargets
- <*> benchTargets
- <*> globalHints
- where includeExternal = boolFlags externalDefault
- "external"
- "inclusion of external dependencies"
- idm
- includeBase = boolFlags True
- "include-base"
- "inclusion of dependencies on base"
- idm
- depthLimit =
- optional (option auto
- (long "depth" <>
- metavar "DEPTH" <>
- help ("Limit the depth of dependency resolution " <>
- "(Default: No limit)")))
- prunedPkgs = optional (strOption
- (long "prune" <>
- metavar "PACKAGES" <>
- help ("Prune each package name " <>
- "from the comma separated list " <>
- "of package names PACKAGES")))
- testTargets = switch (long "test" <>
- help "Consider dependencies of test components")
- benchTargets = switch (long "bench" <>
- help "Consider dependencies of benchmark components")
+dotOptsParser externalDefault = DotOpts
+ <$> includeExternal
+ <*> includeBase
+ <*> depthLimit
+ <*> fmap (maybe Set.empty $ Set.fromList . splitNames) prunedPkgs
+ <*> targetsParser
+ <*> flagsParser
+ <*> testTargets
+ <*> benchTargets
+ <*> globalHints
+ where
+ includeExternal = boolFlags externalDefault
+ "external"
+ "inclusion of external dependencies"
+ idm
+ includeBase = boolFlags True
+ "include-base"
+ "inclusion of dependencies on base"
+ idm
+ depthLimit = optional (option auto
+ ( long "depth"
+ <> metavar "DEPTH"
+ <> help "Limit the depth of dependency resolution (Default: No limit)"
+ ))
+ prunedPkgs = optional (strOption
+ ( long "prune"
+ <> metavar "PACKAGES"
+ <> help "Prune each package name from the comma separated list of package \
+ \names PACKAGES"
+ ))
+ testTargets = switch
+ ( long "test"
+ <> help "Consider dependencies of test components"
+ )
+ benchTargets = switch
+ ( long "bench"
+ <> help "Consider dependencies of benchmark components"
+ )
- splitNames :: String -> [PackageName]
- splitNames = map (mkPackageName . takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","
+ splitNames :: String -> [PackageName]
+ splitNames = map
+ ( mkPackageName
+ . takeWhile (not . isSpace)
+ . dropWhile isSpace
+ )
+ . splitOn ","
- globalHints = switch (long "global-hints" <>
- help "Do not require an install GHC; instead, use a hints file for global packages")
+ globalHints = switch
+ ( long "global-hints"
+ <> help "Do not require an install GHC; instead, use a hints file for \
+ \global packages"
+ )
separatorParser :: Parser Text
-separatorParser =
- fmap escapeSep
- (textOption (long "separator" <>
- metavar "SEP" <>
- help ("Separator between package name " <>
- "and package version.") <>
- value " " <>
- showDefault))
- where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)
+separatorParser = fmap
+ escapeSep
+ ( textOption
+ ( long "separator"
+ <> metavar "SEP"
+ <> help "Separator between package name and package version."
+ <> value " "
+ <> showDefault
+ )
+ )
+ where
+ escapeSep s = T.replace "\\t" "\t" (T.replace "\\n" "\n" s)
licenseParser :: Parser Bool
licenseParser = boolFlags False
- "license"
- "printing of dependency licenses instead of versions"
- idm
+ "license"
+ "printing of dependency licenses instead of versions"
+ idm
listDepsFormatOptsParser :: Parser ListDepsFormatOpts
-listDepsFormatOptsParser = ListDepsFormatOpts <$> separatorParser <*> licenseParser
+listDepsFormatOptsParser = ListDepsFormatOpts
+ <$> separatorParser
+ <*> licenseParser
listDepsTreeParser :: Parser ListDepsFormat
listDepsTreeParser = ListDepsTree <$> listDepsFormatOptsParser
@@ -86,20 +122,40 @@
listDepsJsonParser :: Parser ListDepsFormat
listDepsJsonParser = pure ListDepsJSON
+listDepsConstraintsParser :: Parser ListDepsFormat
+listDepsConstraintsParser = pure ListDepsConstraints
+
toListDepsOptsParser :: Parser ListDepsFormat -> Parser ListDepsOpts
toListDepsOptsParser formatParser = ListDepsOpts
- <$> formatParser
- <*> dotOptsParser True
+ <$> formatParser
+ <*> dotOptsParser True
-formatSubCommand :: String -> String -> Parser ListDepsFormat -> Mod CommandFields ListDepsOpts
+formatSubCommand ::
+ String
+ -> String
+ -> Parser ListDepsFormat
+ -> Mod CommandFields ListDepsOpts
formatSubCommand cmd desc formatParser =
- command cmd (info (toListDepsOptsParser formatParser)
- (progDesc desc))
+ command cmd (info (toListDepsOptsParser formatParser) (progDesc desc))
-- | Parser for arguments to `stack ls dependencies`.
listDepsOptsParser :: Parser ListDepsOpts
listDepsOptsParser = subparser
- ( formatSubCommand "text" "Print dependencies as text (default)" listDepsTextParser
- <> formatSubCommand "tree" "Print dependencies as tree" listDepsTreeParser
- <> formatSubCommand "json" "Print dependencies as JSON" listDepsJsonParser
- ) <|> toListDepsOptsParser listDepsTextParser
+ ( formatSubCommand
+ "text"
+ "Print dependencies as text (default)"
+ listDepsTextParser
+ <> formatSubCommand
+ "cabal"
+ "Print dependencies as exact Cabal constraints"
+ listDepsConstraintsParser
+ <> formatSubCommand
+ "tree"
+ "Print dependencies as tree"
+ listDepsTreeParser
+ <> formatSubCommand
+ "json"
+ "Print dependencies as JSON"
+ listDepsJsonParser
+ )
+ <|> toListDepsOptsParser listDepsTextParser
diff --git a/src/Stack/Options/ExecParser.hs b/src/Stack/Options/ExecParser.hs
--- a/src/Stack/Options/ExecParser.hs
+++ b/src/Stack/Options/ExecParser.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.ExecParser where
+module Stack.Options.ExecParser
+ ( evalOptsParser
+ , execOptsExtraParser
+ , execOptsParser
+ ) where
import Options.Applicative
import Options.Applicative.Builder.Extra
@@ -11,70 +15,75 @@
-- | Parser for exec command
execOptsParser :: Maybe SpecialExecCmd -> Parser ExecOpts
-execOptsParser mcmd =
- ExecOpts
- <$> maybe eoCmdParser pure mcmd
- <*> eoArgsParser
- <*> execOptsExtraParser
- where
- eoCmdParser = ExecCmd <$> strArgument (metavar "COMMAND" <> completer projectExeCompleter)
- eoArgsParser = many (strArgument (metavar txt))
- where
- txt = case mcmd of
- Nothing -> normalTxt
- Just ExecCmd{} -> normalTxt
- Just ExecRun -> "-- ARGUMENT(S) (e.g. stack run -- file.txt)"
- Just ExecGhc -> "-- ARGUMENT(S) (e.g. stack runghc -- X.hs -o x)"
- Just ExecRunGhc -> "-- ARGUMENT(S) (e.g. stack runghc -- X.hs)"
- normalTxt = "-- ARGUMENT(S) (e.g. stack exec ghc-pkg -- describe base)"
+execOptsParser mcmd = ExecOpts
+ <$> maybe eoCmdParser pure mcmd
+ <*> eoArgsParser
+ <*> execOptsExtraParser
+ where
+ eoCmdParser = ExecCmd
+ <$> strArgument
+ ( metavar "COMMAND"
+ <> completer projectExeCompleter
+ )
+ eoArgsParser = many (strArgument (metavar txt))
+ where
+ txt = case mcmd of
+ Nothing -> normalTxt
+ Just ExecCmd{} -> normalTxt
+ Just ExecRun -> "-- ARGUMENT(S) (e.g. stack run -- file.txt)"
+ Just ExecGhc -> "-- ARGUMENT(S) (e.g. stack ghc -- X.hs -o x)"
+ Just ExecRunGhc -> "-- ARGUMENT(S) (e.g. stack runghc -- X.hs)"
+ normalTxt = "-- ARGUMENT(S) (e.g. stack exec ghc-pkg -- describe base)"
evalOptsParser :: String -- ^ metavar
-> Parser EvalOpts
-evalOptsParser meta =
- EvalOpts
- <$> eoArgsParser
- <*> execOptsExtraParser
- where
- eoArgsParser :: Parser String
- eoArgsParser = strArgument (metavar meta)
+evalOptsParser meta = EvalOpts
+ <$> eoArgsParser
+ <*> execOptsExtraParser
+ where
+ eoArgsParser :: Parser String
+ eoArgsParser = strArgument (metavar meta)
-- | Parser for extra options to exec command
execOptsExtraParser :: Parser ExecOptsExtra
execOptsExtraParser = ExecOptsExtra
- <$> eoEnvSettingsParser
- <*> eoPackagesParser
- <*> eoRtsOptionsParser
- <*> eoCwdParser
- where
- eoEnvSettingsParser :: Parser EnvSettings
- eoEnvSettingsParser = EnvSettings 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
- <*> pure False
- <*> pure True
+ <$> eoEnvSettingsParser
+ <*> eoPackagesParser
+ <*> eoRtsOptionsParser
+ <*> eoCwdParser
+ where
+ eoEnvSettingsParser :: Parser EnvSettings
+ eoEnvSettingsParser = EnvSettings 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
+ <*> pure False
+ <*> pure True
- eoPackagesParser :: Parser [String]
- eoPackagesParser = many
- (strOption (long "package"
- <> metavar "PACKAGE"
- <> help "Add a package (can be specified multiple times)"))
+ eoPackagesParser :: Parser [String]
+ eoPackagesParser = many (strOption
+ ( long "package"
+ <> metavar "PACKAGE"
+ <> help "Add a package (can be specified multiple times)"
+ ))
- eoRtsOptionsParser :: Parser [String]
- eoRtsOptionsParser = concat <$> many (argsOption
- ( long "rts-options"
- <> help "Explicit RTS options to pass to application"
- <> metavar "RTSFLAG"))
+ eoRtsOptionsParser :: Parser [String]
+ eoRtsOptionsParser = concat <$> many (argsOption
+ ( long "rts-options"
+ <> help "Explicit RTS options to pass to application"
+ <> metavar "RTSFLAG"
+ ))
- eoCwdParser :: Parser (Maybe FilePath)
- eoCwdParser = optional
- (strOption (long "cwd"
- <> help "Sets the working directory before executing"
- <> metavar "DIR"
- <> completer dirCompleter)
- )
+ eoCwdParser :: Parser (Maybe FilePath)
+ eoCwdParser = optional (strOption
+ ( long "cwd"
+ <> help "Sets the working directory before executing"
+ <> metavar "DIR"
+ <> completer dirCompleter
+ ))
diff --git a/src/Stack/Options/GhcBuildParser.hs b/src/Stack/Options/GhcBuildParser.hs
--- a/src/Stack/Options/GhcBuildParser.hs
+++ b/src/Stack/Options/GhcBuildParser.hs
@@ -1,34 +1,38 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.GhcBuildParser where
+module Stack.Options.GhcBuildParser
+( ghcBuildParser
+) where
import Options.Applicative
-import Options.Applicative.Types
-import Stack.Options.Utils
+ ( Parser, completeWith, help, long, metavar, option )
+import Options.Applicative.Types ( readerAsk, readerError )
+import Stack.Options.Utils ( hideMods )
import Stack.Prelude
-import Stack.Types.CompilerBuild
+import Stack.Types.CompilerBuild ( CompilerBuild, parseCompilerBuild )
-- | GHC build parser
ghcBuildParser :: Bool -> Parser CompilerBuild
-ghcBuildParser hide =
- option
- readGHCBuild
- (long "ghc-build" <> metavar "BUILD" <>
- completeWith [ "standard"
- , "gmp4"
- , "nopie"
- , "tinfo6"
- , "tinfo6-nopie"
- , "ncurses6"
- , "int-native"
- , "integersimple"] <>
- help
- "Specialized GHC build, e.g. 'gmp4' or 'standard' (usually auto-detected)" <>
- hideMods hide
- )
- where
- readGHCBuild = do
- s <- readerAsk
- case parseCompilerBuild s of
- Left e -> readerError (show e)
- Right v -> return v
+ghcBuildParser hide = option readGHCBuild
+ ( long "ghc-build"
+ <> metavar "BUILD"
+ <> completeWith
+ [ "standard"
+ , "gmp4"
+ , "nopie"
+ , "tinfo6"
+ , "tinfo6-nopie"
+ , "ncurses6"
+ , "int-native"
+ , "integersimple"
+ ]
+ <> help "Specialized GHC build, e.g. 'gmp4' or 'standard' (usually \
+ \auto-detected)"
+ <> hideMods hide
+ )
+ where
+ readGHCBuild = do
+ s <- readerAsk
+ case parseCompilerBuild s of
+ Left e -> readerError (displayException e)
+ Right v -> pure v
diff --git a/src/Stack/Options/GhcVariantParser.hs b/src/Stack/Options/GhcVariantParser.hs
--- a/src/Stack/Options/GhcVariantParser.hs
+++ b/src/Stack/Options/GhcVariantParser.hs
@@ -1,25 +1,28 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.GhcVariantParser where
+module Stack.Options.GhcVariantParser
+ ( ghcVariantParser
+ ) where
import Options.Applicative
-import Options.Applicative.Types (readerAsk)
+ ( Parser, help, long, metavar, option, readerError )
+import Options.Applicative.Types ( readerAsk )
import Stack.Prelude
-import Stack.Options.Utils
-import Stack.Types.Config
+import Stack.Options.Utils ( hideMods )
+import Stack.Types.Config ( GHCVariant, parseGHCVariant )
-- | GHC variant parser
ghcVariantParser :: Bool -> Parser GHCVariant
ghcVariantParser hide = option readGHCVariant
- ( long "ghc-variant"
+ ( long "ghc-variant"
<> metavar "VARIANT"
<> help "Specialized GHC variant, e.g. int-native or integersimple \
\(incompatible with --system-ghc)"
<> hideMods hide
- )
+ )
where
readGHCVariant = do
s <- readerAsk
case parseGHCVariant s of
- Left e -> readerError (show e)
- Right v -> return v
+ Left e -> readerError (displayException e)
+ Right v -> pure v
diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs
--- a/src/Stack/Options/GhciParser.hs
+++ b/src/Stack/Options/GhciParser.hs
@@ -1,61 +1,100 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-module Stack.Options.GhciParser where
+module Stack.Options.GhciParser
+ ( ghciOptsParser
+ ) where
import Options.Applicative
-import Options.Applicative.Args
+ ( Parser, completer, flag, help, idm, internal, long, metavar
+ , strOption, switch
+ )
+import Options.Applicative.Args ( argsOption )
import Options.Applicative.Builder.Extra
-import Stack.Config (packagesParser)
-import Stack.Ghci (GhciOpts (..))
-import Stack.Options.BuildParser (flagsParser)
+ ( boolFlags, boolFlagsNoDefault, fileExtCompleter
+ , textArgument, textOption
+ )
+import Stack.Config ( packagesParser )
+import Stack.Ghci ( GhciOpts (..) )
+import Stack.Options.BuildParser ( flagsParser )
import Stack.Options.Completion
+ ( ghcOptsCompleter, targetCompleter )
import Stack.Prelude
-- | Parser for GHCI options
ghciOptsParser :: Parser GhciOpts
ghciOptsParser = GhciOpts
- <$> many
- (textArgument
- (metavar "TARGET/FILE" <>
- completer (targetCompleter <> fileExtCompleter [".hs", ".lhs"]) <>
- help ("If none specified, use all local packages. " <>
- "See https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details. " <>
- "If a path to a .hs or .lhs file is specified, it will be loaded.")))
- <*> ((\x y -> x ++ concat y)
- <$> flag
- []
- ["-Wall", "-Werror"]
- (long "pedantic" <> help "Turn on -Wall and -Werror")
- <*> many (argsOption (long "ghci-options" <>
- metavar "OPTIONS" <>
- completer ghcOptsCompleter <>
- help "Additional options passed to GHCi"))
- )
- <*> (concat <$> many
- (argsOption
- (long "ghc-options" <>
- metavar "OPTIONS" <>
- completer ghcOptsCompleter <>
- help "Additional options passed to both GHC and GHCi")))
- <*> flagsParser
- <*> optional
- (strOption (long "with-ghc" <>
- metavar "GHC" <>
- help "Use this GHC to run GHCi"))
- <*> (not <$> boolFlags True "load" "load modules on start-up" idm)
- <*> packagesParser
- <*> optional
- (textOption
- (long "main-is" <>
- metavar "TARGET" <>
- completer targetCompleter <>
- help "Specify which target should contain the main \
- \module to load, such as for an executable for \
- \test suite or benchmark."))
- <*> switch (long "load-local-deps" <> help "Load all local dependencies of your targets")
- -- TODO: deprecate this? probably useless.
- <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies" <> internal)
- <*> optional (boolFlagsNoDefault "package-hiding" "package hiding" idm)
- <*> switch (long "no-build" <> help "Don't build before launching GHCi" <> internal)
- <*> switch (long "only-main" <> help "Only load and import the main module. If no main module, no modules will be loaded.")
+ <$> many (textArgument
+ ( metavar "TARGET/FILE"
+ <> completer (targetCompleter <> fileExtCompleter [".hs", ".lhs"])
+ <> help "If none specified, use all local packages. See \
+ \https://docs.haskellstack.org/en/stable/build_command/#target-syntax \
+ \for details. If a path to a .hs or .lhs file is specified, it \
+ \will be loaded."
+ ))
+ <*> ( (\x y -> x ++ concat y)
+ <$> flag
+ []
+ ["-Wall", "-Werror"]
+ ( long "pedantic"
+ <> help "Turn on -Wall and -Werror"
+ )
+ <*> many (argsOption
+ ( long "ghci-options"
+ <> metavar "OPTIONS"
+ <> completer ghcOptsCompleter
+ <> help "Additional options passed to GHCi"
+ ))
+ )
+ <*> ( concat
+ <$> many (argsOption
+ ( long "ghc-options"
+ <> metavar "OPTIONS"
+ <> completer ghcOptsCompleter
+ <> help "Additional options passed to both GHC and GHCi"
+ ))
+ )
+ <*> flagsParser
+ <*> optional (strOption
+ ( long "with-ghc"
+ <> metavar "GHC"
+ <> help "Use this GHC to run GHCi"
+ ))
+ <*> ( not
+ <$> boolFlags True
+ "load"
+ "load modules on start-up"
+ idm
+ )
+ <*> packagesParser
+ <*> optional (textOption
+ ( long "main-is"
+ <> metavar "TARGET"
+ <> completer targetCompleter
+ <> help "Specify which target should contain the main module to load, \
+ \such as for an executable for test suite or benchmark."
+ ))
+ <*> switch
+ ( long "load-local-deps"
+ <> help "Load all local dependencies of your targets"
+ )
+ -- TODO: deprecate this? probably useless.
+ <*> switch
+ ( long "skip-intermediate-deps"
+ <> help "Skip loading intermediate target dependencies"
+ <> internal
+ )
+ <*> optional (boolFlagsNoDefault
+ "package-hiding"
+ "package hiding"
+ idm)
+ <*> switch
+ ( long "no-build"
+ <> help "Don't build before launching GHCi"
+ <> internal
+ )
+ <*> switch
+ ( long "only-main"
+ <> help "Only load and import the main module. If no main module, no \
+ \modules will be loaded."
+ )
diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs
--- a/src/Stack/Options/GlobalParser.hs
+++ b/src/Stack/Options/GlobalParser.hs
@@ -1,80 +1,119 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
-module Stack.Options.GlobalParser where
+module Stack.Options.GlobalParser
+ ( globalOptsFromMonoid
+ , globalOptsParser
+ , initOptsParser
+ ) where
import Options.Applicative
+ ( Parser, auto, completer, help, hidden, internal, long
+ , metavar, option, strOption, switch, value
+ )
import Options.Applicative.Builder.Extra
-import Path.IO (getCurrentDir, resolveDir', resolveFile')
-import qualified Stack.Docker as Docker
-import Stack.Init
+ ( dirCompleter, fileExtCompleter, firstBoolFlagsFalse
+ , firstBoolFlagsNoDefault, firstBoolFlagsTrue, optionalFirst
+ , textArgument
+ )
+import Path.IO ( getCurrentDir, resolveDir', resolveFile' )
+import qualified Stack.Docker as Docker
+import Stack.Init ( InitOpts (..) )
import Stack.Prelude
-import Stack.Options.ConfigParser
-import Stack.Options.LogLevelParser
+import Stack.Options.ConfigParser ( configOptsParser )
+import Stack.Options.LogLevelParser ( logLevelOptsParser )
import Stack.Options.ResolverParser
-import Stack.Options.Utils
+ ( abstractResolverOptsParser, compilerOptsParser )
+import Stack.Options.Utils ( GlobalOptsContext (..), hideMods )
import Stack.Types.Config
-import Stack.Types.Docker
+ ( GlobalOpts (..), GlobalOptsMonoid (..)
+ , LockFileBehavior (..), StackYamlLoc (..), defaultLogLevel
+ , readLockFileBehavior, readStyles
+ )
+import Stack.Types.Docker ( dockerEntrypointArgName )
-- | Parser for global command-line options.
-globalOptsParser :: FilePath -> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid
-globalOptsParser currentDir kind defLogLevel =
- GlobalOptsMonoid <$>
- optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>
- optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>
- (First <$> logLevelOptsParser hide0 defLogLevel) <*>
- firstBoolFlagsTrue
+globalOptsParser ::
+ FilePath
+ -> GlobalOptsContext
+ -> Maybe LogLevel
+ -> Parser GlobalOptsMonoid
+globalOptsParser currentDir kind defLogLevel = GlobalOptsMonoid
+ <$> optionalFirst (strOption
+ ( long Docker.reExecArgName
+ <> hidden
+ <> internal
+ ))
+ <*> optionalFirst (option auto
+ ( long dockerEntrypointArgName
+ <> hidden
+ <> internal
+ ))
+ <*> (First <$> logLevelOptsParser hide0 defLogLevel)
+ <*> firstBoolFlagsTrue
"time-in-log"
"inclusion of timings in logs, for the purposes of using diff with logs"
- hide <*>
- firstBoolFlagsFalse
+ hide
+ <*> firstBoolFlagsFalse
"rsl-in-log"
"inclusion of raw snapshot layer (rsl) in logs"
- hide <*>
- configOptsParser currentDir kind <*>
- optionalFirst (abstractResolverOptsParser hide0) <*>
- pure (First Nothing) <*> -- resolver root is only set via the script command
- optionalFirst (compilerOptsParser hide0) <*>
- firstBoolFlagsNoDefault
+ hide
+ <*> configOptsParser currentDir kind
+ <*> optionalFirst (abstractResolverOptsParser hide0)
+ <*> pure (First Nothing)
+ <*> optionalFirst (compilerOptsParser hide0)
+ -- resolver root is only set via the script command
+ <*> firstBoolFlagsNoDefault
"terminal"
"overriding terminal detection in the case of running in a false terminal"
- hide <*>
- option readStyles
- (long "stack-colors" <>
- long "stack-colours" <>
- metavar "STYLES" <>
- value mempty <>
- help "Specify stack's output styles; STYLES is a colon-delimited \
- \sequence of key=value, where 'key' is a style name and 'value' \
- \is a semicolon-delimited list of 'ANSI' SGR (Select Graphic \
- \Rendition) control codes (in decimal). Use 'stack ls \
- \stack-colors --basic' to see the current sequence. In shells \
- \where a semicolon is a command separator, enclose STYLES in \
- \quotes." <>
- hide) <*>
- optionalFirst (option auto
- (long "terminal-width" <>
- metavar "INT" <>
- help "Specify the width of the terminal, used for pretty-print messages" <>
- hide)) <*>
- optionalFirst
- (strOption
- (long "stack-yaml" <>
- metavar "STACK-YAML" <>
- completer (fileExtCompleter [".yaml"]) <>
- help ("Override project stack.yaml file " <>
- "(overrides any STACK_YAML environment variable)") <>
- hide)) <*>
- optionalFirst (option readLockFileBehavior
- (long "lock-file" <>
- help "Specify how to interact with lock files. Default: read/write. If resolver is overridden: read-only" <>
- hide))
- where
- hide = hideMods hide0
- hide0 = kind /= OuterGlobalOpts
+ hide
+ <*> option readStyles
+ ( long "stack-colors"
+ <> long "stack-colours"
+ <> metavar "STYLES"
+ <> value mempty
+ <> help "Specify Stack's output styles; STYLES is a colon-delimited \
+ \sequence of key=value, where 'key' is a style name and 'value' \
+ \is a semicolon-delimited list of 'ANSI' SGR (Select Graphic \
+ \Rendition) control codes (in decimal). Use 'stack ls \
+ \stack-colors --basic' to see the current sequence. In shells \
+ \where a semicolon is a command separator, enclose STYLES in \
+ \quotes."
+ <> hide
+ )
+ <*> optionalFirst (option auto
+ ( long "terminal-width"
+ <> metavar "INT"
+ <> help "Specify the width of the terminal, used for pretty-print \
+ \messages"
+ <> hide
+ ))
+ <*> optionalFirst (strOption
+ ( long "stack-yaml"
+ <> metavar "STACK-YAML"
+ <> completer (fileExtCompleter [".yaml"])
+ <> help
+ ( "Override project stack.yaml file "
+ <> "(overrides any STACK_YAML environment variable)"
+ )
+ <> hide
+ ))
+ <*> optionalFirst (option readLockFileBehavior
+ ( long "lock-file"
+ <> help "Specify how to interact with lock files. Default: read/write. \
+ \If resolver is overridden: read-only"
+ <> hide
+ ))
+ where
+ hide = hideMods hide0
+ hide0 = kind /= OuterGlobalOpts
-- | Create GlobalOpts from GlobalOptsMonoid.
-globalOptsFromMonoid :: MonadIO m => Bool -> GlobalOptsMonoid -> m GlobalOpts
+globalOptsFromMonoid ::
+ MonadIO m
+ => Bool
+ -> GlobalOptsMonoid
+ -> m GlobalOpts
globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = do
resolver <- for (getFirst globalMonoidResolver) $ \ur -> do
root <-
@@ -108,24 +147,30 @@
}
initOptsParser :: Parser InitOpts
-initOptsParser =
- InitOpts <$> searchDirs
- <*> omitPackages
- <*> overwrite <*> fmap not ignoreSubDirs
- where
- searchDirs =
- many (textArgument
- (metavar "DIR(S)" <>
- completer dirCompleter <>
- help "Directory, or directories, to include in the search for \
- \.cabal files, when initialising. The default is the \
- \current directory."))
- ignoreSubDirs = switch (long "ignore-subdirs" <>
- help "Do not search for .cabal files in \
- \subdirectories, when initialising.")
- overwrite = switch (long "force" <>
- help "Force an initialisation that overwrites any \
- \existing stack.yaml file.")
- omitPackages = switch (long "omit-packages" <>
- help "Exclude conflicting or incompatible user \
- \packages, when initialising.")
+initOptsParser = InitOpts
+ <$> searchDirs
+ <*> omitPackages
+ <*> overwrite
+ <*> fmap not ignoreSubDirs
+ where
+ searchDirs = many (textArgument
+ ( metavar "DIR(S)"
+ <> completer dirCompleter
+ <> help "Directory, or directories, to include in the search for .cabal \
+ \files, when initialising. The default is the current directory."
+ ))
+ ignoreSubDirs = switch
+ ( long "ignore-subdirs"
+ <> help "Do not search for .cabal files in subdirectories, when \
+ \initialising."
+ )
+ overwrite = switch
+ ( long "force"
+ <> help "Force an initialisation that overwrites any existing stack.yaml \
+ \file."
+ )
+ omitPackages = switch
+ ( long "omit-packages"
+ <> help "Exclude conflicting or incompatible user packages, when \
+ \initialising."
+ )
diff --git a/src/Stack/Options/HaddockParser.hs b/src/Stack/Options/HaddockParser.hs
--- a/src/Stack/Options/HaddockParser.hs
+++ b/src/Stack/Options/HaddockParser.hs
@@ -1,21 +1,26 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.HaddockParser where
+module Stack.Options.HaddockParser
+ ( haddockOptsParser
+ ) where
-import Options.Applicative
-import Options.Applicative.Args
-import Stack.Options.Utils
+import Options.Applicative ( Parser, help, long, metavar )
+import Options.Applicative.Args ( argsOption )
+import Stack.Options.Utils ( hideMods )
import Stack.Prelude
-import Stack.Types.Config
+import Stack.Types.Config ( HaddockOptsMonoid (..) )
-- | Parser for haddock arguments.
haddockOptsParser :: Bool -> Parser HaddockOptsMonoid
-haddockOptsParser hide0 =
- HaddockOptsMonoid <$> fmap (fromMaybe [])
- (optional
- (argsOption
- (long "haddock-arguments" <>
- metavar "HADDOCK_ARGS" <>
- help "Arguments passed to the haddock program" <>
- hide)))
- where hide = hideMods hide0
+haddockOptsParser hide0 = HaddockOptsMonoid
+ <$> fmap
+ (fromMaybe [])
+ ( optional (argsOption
+ ( long "haddock-arguments"
+ <> metavar "HADDOCK_ARGS"
+ <> help "Arguments passed to the haddock program"
+ <> hide
+ ))
+ )
+ where
+ hide = hideMods hide0
diff --git a/src/Stack/Options/HpcReportParser.hs b/src/Stack/Options/HpcReportParser.hs
--- a/src/Stack/Options/HpcReportParser.hs
+++ b/src/Stack/Options/HpcReportParser.hs
@@ -1,42 +1,57 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.HpcReportParser where
+module Stack.Options.HpcReportParser
+ ( hpcReportOptsParser
+ , pvpBoundsOption
+ ) where
-import qualified Data.Text as T
+import qualified Data.Text as T
import Options.Applicative
+ ( Parser, completer, completeWith, help, long, metavar
+ , option, readerError, strOption, switch
+ )
import Options.Applicative.Builder.Extra
-import Options.Applicative.Types (readerAsk)
-import Stack.Coverage (HpcReportOpts (..))
-import Stack.Options.Completion (targetCompleter)
+ ( dirCompleter, fileExtCompleter, textArgument )
+import Options.Applicative.Types ( readerAsk )
+import Stack.Coverage ( HpcReportOpts (..) )
+import Stack.Options.Completion ( targetCompleter )
import Stack.Prelude
-import Stack.Types.Config
+import Stack.Types.Config ( PvpBounds, parsePvpBounds )
-- | Parser for @stack hpc report@.
hpcReportOptsParser :: Parser HpcReportOpts
hpcReportOptsParser = HpcReportOpts
- <$> many (textArgument $ metavar "TARGET_OR_TIX" <>
- completer (targetCompleter <> fileExtCompleter [".tix"]))
- <*> switch (long "all" <> help "Use results from all packages and components involved in previous --coverage run")
- <*> optional (strOption (long "destdir" <>
- metavar "DIR" <>
- completer dirCompleter <>
- help "Output directory for HTML report"))
- <*> switch (long "open" <> help "Open the report in the browser")
+ <$> many (textArgument
+ ( metavar "TARGET_OR_TIX"
+ <> completer (targetCompleter <> fileExtCompleter [".tix"])
+ ))
+ <*> switch
+ ( long "all"
+ <> help "Use results from all packages and components involved in \
+ \previous --coverage run"
+ )
+ <*> optional (strOption
+ ( long "destdir"
+ <> metavar "DIR"
+ <> completer dirCompleter
+ <> help "Output directory for HTML report"
+ ))
+ <*> switch
+ ( long "open"
+ <> help "Open the report in the browser"
+ )
pvpBoundsOption :: Parser PvpBounds
-pvpBoundsOption =
- option
- readPvpBounds
- (long "pvp-bounds" <>
- metavar "PVP-BOUNDS" <>
- completeWith ["none", "lower", "upper", "both"] <>
- help
- "How PVP version bounds should be added to .cabal file: none, lower, upper, both")
- where
- readPvpBounds = do
- s <- readerAsk
- case parsePvpBounds $ T.pack s of
- Left e ->
- readerError e
- Right v ->
- return v
+pvpBoundsOption = option readPvpBounds
+ ( long "pvp-bounds"
+ <> metavar "PVP-BOUNDS"
+ <> completeWith ["none", "lower", "upper", "both"]
+ <> help "How PVP version bounds should be added to Cabal file: none, lower, \
+ \upper, both"
+ )
+ where
+ readPvpBounds = do
+ s <- readerAsk
+ case parsePvpBounds $ T.pack s of
+ Left e -> readerError e
+ Right v -> pure v
diff --git a/src/Stack/Options/LogLevelParser.hs b/src/Stack/Options/LogLevelParser.hs
--- a/src/Stack/Options/LogLevelParser.hs
+++ b/src/Stack/Options/LogLevelParser.hs
@@ -1,44 +1,59 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-module Stack.Options.LogLevelParser where
+module Stack.Options.LogLevelParser
+ ( logLevelOptsParser
+ ) where
-import qualified Data.Text as T
+import qualified Data.Text as T
import Options.Applicative
-import Stack.Options.Utils
+ ( Parser, completeWith, flag', help, long, metavar, short
+ , strOption
+ )
+import Stack.Options.Utils ( hideMods )
import Stack.Prelude
-- | Parser for a logging level.
logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)
-logLevelOptsParser hide defLogLevel =
- fmap (Just . parse)
- (strOption (long "verbosity" <>
- metavar "VERBOSITY" <>
- completeWith ["silent", "error", "warn", "info", "debug"] <>
- help "Verbosity: silent, error, warn, info, debug" <>
- hideMods hide)) <|>
- flag' (Just verboseLevel)
- (short 'v' <> long "verbose" <>
- help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <>
- hideMods hide) <|>
- flag' (Just silentLevel)
- (long "silent" <>
- help ("Enable silent mode: verbosity level \"" <> showLevel silentLevel <> "\"") <>
- hideMods hide) <|>
- pure defLogLevel
- where verboseLevel = LevelDebug
- silentLevel = LevelOther "silent"
- showLevel l =
- case l of
- LevelDebug -> "debug"
- LevelInfo -> "info"
- LevelWarn -> "warn"
- LevelError -> "error"
- LevelOther x -> T.unpack x
- parse s =
- case s of
- "debug" -> LevelDebug
- "info" -> LevelInfo
- "warn" -> LevelWarn
- "error" -> LevelError
- _ -> LevelOther (T.pack s)
+logLevelOptsParser hide defLogLevel = fmap (Just . parse)
+ (strOption
+ ( long "verbosity"
+ <> metavar "VERBOSITY"
+ <> completeWith ["silent", "error", "warn", "info", "debug"]
+ <> help "Verbosity: silent, error, warn, info, debug"
+ <> hideMods hide
+ ))
+ <|> flag' (Just verboseLevel)
+ ( short 'v'
+ <> long "verbose"
+ <> help
+ ( "Enable verbose mode: verbosity level \""
+ <> showLevel verboseLevel
+ <> "\""
+ )
+ <> hideMods hide
+ )
+ <|> flag' (Just silentLevel)
+ ( long "silent"
+ <> help ( "Enable silent mode: verbosity level \""
+ <> showLevel silentLevel
+ <> "\""
+ )
+ <> hideMods hide
+ )
+ <|> pure defLogLevel
+ where
+ verboseLevel = LevelDebug
+ silentLevel = LevelOther "silent"
+ showLevel l = case l of
+ LevelDebug -> "debug"
+ LevelInfo -> "info"
+ LevelWarn -> "warn"
+ LevelError -> "error"
+ LevelOther x -> T.unpack x
+ parse s = case s of
+ "debug" -> LevelDebug
+ "info" -> LevelInfo
+ "warn" -> LevelWarn
+ "error" -> LevelError
+ _ -> LevelOther (T.pack s)
diff --git a/src/Stack/Options/NewParser.hs b/src/Stack/Options/NewParser.hs
--- a/src/Stack/Options/NewParser.hs
+++ b/src/Stack/Options/NewParser.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.NewParser where
+module Stack.Options.NewParser
+ ( newOptsParser
+ ) where
-import qualified Data.Map.Strict as M
+import qualified Data.Map.Strict as M
import Options.Applicative
import Stack.Init
import Stack.New
@@ -14,26 +16,27 @@
-- | Parser for @stack new@.
newOptsParser :: Parser (NewOpts,InitOpts)
newOptsParser = (,) <$> newOpts <*> initOptsParser
- where
- newOpts =
- NewOpts <$>
- packageNameArgument
- (metavar "PACKAGE_NAME" <> help "A valid package name.") <*>
- switch
- (long "bare" <>
- help "Do not create a subdirectory for the project") <*>
- optional (templateNameArgument
- (metavar "TEMPLATE_NAME" <>
- help "Name of a template - can take the form\
- \ [[service:]username/]template with optional service name\
- \ (github, gitlab, or bitbucket) \
- \ and username for the service; or, a local filename such as\
- \ foo.hsfiles or ~/foo; or, a full URL such as\
- \ https://example.com/foo.hsfiles.")) <*>
- fmap
- M.fromList
- (many
- (templateParamArgument
- (short 'p' <> long "param" <> metavar "KEY:VALUE" <>
- help
- "Parameter for the template in the format key:value")))
+ where
+ newOpts = NewOpts
+ <$> packageNameArgument
+ ( metavar "PACKAGE_NAME"
+ <> help "A valid package name."
+ )
+ <*> switch
+ ( long "bare"
+ <> help "Do not create a subdirectory for the project"
+ )
+ <*> optional (templateNameArgument
+ ( metavar "TEMPLATE_NAME"
+ <> help "Name of a template - can take the form\
+ \ [[service:]username/]template with optional service name\
+ \ (github, gitlab, or bitbucket) and username for the \
+ \service; or, a local filename such as foo.hsfiles or ~/foo; \
+ \or, a full URL such as https://example.com/foo.hsfiles."
+ ))
+ <*> fmap M.fromList (many (templateParamArgument
+ ( short 'p'
+ <> long "param"
+ <> metavar "KEY:VALUE"
+ <> help "Parameter for the template in the format key:value"
+ )))
diff --git a/src/Stack/Options/NixParser.hs b/src/Stack/Options/NixParser.hs
--- a/src/Stack/Options/NixParser.hs
+++ b/src/Stack/Options/NixParser.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.NixParser where
+module Stack.Options.NixParser
+ ( nixOptsParser
+ ) where
-import qualified Data.Text as T
+import qualified Data.Text as T
import Options.Applicative
import Options.Applicative.Args
import Options.Applicative.Builder.Extra
@@ -13,50 +15,52 @@
nixOptsParser :: Bool -> Parser NixOptsMonoid
nixOptsParser hide0 = overrideActivation <$>
- (NixOptsMonoid
+ ( NixOptsMonoid
<$> firstBoolFlagsNoDefault
- nixCmdName
- "use of a Nix-shell. Implies 'system-ghc: true'"
- hide
+ nixCmdName
+ "use of a Nix-shell. Implies 'system-ghc: true'"
+ hide
<*> firstBoolFlagsNoDefault
- "nix-pure"
- "use of a pure Nix-shell. Implies '--nix' and 'system-ghc: true'"
- hide
- <*> optionalFirst
- (textArgsOption
- (long "nix-packages" <>
- metavar "NAMES" <>
- help "List of packages that should be available in the nix-shell (space separated)" <>
- hide))
- <*> optionalFirst
- (option
- str
- (long "nix-shell-file" <>
- metavar "FILE" <>
- completer (fileExtCompleter [".nix"]) <>
- help "Nix file to be used to launch a nix-shell (for regular Nix users)" <>
- hide))
- <*> optionalFirst
- (textArgsOption
- (long "nix-shell-options" <>
- metavar "OPTIONS" <>
- help "Additional options passed to nix-shell" <>
- hide))
- <*> optionalFirst
- (textArgsOption
- (long "nix-path" <>
- metavar "PATH_OPTIONS" <>
- help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>
- hide))
+ "nix-pure"
+ "use of a pure Nix-shell. Implies '--nix' and 'system-ghc: true'"
+ hide
+ <*> optionalFirst (textArgsOption
+ ( long "nix-packages"
+ <> metavar "NAMES"
+ <> help "List of packages that should be available in the nix-shell \
+ \(space separated)"
+ <> hide
+ ))
+ <*> optionalFirst (option str
+ ( long "nix-shell-file"
+ <> metavar "FILE"
+ <> completer (fileExtCompleter [".nix"])
+ <> help "Nix file to be used to launch a nix-shell (for regular Nix \
+ \users)"
+ <> hide
+ ))
+ <*> optionalFirst (textArgsOption
+ ( long "nix-shell-options"
+ <> metavar "OPTIONS"
+ <> help "Additional options passed to nix-shell"
+ <> hide
+ ))
+ <*> optionalFirst (textArgsOption
+ ( long "nix-path"
+ <> metavar "PATH_OPTIONS"
+ <> help "Additional options to override NIX_PATH parts (notably \
+ \'nixpkgs')"
+ <> hide
+ ))
<*> firstBoolFlagsFalse
- "nix-add-gc-roots"
- "addition of packages to the nix GC roots so nix-collect-garbage doesn't remove them"
- hide
+ "nix-add-gc-roots"
+ "addition of packages to the nix GC roots so nix-collect-garbage doesn't remove them"
+ hide
)
- where
- hide = hideMods hide0
- overrideActivation m =
- if fromFirst False (nixMonoidPureShell m)
- then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) }
- else m
- textArgsOption = fmap (map T.pack) . argsOption
+ where
+ hide = hideMods hide0
+ overrideActivation m =
+ if fromFirst False (nixMonoidPureShell m)
+ then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) }
+ else m
+ textArgsOption = fmap (map T.pack) . argsOption
diff --git a/src/Stack/Options/PackageParser.hs b/src/Stack/Options/PackageParser.hs
--- a/src/Stack/Options/PackageParser.hs
+++ b/src/Stack/Options/PackageParser.hs
@@ -1,32 +1,31 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.PackageParser where
+module Stack.Options.PackageParser
+ ( readFlag
+ ) where
-import qualified Data.Map as Map
-import Options.Applicative
-import Options.Applicative.Types (readerAsk)
+import qualified Data.Map as Map
+import Options.Applicative ( ReadM, readerError )
+import Options.Applicative.Types ( readerAsk )
import Stack.Prelude
-import Stack.Types.Config.Build (ApplyCLIFlag (..))
+import Stack.Types.Config.Build ( ApplyCLIFlag (..) )
-- | Parser for package:[-]flag
readFlag :: ReadM (Map ApplyCLIFlag (Map FlagName Bool))
readFlag = do
- s <- readerAsk
- case break (== ':') s of
- (pn, ':':mflag) -> do
- pn' <-
- case parsePackageName pn of
- Nothing
- | pn == "*" -> return ACFAllProjectPackages
- | otherwise -> readerError $ "Invalid package name: " ++ pn
- Just x -> return $ ACFByName x
- let (b, flagS) =
- case mflag of
- '-':x -> (False, x)
- _ -> (True, mflag)
- flagN <-
- case parseFlagName flagS of
- Nothing -> readerError $ "Invalid flag name: " ++ flagS
- Just x -> return x
- return $ Map.singleton pn' $ Map.singleton flagN b
- _ -> readerError "Must have a colon"
+ s <- readerAsk
+ case break (== ':') s of
+ (pn, ':':mflag) -> do
+ pn' <- case parsePackageName pn of
+ Nothing
+ | pn == "*" -> pure ACFAllProjectPackages
+ | otherwise -> readerError $ "Invalid package name: " ++ pn
+ Just x -> pure $ ACFByName x
+ let (b, flagS) = case mflag of
+ '-':x -> (False, x)
+ _ -> (True, mflag)
+ flagN <- case parseFlagName flagS of
+ Nothing -> readerError $ "Invalid flag name: " ++ flagS
+ Just x -> pure x
+ pure $ Map.singleton pn' $ Map.singleton flagN b
+ _ -> readerError "Must have a colon"
diff --git a/src/Stack/Options/ResolverParser.hs b/src/Stack/Options/ResolverParser.hs
--- a/src/Stack/Options/ResolverParser.hs
+++ b/src/Stack/Options/ResolverParser.hs
@@ -1,35 +1,40 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
-module Stack.Options.ResolverParser where
+module Stack.Options.ResolverParser
+ ( abstractResolverOptsParser
+ , compilerOptsParser
+ , readCompilerVersion
+ ) where
-import qualified Data.Text as T
+import qualified Data.Text as T
import Options.Applicative
-import Options.Applicative.Types (readerAsk)
-import Stack.Options.Utils
+ ( Parser, ReadM, help, long, metavar, option, readerError )
+import Options.Applicative.Types ( readerAsk )
+import Stack.Options.Utils ( hideMods )
import Stack.Prelude
-import Stack.Types.Resolver
+import Stack.Types.Resolver ( AbstractResolver, readAbstractResolver )
-- | Parser for the resolver
abstractResolverOptsParser :: Bool -> Parser (Unresolved AbstractResolver)
-abstractResolverOptsParser hide =
- option readAbstractResolver
- (long "resolver" <>
- metavar "RESOLVER" <>
- help "Override resolver in project file" <>
- hideMods hide)
+abstractResolverOptsParser hide = option readAbstractResolver
+ ( long "resolver"
+ <> metavar "RESOLVER"
+ <> help "Override resolver in project file"
+ <> hideMods hide
+ )
compilerOptsParser :: Bool -> Parser WantedCompiler
-compilerOptsParser hide =
- option readCompilerVersion
- (long "compiler" <>
- metavar "COMPILER" <>
- help "Use the specified compiler" <>
- hideMods hide)
+compilerOptsParser hide = option readCompilerVersion
+ ( long "compiler"
+ <> metavar "COMPILER"
+ <> help "Use the specified compiler"
+ <> hideMods hide
+ )
readCompilerVersion :: ReadM WantedCompiler
readCompilerVersion = do
- s <- readerAsk
- case parseWantedCompiler (T.pack s) of
- Left{} -> readerError $ "Failed to parse compiler: " ++ s
- Right x -> return x
+ s <- readerAsk
+ case parseWantedCompiler (T.pack s) of
+ Left{} -> readerError $ "Failed to parse compiler: " ++ s
+ Right x -> pure x
diff --git a/src/Stack/Options/SDistParser.hs b/src/Stack/Options/SDistParser.hs
--- a/src/Stack/Options/SDistParser.hs
+++ b/src/Stack/Options/SDistParser.hs
@@ -1,24 +1,35 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.SDistParser where
+module Stack.Options.SDistParser
+ ( sdistOptsParser
+ ) where
import Options.Applicative
import Options.Applicative.Builder.Extra
import Stack.Prelude
import Stack.SDist
-import Stack.Options.HpcReportParser (pvpBoundsOption)
+import Stack.Options.HpcReportParser ( pvpBoundsOption )
-- | Parser for arguments to `stack sdist`
sdistOptsParser :: Parser SDistOpts
-sdistOptsParser = SDistOpts <$>
- many (strArgument $ metavar "DIR" <> completer dirCompleter) <*>
- optional pvpBoundsOption <*>
- ignoreCheckSwitch <*>
- buildPackageOption <*>
- optional (strOption (long "tar-dir" <> help "If specified, copy all the tar to this dir"))
- where
- ignoreCheckSwitch =
- switch (long "ignore-check"
- <> help "Do not check package for common mistakes")
- buildPackageOption =
- boolFlags False "test-tarball" "building of the resulting tarball" idm
+sdistOptsParser = SDistOpts
+ <$> many (strArgument
+ ( metavar "DIR"
+ <> completer dirCompleter
+ ))
+ <*> optional pvpBoundsOption
+ <*> ignoreCheckSwitch
+ <*> buildPackageOption
+ <*> optional (strOption
+ ( long "tar-dir"
+ <> help "If specified, copy all the tar to this dir"
+ ))
+ where
+ ignoreCheckSwitch = switch
+ ( long "ignore-check"
+ <> help "Do not check package for common mistakes"
+ )
+ buildPackageOption = boolFlags False
+ "test-tarball"
+ "building of the resulting tarball"
+ idm
diff --git a/src/Stack/Options/ScriptParser.hs b/src/Stack/Options/ScriptParser.hs
--- a/src/Stack/Options/ScriptParser.hs
+++ b/src/Stack/Options/ScriptParser.hs
@@ -1,10 +1,18 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.ScriptParser where
+module Stack.Options.ScriptParser
+ ( ScriptExecute (..)
+ , ScriptOpts (..)
+ , ShouldRun (..)
+ , scriptOptsParser
+ ) where
import Options.Applicative
-import Options.Applicative.Builder.Extra
-import Stack.Options.Completion
+ ( Parser, completer, eitherReader, flag', help, long
+ , metavar, option, strArgument, strOption
+ )
+import Options.Applicative.Builder.Extra ( fileExtCompleter )
+import Stack.Options.Completion ( ghcOptsCompleter )
import Stack.Prelude
data ScriptOpts = ScriptOpts
@@ -29,30 +37,46 @@
scriptOptsParser :: Parser ScriptOpts
scriptOptsParser = ScriptOpts
- <$> many (strOption
- (long "package" <>
- metavar "PACKAGE" <>
- help "Add a package (can be specified multiple times)"))
- <*> strArgument (metavar "FILE" <> completer (fileExtCompleter [".hs", ".lhs"]))
- <*> many (strArgument (metavar "-- ARGUMENT(S) (e.g. stack script X.hs -- argument(s) to program)"))
- <*> (flag' SECompile
- ( long "compile"
- <> help "Compile the script without optimization and run the executable"
- ) <|>
- flag' SEOptimize
- ( long "optimize"
- <> help "Compile the script with optimization and run the executable"
- ) <|>
- pure SEInterpret)
- <*> many (strOption
- (long "ghc-options" <>
- metavar "OPTIONS" <>
- completer ghcOptsCompleter <>
- help "Additional options passed to GHC"))
- <*> many (option extraDepRead
- (long "extra-dep" <>
- metavar "PACKAGE-VERSION" <>
- help "Extra dependencies to be added to the snapshot"))
- <*> (flag' NoRun (long "no-run" <> help "Don't run, just compile.") <|> pure YesRun)
- where
- extraDepRead = eitherReader $ mapLeft show . parsePackageIdentifierRevision . fromString
+ <$> many (strOption
+ ( long "package"
+ <> metavar "PACKAGE"
+ <> help "Add a package (can be specified multiple times)"
+ ))
+ <*> strArgument
+ ( metavar "FILE"
+ <> completer (fileExtCompleter [".hs", ".lhs"])
+ )
+ <*> many (strArgument
+ ( metavar "-- ARGUMENT(S) (e.g. stack script X.hs -- argument(s) to \
+ \program)"
+ ))
+ <*> ( flag' SECompile
+ ( long "compile"
+ <> help "Compile the script without optimization and run the executable"
+ )
+ <|> flag' SEOptimize
+ ( long "optimize"
+ <> help "Compile the script with optimization and run the executable"
+ )
+ <|> pure SEInterpret
+ )
+ <*> many (strOption
+ ( long "ghc-options"
+ <> metavar "OPTIONS"
+ <> completer ghcOptsCompleter
+ <> help "Additional options passed to GHC"
+ ))
+ <*> many (option extraDepRead
+ ( long "extra-dep"
+ <> metavar "PACKAGE-VERSION"
+ <> help "Extra dependencies to be added to the snapshot"
+ ))
+ <*> ( flag' NoRun
+ ( long "no-run"
+ <> help "Don't run, just compile."
+ )
+ <|> pure YesRun
+ )
+ where
+ extraDepRead = eitherReader $
+ mapLeft show . parsePackageIdentifierRevision . fromString
diff --git a/src/Stack/Options/TestParser.hs b/src/Stack/Options/TestParser.hs
--- a/src/Stack/Options/TestParser.hs
+++ b/src/Stack/Options/TestParser.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.TestParser where
+module Stack.Options.TestParser
+ ( testOptsParser
+ ) where
import Options.Applicative
import Options.Applicative.Args
@@ -12,34 +14,36 @@
-- | Parser for test arguments.
-- FIXME hide args
testOptsParser :: Bool -> Parser TestOptsMonoid
-testOptsParser hide0 =
- TestOptsMonoid
- <$> firstBoolFlagsTrue
- "rerun-tests"
- "running already successful tests"
- hide
- <*> fmap
- concat
- (many
- (argsOption
- (long "test-arguments" <>
- long "ta" <>
- metavar "TEST_ARGS" <>
- help "Arguments passed in to the test suite program" <>
- hide)))
- <*> optionalFirstFalse
- (flag' True
- (long "coverage" <>
- help "Generate a code coverage report" <>
- hide))
- <*> optionalFirstFalse
- (flag' True
- (long "no-run-tests" <>
- help "Disable running of tests. (Tests will still be built.)" <>
- hide))
- <*> optionalFirst
- (option (fmap Just auto)
- (long "test-suite-timeout" <>
- help "Maximum test suite run time in seconds." <>
- hide))
- where hide = hideMods hide0
+testOptsParser hide0 = TestOptsMonoid
+ <$> firstBoolFlagsTrue
+ "rerun-tests"
+ "running already successful tests"
+ hide
+ <*> fmap concat (many (argsOption
+ ( long "test-arguments"
+ <> long "ta"
+ <> metavar "TEST_ARGS"
+ <> help "Arguments passed in to the test suite program"
+ <> hide
+ )))
+ <*> optionalFirstFalse (flag' True
+ ( long "coverage"
+ <> help "Generate a code coverage report"
+ <> hide
+ ))
+ <*> optionalFirstFalse (flag' True
+ ( long "no-run-tests"
+ <> help "Disable running of tests. (Tests will still be built.)"
+ <> hide
+ ))
+ <*> optionalFirst (option (fmap Just auto)
+ ( long "test-suite-timeout"
+ <> help "Maximum test suite run time in seconds."
+ <> hide
+ ))
+ <*> firstBoolFlagsTrue
+ "tests-allow-stdin"
+ "allow standard input in test executables"
+ hide
+ where
+ hide = hideMods hide0
diff --git a/src/Stack/Options/UploadParser.hs b/src/Stack/Options/UploadParser.hs
--- a/src/Stack/Options/UploadParser.hs
+++ b/src/Stack/Options/UploadParser.hs
@@ -1,15 +1,15 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Stack.Options.UploadParser
- ( UploadOpts(..)
- , UploadVariant(..)
+ ( UploadOpts (..)
+ , UploadVariant (..)
, uploadOptsParser
) where
import Options.Applicative
-import Stack.Options.SDistParser (sdistOptsParser)
+import Stack.Options.SDistParser ( sdistOptsParser )
import Stack.Prelude
-import Stack.SDist (SDistOpts(..))
+import Stack.SDist ( SDistOpts (..) )
data UploadOpts = UploadOpts
{ uoptsSDistOpts :: SDistOpts
diff --git a/src/Stack/Options/Utils.hs b/src/Stack/Options/Utils.hs
--- a/src/Stack/Options/Utils.hs
+++ b/src/Stack/Options/Utils.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Stack.Options.Utils where
+module Stack.Options.Utils
+ ( GlobalOptsContext (..)
+ , hideMods
+ ) where
-import Options.Applicative
+import Options.Applicative ( Mod, hidden, idm, internal )
import Stack.Prelude
-- | If argument is True, hides the option from usage and help
@@ -15,8 +18,8 @@
-- local --resolver this is not being used anymore but the code is kept for any
-- similar future use cases.
data GlobalOptsContext
- = OuterGlobalOpts -- ^ Global options before subcommand name
- | OtherCmdGlobalOpts -- ^ Global options following any other subcommand
- | BuildCmdGlobalOpts
- | GhciCmdGlobalOpts
- deriving (Show, Eq)
+ = OuterGlobalOpts -- ^ Global options before subcommand name
+ | OtherCmdGlobalOpts -- ^ Global options following any other subcommand
+ | BuildCmdGlobalOpts
+ | GhciCmdGlobalOpts
+ deriving (Eq, Show)
diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs
--- a/src/Stack/Package.hs
+++ b/src/Stack/Package.hs
@@ -1,111 +1,80 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-- | Dealing with Cabal.
module Stack.Package
- (readDotBuildinfo
- ,resolvePackage
- ,packageFromPackageDescription
- ,Package(..)
- ,PackageDescriptionPair(..)
- ,GetPackageFiles(..)
- ,GetPackageOpts(..)
- ,PackageConfig(..)
- ,buildLogPath
- ,PackageException (..)
- ,resolvePackageDescription
- ,packageDependencies
- ,applyForceCustomBuild
+ ( readDotBuildinfo
+ , resolvePackage
+ , packageFromPackageDescription
+ , Package (..)
+ , PackageDescriptionPair (..)
+ , GetPackageOpts (..)
+ , PackageConfig (..)
+ , buildLogPath
+ , PackageException (..)
+ , resolvePackageDescription
+ , packageDependencies
+ , applyForceCustomBuild
) where
-import Data.List (find, isPrefixOf, unzip)
+import Data.List ( unzip )
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import Distribution.CabalSpecVersion
import Distribution.Compiler
-import Distribution.ModuleName (ModuleName)
-import qualified Distribution.ModuleName as Cabal
-import Distribution.Package hiding (Package, packageName, packageVersion, PackageIdentifier)
-import Distribution.PackageDescription hiding (FlagName)
+import Distribution.Package
+ hiding
+ ( Package, packageName, packageVersion, PackageIdentifier )
+import Distribution.PackageDescription hiding ( FlagName )
#if !MIN_VERSION_Cabal(3,8,1)
import Distribution.PackageDescription.Parsec
#endif
-import Distribution.Pretty (prettyShow)
-import Distribution.Simple.Glob (matchDirFileGlob)
+import Distribution.Pretty ( prettyShow )
#if MIN_VERSION_Cabal(3,8,1)
-import Distribution.Simple.PackageDescription (readHookedBuildInfo)
+import Distribution.Simple.PackageDescription ( readHookedBuildInfo )
#endif
-import Distribution.System (OS (..), Arch, Platform (..))
-import Distribution.Text (display)
+import Distribution.System ( OS (..), Arch, Platform (..) )
+import Distribution.Text ( display )
import qualified Distribution.Types.CondTree as Cabal
import qualified Distribution.Types.ExeDependency as Cabal
import qualified Distribution.Types.LegacyExeDependency as Cabal
import Distribution.Types.MungedPackageName
import qualified Distribution.Types.UnqualComponentName as Cabal
-import Distribution.Utils.Path (getSymbolicPath)
-import Distribution.Verbosity (silent)
-import Distribution.Version (mkVersion, orLaterVersion, anyVersion)
-import qualified HiFileParser as Iface
-import Path as FL hiding (replaceExtension)
+import Distribution.Utils.Path ( getSymbolicPath )
+import Distribution.Verbosity ( silent )
+import Distribution.Version ( mkVersion, orLaterVersion, anyVersion )
+import Path as FL hiding ( replaceExtension )
import Path.Extra
-import Path.IO hiding (findFiles)
+import Path.IO hiding ( findFiles )
import Stack.Build.Installed
import Stack.Constants
import Stack.Constants.Config
-import Stack.Prelude hiding (Display (..))
+import Stack.Prelude hiding ( Display (..) )
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.Version
-import qualified System.Directory as D (doesFileExist)
-import System.FilePath (replaceExtension)
-import qualified System.FilePath as FilePath
-import System.IO.Error
-import RIO.Process
-import RIO.PrettyPrint
-import qualified RIO.PrettyPrint as PP (Style (Module))
-
-data Ctx = Ctx { ctxFile :: !(Path Abs File)
- , ctxDistDir :: !(Path Abs Dir)
- , ctxBuildConfig :: !BuildConfig
- , ctxCabalVer :: !Version
- }
-
-instance HasPlatform Ctx
-instance HasGHCVariant Ctx
-instance HasLogFunc Ctx where
- logFuncL = configL.logFuncL
-instance HasRunner Ctx where
- runnerL = configL.runnerL
-instance HasStylesUpdate Ctx where
- stylesUpdateL = runnerL.stylesUpdateL
-instance HasTerm Ctx where
- useColorL = runnerL.useColorL
- termWidthL = runnerL.termWidthL
-instance HasConfig Ctx
-instance HasPantryConfig Ctx where
- pantryConfigL = configL.pantryConfigL
-instance HasProcessContext Ctx where
- processContextL = configL.processContextL
-instance HasBuildConfig Ctx where
- buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = y })
-
+import System.FilePath ( replaceExtension )
+import Stack.Types.Dependency ( DepValue (..), DepType (..) )
+import Stack.Types.PackageFile
+ ( GetPackageFileContext (..), DotCabalPath
+ , GetPackageFiles (..)
+ )
+import Stack.PackageFile ( packageDescModulesAndFiles )
+import Stack.ComponentFile
-- | Read @.buildinfo@ ancillary files produced by some Setup.hs hooks.
-- The file includes Cabal file syntax to be merged into the package description
--- derived from the package's .cabal file.
+-- derived from the package's Cabal file.
--
-- NOTE: not to be confused with BuildInfo, an Stack-internal datatype.
readDotBuildinfo :: MonadIO m
@@ -114,8 +83,8 @@
readDotBuildinfo buildinfofp =
liftIO $ readHookedBuildInfo silent (toFilePath buildinfofp)
--- | Resolve a parsed cabal file into a 'Package', which contains all of
--- the info needed for stack to build the 'Package' given the current
+-- | Resolve a parsed Cabal file into a 'Package', which contains all of
+-- the info needed for Stack to build the 'Package' given the current
-- configuration.
resolvePackage :: PackageConfig
-> GenericPackageDescription
@@ -143,7 +112,7 @@
, packageFlags = packageConfigFlags packageConfig
, packageDefaultFlags = M.fromList
[(flagName flag, flagDefault flag) | flag <- pkgFlags]
- , packageAllDeps = S.fromList (M.keys deps)
+ , packageAllDeps = M.keysSet deps
, packageLibraries =
let mlib = do
lib <- library pkg
@@ -182,7 +151,7 @@
generatePkgDescOpts installMap installedMap
(excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs)
cabalfp pkg componentFiles
- return (componentsModules,componentFiles,componentsOpts)
+ pure (componentsModules,componentFiles,componentsOpts)
, packageHasExposedModules = maybe
False
(not . null . exposedModules)
@@ -222,7 +191,7 @@
cabalVer <- view cabalVersionL
(componentModules,componentFiles,dataFiles',warnings) <-
runRIO
- (Ctx cabalfp distDir bc cabalVer)
+ (GetPackageFileContext cabalfp distDir bc cabalVer)
(packageDescModulesAndFiles pkg)
setupFiles <-
if buildType pkg == Custom
@@ -230,15 +199,15 @@
let setupHsPath = pkgDir relFileSetupHs
setupLhsPath = pkgDir relFileSetupLhs
setupHsExists <- doesFileExist setupHsPath
- if setupHsExists then return (S.singleton setupHsPath) else do
+ if setupHsExists then pure (S.singleton setupHsPath) else do
setupLhsExists <- doesFileExist setupLhsPath
- if setupLhsExists then return (S.singleton setupLhsPath) else return S.empty
- else return S.empty
+ if setupLhsExists then pure (S.singleton setupLhsPath) else pure S.empty
+ else pure S.empty
buildFiles <- liftM (S.insert cabalfp . S.union setupFiles) $ do
let hpackPath = pkgDir relFileHpackPackageConfig
hpackExists <- doesFileExist hpackPath
- return $ if hpackExists then S.singleton hpackPath else S.empty
- return (componentModules, componentFiles, buildFiles <> dataFiles', warnings)
+ pure $ if hpackExists then S.singleton hpackPath else S.empty
+ pure (componentModules, componentFiles, buildFiles <> dataFiles', warnings)
pkgId = package pkg
name = pkgName pkgId
@@ -301,12 +270,12 @@
, biCabalVersion = cabalVer
}
)
- return
+ pure
( M.fromList
(concat
[ maybe
[]
- (return . generate CLib . libBuildInfo)
+ (pure . generate CLib . libBuildInfo)
(library pkg)
, mapMaybe
(\sublib -> do
@@ -468,55 +437,7 @@
relCFilePath <- stripProperPrefix cabalDir cFilePath
relOFilePath <-
parseRelFile (replaceExtension (toFilePath relCFilePath) "o")
- return (componentOutputDir namedComponent distDir relOFilePath)
-
--- | Make the global autogen dir if Cabal version is new enough.
-packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)
-packageAutogenDir cabalVer distDir
- | cabalVer < mkVersion [2, 0] = Nothing
- | otherwise = Just $ buildDir distDir relDirGlobalAutogen
-
--- | Make the autogen dir.
-componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
-componentAutogenDir cabalVer component distDir =
- componentBuildDir cabalVer component distDir relDirAutogen
-
--- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir'
-componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
-componentBuildDir cabalVer component distDir
- | cabalVer < mkVersion [2, 0] = buildDir distDir
- | otherwise =
- case component of
- CLib -> buildDir distDir
- CInternalLib name -> buildDir distDir componentNameToDir name
- CExe name -> buildDir distDir componentNameToDir name
- CTest name -> buildDir distDir componentNameToDir name
- CBench name -> buildDir distDir componentNameToDir name
-
--- | The directory where generated files are put like .o or .hs (from .x files).
-componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir
-componentOutputDir namedComponent distDir =
- case namedComponent of
- CLib -> buildDir distDir
- CInternalLib name -> makeTmp name
- CExe name -> makeTmp name
- CTest name -> makeTmp name
- CBench name -> makeTmp name
- where
- makeTmp name =
- buildDir distDir componentNameToDir (name <> "/" <> name <> "-tmp")
-
--- | Make the build dir. Note that Cabal >= 2.0 uses the
--- 'componentBuildDir' above for some things.
-buildDir :: Path Abs Dir -> Path Abs Dir
-buildDir distDir = distDir relDirBuild
-
--- NOTE: don't export this, only use it for valid paths based on
--- component names.
-componentNameToDir :: Text -> Path Rel Dir
-componentNameToDir name =
- fromMaybe (error "Invariant violated: component names should always parse as directory names")
- (parseRelDir (T.unpack name))
+ pure (componentOutputDir namedComponent distDir relOFilePath)
-- | Get all dependencies of the package (buildable targets only).
--
@@ -641,199 +562,6 @@
, let bi = benchmarkBuildInfo tst
, buildable bi ]
--- | Get all files referenced by the package.
-packageDescModulesAndFiles
- :: PackageDescription
- -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent [DotCabalPath], Set (Path Abs File), [PackageWarning])
-packageDescModulesAndFiles pkg = do
- (libraryMods,libDotCabalFiles,libWarnings) <-
- maybe
- (return (M.empty, M.empty, []))
- (asModuleAndFileMap libComponent libraryFiles)
- (library pkg)
- (subLibrariesMods,subLibDotCabalFiles,subLibWarnings) <-
- liftM
- foldTuples
- (mapM
- (asModuleAndFileMap internalLibComponent libraryFiles)
- (subLibraries pkg))
- (executableMods,exeDotCabalFiles,exeWarnings) <-
- liftM
- foldTuples
- (mapM
- (asModuleAndFileMap exeComponent executableFiles)
- (executables pkg))
- (testMods,testDotCabalFiles,testWarnings) <-
- liftM
- foldTuples
- (mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg))
- (benchModules,benchDotCabalPaths,benchWarnings) <-
- liftM
- foldTuples
- (mapM
- (asModuleAndFileMap benchComponent benchmarkFiles)
- (benchmarks pkg))
- dfiles <- resolveGlobFiles (specVersion pkg)
- (extraSrcFiles pkg
- ++ map (dataDir pkg FilePath.) (dataFiles pkg))
- let modules = libraryMods <> subLibrariesMods <> executableMods <> testMods <> benchModules
- files =
- libDotCabalFiles <> subLibDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <>
- benchDotCabalPaths
- warnings = libWarnings <> subLibWarnings <> exeWarnings <> testWarnings <> benchWarnings
- return (modules, files, dfiles, warnings)
- where
- libComponent = const CLib
- internalLibComponent = CInternalLib . T.pack . maybe "" Cabal.unUnqualComponentName . libraryNameString . libName
- exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName
- testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName
- benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName
- asModuleAndFileMap label f lib = do
- (a,b,c) <- f (label lib) lib
- return (M.singleton (label lib) a, M.singleton (label lib) b, c)
- foldTuples = foldl' (<>) (M.empty, M.empty, [])
-
--- | Resolve globbing of files (e.g. data files) to absolute paths.
-resolveGlobFiles
- :: CabalSpecVersion -- ^ cabal file version
- -> [String]
- -> RIO Ctx (Set (Path Abs File))
-resolveGlobFiles cabalFileVersion =
- liftM (S.fromList . catMaybes . concat) .
- mapM resolve
- where
- resolve name =
- if '*' `elem` name
- then explode name
- else liftM return (resolveFileOrWarn name)
- explode name = do
- dir <- asks (parent . ctxFile)
- names <-
- matchDirFileGlob'
- (FL.toFilePath dir)
- name
- mapM resolveFileOrWarn names
- matchDirFileGlob' dir glob =
- catch
- (liftIO (matchDirFileGlob minBound cabalFileVersion dir glob))
- (\(e :: IOException) ->
- if isUserError e
- then do
- prettyWarnL
- [ flow "Wildcard does not match any files:"
- , style File $ fromString glob
- , line <> flow "in directory:"
- , style Dir $ fromString dir
- ]
- return []
- else throwIO e)
-
--- | Get all files referenced by the benchmark.
-benchmarkFiles
- :: NamedComponent
- -> Benchmark
- -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
-benchmarkFiles component bench = do
- resolveComponentFiles component build names
- where
- names = bnames <> exposed
- exposed =
- case benchmarkInterface bench of
- BenchmarkExeV10 _ fp -> [DotCabalMain fp]
- BenchmarkUnsupported _ -> []
- bnames = map DotCabalModule (otherModules build)
- build = benchmarkBuildInfo bench
-
--- | Get all files referenced by the test.
-testFiles
- :: NamedComponent
- -> TestSuite
- -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
-testFiles component test = do
- resolveComponentFiles component build names
- where
- names = bnames <> exposed
- exposed =
- case testInterface test of
- TestSuiteExeV10 _ fp -> [DotCabalMain fp]
- TestSuiteLibV09 _ mn -> [DotCabalModule mn]
- TestSuiteUnsupported _ -> []
- bnames = map DotCabalModule (otherModules build)
- build = testBuildInfo test
-
--- | Get all files referenced by the executable.
-executableFiles
- :: NamedComponent
- -> Executable
- -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
-executableFiles component exe = do
- resolveComponentFiles component build names
- where
- build = buildInfo exe
- names =
- map DotCabalModule (otherModules build) ++
- [DotCabalMain (modulePath exe)]
-
--- | Get all files referenced by the library.
-libraryFiles
- :: NamedComponent
- -> Library
- -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
-libraryFiles component lib = do
- resolveComponentFiles component build names
- where
- build = libBuildInfo lib
- names = bnames ++ exposed
- exposed = map DotCabalModule (exposedModules lib)
- bnames = map DotCabalModule (otherModules build)
-
--- | Get all files referenced by the component.
-resolveComponentFiles
- :: NamedComponent
- -> BuildInfo
- -> [DotCabalDescriptor]
- -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
-resolveComponentFiles component build names = do
- dirs <- mapMaybeM (resolveDirOrWarn . getSymbolicPath) (hsSourceDirs build)
- dir <- asks (parent . ctxFile)
- agdirs <- autogenDirs
- (modules,files,warnings) <-
- resolveFilesAndDeps
- component
- ((if null dirs then [dir] else dirs) ++ agdirs)
- names
- cfiles <- buildOtherSources build
- return (modules, files <> cfiles, warnings)
- where
- autogenDirs = do
- cabalVer <- asks ctxCabalVer
- distDir <- asks ctxDistDir
- let compDir = componentAutogenDir cabalVer component distDir
- pkgDir = maybeToList $ packageAutogenDir cabalVer distDir
- filterM doesDirExist $ compDir : pkgDir
-
--- | Get all C sources and extra source files in a build.
-buildOtherSources :: BuildInfo -> RIO Ctx [DotCabalPath]
-buildOtherSources build = do
- cwd <- liftIO getCurrentDir
- dir <- asks (parent . ctxFile)
- file <- asks ctxFile
- let resolveDirFiles files toCabalPath =
- forMaybeM files $ \fp -> do
- result <- resolveDirFile dir fp
- case result of
- Nothing -> do
- warnMissingFile "File" cwd fp file
- return Nothing
- Just p -> return $ Just (toCabalPath p)
- csources <- resolveDirFiles (cSources build) DotCabalCFilePath
- jsources <- resolveDirFiles (targetJsSources build) DotCabalFilePath
- return (csources <> jsources)
-
--- | Get the target's JS sources.
-targetJsSources :: BuildInfo -> [FilePath]
-targetJsSources = jsSources
-
-- | A pair of package descriptions: one which modified the buildable
-- values of test suites and benchmarks depending on whether they are
-- enabled, and one which does not.
@@ -995,298 +723,6 @@
(GHC, ACGhc vghc) -> vghc `withinRange` range
_ -> False
--- | Try to resolve the list of base names in the given directory by
--- looking for unique instances of base names applied with the given
--- extensions, plus find any of their module and TemplateHaskell
--- dependencies.
-resolveFilesAndDeps
- :: NamedComponent -- ^ Package component name
- -> [Path Abs Dir] -- ^ Directories to look in.
- -> [DotCabalDescriptor] -- ^ Base names.
- -> RIO Ctx (Map ModuleName (Path Abs File),[DotCabalPath],[PackageWarning])
-resolveFilesAndDeps component dirs names0 = do
- (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty
- warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules)
- return (foundModules, dotCabalPaths, warnings)
- where
- loop [] _ = return ([], M.empty, [])
- loop names doneModules0 = do
- resolved <- resolveFiles dirs names
- let foundFiles = mapMaybe snd resolved
- foundModules = mapMaybe toResolvedModule resolved
- missingModules = mapMaybe toMissingModule resolved
- pairs <- mapM (getDependencies component dirs) foundFiles
- let doneModules =
- S.union
- doneModules0
- (S.fromList (mapMaybe dotCabalModule names))
- moduleDeps = S.unions (map fst pairs)
- thDepFiles = concatMap snd pairs
- modulesRemaining = S.difference moduleDeps doneModules
- -- Ignore missing modules discovered as dependencies - they may
- -- have been deleted.
- (resolvedFiles, resolvedModules, _) <-
- loop (map DotCabalModule (S.toList modulesRemaining)) doneModules
- return
- ( nubOrd $ foundFiles <> map DotCabalFilePath thDepFiles <> resolvedFiles
- , M.union
- (M.fromList foundModules)
- resolvedModules
- , missingModules)
- warnUnlisted foundModules = do
- let unlistedModules =
- foundModules `M.difference`
- M.fromList (mapMaybe (fmap (, ()) . dotCabalModule) names0)
- return $
- if M.null unlistedModules
- then []
- else [ UnlistedModulesWarning
- component
- (map fst (M.toList unlistedModules))]
- warnMissing _missingModules = do
- return []
- -- TODO: bring this back - see
- -- https://github.com/commercialhaskell/stack/issues/2649
- {-
- cabalfp <- asks ctxFile
- return $
- if null missingModules
- then []
- else [ MissingModulesWarning
- cabalfp
- component
- missingModules]
- -}
- -- TODO: In usages of toResolvedModule / toMissingModule, some sort
- -- of map + partition would probably be better.
- toResolvedModule
- :: (DotCabalDescriptor, Maybe DotCabalPath)
- -> Maybe (ModuleName, Path Abs File)
- toResolvedModule (DotCabalModule mn, Just (DotCabalModulePath fp)) =
- Just (mn, fp)
- toResolvedModule _ =
- Nothing
- toMissingModule
- :: (DotCabalDescriptor, Maybe DotCabalPath)
- -> Maybe ModuleName
- toMissingModule (DotCabalModule mn, Nothing) =
- Just mn
- toMissingModule _ =
- Nothing
-
--- | Get the dependencies of a Haskell module file.
-getDependencies
- :: NamedComponent -> [Path Abs Dir] -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File])
-getDependencies component dirs dotCabalPath =
- case dotCabalPath of
- DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile
- DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile
- DotCabalFilePath{} -> return (S.empty, [])
- DotCabalCFilePath{} -> return (S.empty, [])
- where
- readResolvedHi resolvedFile = do
- dumpHIDir <- componentOutputDir component <$> asks ctxDistDir
- dir <- asks (parent . ctxFile)
- let sourceDir = fromMaybe dir $ find (`isProperPrefixOf` resolvedFile) dirs
- stripSourceDir d = stripProperPrefix d resolvedFile
- case stripSourceDir sourceDir of
- Nothing -> return (S.empty, [])
- Just fileRel -> do
- let hiPath =
- FilePath.replaceExtension
- (toFilePath (dumpHIDir fileRel))
- ".hi"
- dumpHIExists <- liftIO $ D.doesFileExist hiPath
- if dumpHIExists
- then parseHI hiPath
- else return (S.empty, [])
-
--- | Parse a .hi file into a set of modules and files.
-parseHI
- :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File])
-parseHI hiPath = do
- dir <- asks (parent . ctxFile)
- result <- liftIO $ Iface.fromFile hiPath `catchAnyDeep` \e -> pure (Left (show e))
- case result of
- Left msg -> do
- prettyStackDevL
- [ flow "Failed to decode module interface:"
- , style File $ fromString hiPath
- , flow "Decoding failure:"
- , style Error $ fromString msg
- ]
- pure (S.empty, [])
- Right iface -> do
- let moduleNames = fmap (fromString . T.unpack . decodeUtf8Lenient . fst) .
- Iface.unList . Iface.dmods . Iface.deps
- resolveFileDependency file = do
- resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile
- when (isNothing resolved) $
- prettyWarnL
- [ flow "Dependent file listed in:"
- , style File $ fromString hiPath
- , flow "does not exist:"
- , style File $ fromString file
- ]
- pure resolved
- resolveUsages = traverse (resolveFileDependency . Iface.unUsage) . Iface.unList . Iface.usage
- resolvedUsages <- catMaybes <$> resolveUsages iface
- pure (S.fromList $ moduleNames iface, resolvedUsages)
-
--- | Try to resolve the list of base names in the given directory by
--- looking for unique instances of base names applied with the given
--- extensions.
-resolveFiles
- :: [Path Abs Dir] -- ^ Directories to look in.
- -> [DotCabalDescriptor] -- ^ Base names.
- -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)]
-resolveFiles dirs names =
- forM names (\name -> liftM (name, ) (findCandidate dirs name))
-
-data CabalFileNameParseFail
- = CabalFileNameParseFail FilePath
- | CabalFileNameInvalidPackageName FilePath
- deriving (Typeable)
-
-instance Exception CabalFileNameParseFail
-instance Show CabalFileNameParseFail where
- 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
-
--- | Parse a package name from a file path.
-parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
-parsePackageNameFromFilePath fp = do
- base <- clean $ toFilePath $ filename fp
- case parsePackageName 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))
-
--- | Find a candidate for the given module-or-filename from the list
--- of directories and given extensions.
-findCandidate
- :: [Path Abs Dir]
- -> DotCabalDescriptor
- -> RIO Ctx (Maybe DotCabalPath)
-findCandidate dirs name = do
- pkg <- asks ctxFile >>= parsePackageNameFromFilePath
- customPreprocessorExts <- view $ configL . to configCustomPreprocessorExts
- let haskellPreprocessorExts = haskellDefaultPreprocessorExts ++ customPreprocessorExts
- candidates <- liftIO $ makeNameCandidates haskellPreprocessorExts
- case candidates of
- [candidate] -> return (Just (cons candidate))
- [] -> do
- case name of
- DotCabalModule mn
- | display mn /= paths_pkg pkg -> logPossibilities dirs mn
- _ -> return ()
- return Nothing
- (candidate:rest) -> do
- warnMultiple name candidate rest
- return (Just (cons candidate))
- where
- cons =
- case name of
- DotCabalModule{} -> DotCabalModulePath
- DotCabalMain{} -> DotCabalMainPath
- DotCabalFile{} -> DotCabalFilePath
- DotCabalCFile{} -> DotCabalCFilePath
- paths_pkg pkg = "Paths_" ++ packageNameString pkg
- makeNameCandidates haskellPreprocessorExts =
- liftM (nubOrd . concat) (mapM (makeDirCandidates haskellPreprocessorExts) dirs)
- makeDirCandidates :: [Text]
- -> Path Abs Dir
- -> IO [Path Abs File]
- makeDirCandidates haskellPreprocessorExts dir =
- case name of
- DotCabalMain fp -> resolveCandidate dir fp
- DotCabalFile fp -> resolveCandidate dir fp
- DotCabalCFile fp -> resolveCandidate dir fp
- DotCabalModule mn -> do
- let perExt ext =
- resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ T.unpack ext)
- withHaskellExts <- mapM perExt haskellFileExts
- withPPExts <- mapM perExt haskellPreprocessorExts
- pure $
- case (concat withHaskellExts, concat withPPExts) of
- -- If we have exactly 1 Haskell extension and exactly
- -- 1 preprocessor extension, assume the former file is
- -- generated from the latter
- --
- -- See https://github.com/commercialhaskell/stack/issues/4076
- ([_], [y]) -> [y]
-
- -- Otherwise, return everything
- (xs, ys) -> xs ++ ys
- resolveCandidate dir = fmap maybeToList . resolveDirFile dir
-
--- | Resolve file as a child of a specified directory, symlinks
--- don't get followed.
-resolveDirFile
- :: (MonadIO m, MonadThrow m)
- => Path Abs Dir -> FilePath.FilePath -> m (Maybe (Path Abs File))
-resolveDirFile x y = do
- -- The standard canonicalizePath does not work for this case
- p <- parseCollapsedAbsFile (toFilePath x FilePath. y)
- exists <- doesFileExist p
- return $ if exists then Just p else Nothing
-
--- | Warn the user that multiple candidates are available for an
--- entry, but that we picked one anyway and continued.
-warnMultiple
- :: DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx ()
-warnMultiple name candidate rest =
- -- TODO: figure out how to style 'name' and the dispOne stuff
- prettyWarnL
- [ flow "There were multiple candidates for the Cabal entry"
- , fromString . showName $ name
- , line <> bulletedList (map dispOne (candidate:rest))
- , line <> flow "picking:"
- , dispOne candidate
- ]
- where showName (DotCabalModule name') = display name'
- showName (DotCabalMain fp) = fp
- showName (DotCabalFile fp) = fp
- showName (DotCabalCFile fp) = fp
- dispOne = fromString . toFilePath
- -- TODO: figure out why dispOne can't be just `display`
- -- (remove the .hlint.yaml exception if it can be)
-
--- | Log that we couldn't find a candidate, but there are
--- possibilities for custom preprocessor extensions.
---
--- For example: .erb for a Ruby file might exist in one of the
--- directories.
-logPossibilities
- :: HasTerm env
- => [Path Abs Dir] -> ModuleName -> RIO env ()
-logPossibilities dirs mn = do
- possibilities <- liftM concat (makePossibilities mn)
- unless (null possibilities) $ prettyWarnL
- [ flow "Unable to find a known candidate for the Cabal entry"
- , (style PP.Module . fromString $ display mn) <> ","
- , flow "but did find:"
- , line <> bulletedList (map pretty possibilities)
- , flow "If you are using a custom preprocessor for this module"
- , flow "with its own file extension, consider adding the extension"
- , flow "to the 'custom-preprocessor-extensions' field in stack.yaml."
- ]
- where
- makePossibilities name =
- mapM
- (\dir ->
- do (_,files) <- listDir dir
- return
- (map
- filename
- (filter
- (isPrefixOf (display name) .
- toFilePath . filename)
- files)))
- dirs
-
-- | Path for the package's build log.
buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)
=> Package -> Maybe String -> m (Path Abs File)
@@ -1296,44 +732,7 @@
fp <- parseRelFile $ concat $
packageIdentifierString (packageIdentifier package') :
maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"]
- return $ stack relDirLogs fp
-
--- Internal helper to define resolveFileOrWarn and resolveDirOrWarn
-resolveOrWarn :: Text
- -> (Path Abs Dir -> String -> RIO Ctx (Maybe a))
- -> FilePath.FilePath
- -> RIO Ctx (Maybe a)
-resolveOrWarn subject resolver path =
- do cwd <- liftIO getCurrentDir
- file <- asks ctxFile
- dir <- asks (parent . ctxFile)
- result <- resolver dir path
- when (isNothing result) $ warnMissingFile subject cwd path file
- return result
-
-warnMissingFile :: Text -> Path Abs Dir -> FilePath -> Path Abs File -> RIO Ctx ()
-warnMissingFile subject cwd path fromFile =
- prettyWarnL
- [ fromString . T.unpack $ subject -- TODO: needs style?
- , flow "listed in"
- , maybe (pretty fromFile) pretty (stripProperPrefix cwd fromFile)
- , flow "file does not exist:"
- , style Dir . fromString $ path
- ]
-
--- | Resolve the file, if it can't be resolved, warn for the user
--- (purely to be helpful).
-resolveFileOrWarn :: FilePath.FilePath
- -> RIO Ctx (Maybe (Path Abs File))
-resolveFileOrWarn = resolveOrWarn "File" f
- where f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile
-
--- | Resolve the directory, if it can't be resolved, warn for the user
--- (purely to be helpful).
-resolveDirOrWarn :: FilePath.FilePath
- -> RIO Ctx (Maybe (Path Abs Dir))
-resolveDirOrWarn = resolveOrWarn "Directory" f
- where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir
+ pure $ stack relDirLogs fp
{- FIXME
-- | Create a 'ProjectPackage' from a directory containing a package.
@@ -1344,7 +743,7 @@
-> RIO env ProjectPackage
mkProjectPackage printWarnings dir = do
(gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
- return ProjectPackage
+ pure ProjectPackage
{ ppCabalFP = cabalfp
, ppGPD' = gpd printWarnings
, ppResolvedDir = dir
@@ -1366,7 +765,7 @@
PackageIdentifier name _ <- getPackageLocationIdent pli
run <- askRunInIO
pure (name, run $ loadCabalFileImmutable pli)
- return DepPackage
+ pure DepPackage
{ dpGPD' = gpdio
, dpLocation = pl
, dpName = name
diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs
--- a/src/Stack/PackageDump.hs
+++ b/src/Stack/PackageDump.hs
@@ -6,18 +6,17 @@
{-# LANGUAGE TupleSections #-}
module Stack.PackageDump
- ( Line
- , eachSection
- , eachPair
- , DumpPackage (..)
- , conduitDumpPackage
- , ghcPkgDump
- , ghcPkgDescribe
- , sinkMatching
- , pruneDeps
- ) where
+ ( Line
+ , eachSection
+ , eachPair
+ , DumpPackage (..)
+ , conduitDumpPackage
+ , ghcPkgDump
+ , ghcPkgDescribe
+ , sinkMatching
+ , pruneDeps
+ ) where
-import Stack.Prelude
import Data.Attoparsec.Args
import Data.Attoparsec.Text as P
import Data.Conduit
@@ -25,14 +24,41 @@
import qualified Data.Conduit.Text as CT
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified RIO.Text as T
import qualified Distribution.Text as C
-import Path.Extra (toFilePathNoTrailingSep)
+import Path.Extra ( toFilePathNoTrailingSep )
+import RIO.Process hiding ( readProcess )
+import qualified RIO.Text as T
import Stack.GhcPkg
-import Stack.Types.Config (HasCompiler (..), GhcPkgExe (..), DumpPackage (..))
+import Stack.Prelude
+import Stack.Types.Config
+ ( HasCompiler (..), GhcPkgExe (..), DumpPackage (..) )
import Stack.Types.GhcPkgId
-import RIO.Process hiding (readProcess)
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.PackageDump" module.
+data PackageDumpException
+ = MissingSingleField Text (Map Text [Line])
+ | Couldn'tParseField Text [Line]
+ deriving (Show, Typeable)
+
+instance Exception PackageDumpException where
+ displayException (MissingSingleField name values) = unlines $
+ concat
+ [ "Error: [S-4257]\n"
+ , "Expected single value for field name "
+ , show name
+ , " when parsing ghc-pkg dump output:"
+ ]
+ : map (\(k, v) -> " " ++ show (k, v)) (Map.toList values)
+ displayException (Couldn'tParseField name ls) = concat
+ [ "Error: [S-2016]\n"
+ , "Couldn't parse the field "
+ , show name
+ , " from lines: "
+ , show ls
+ , "."
+ ]
+
-- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database
ghcPkgDump
:: (HasProcessContext env, HasLogFunc env)
@@ -63,7 +89,7 @@
ghcPkgCmdArgs pkgexe@(GhcPkgExe pkgPath) cmd mpkgDbs sink = do
case reverse mpkgDbs of
(pkgDb:_) -> createDatabase pkgexe pkgDb -- TODO maybe use some retry logic instead?
- _ -> return ()
+ _ -> pure ()
-- https://github.com/haskell/process/issues/251
snd <$> sinkProcessStderrStdout (toFilePath pkgPath) args CL.sinkNull sink'
where
@@ -138,21 +164,6 @@
Just version' | version /= version' -> False
_ -> True
-data PackageDumpException
- = MissingSingleField Text (Map Text [Line])
- | Couldn'tParseField Text [Line]
- deriving Typeable
-instance Exception PackageDumpException
-instance Show PackageDumpException where
- show (MissingSingleField name values) = unlines $
- return (concat
- [ "Expected single value for field name "
- , show name
- , " when parsing ghc-pkg dump output:"
- ]) ++ map (\(k, v) -> " " ++ show (k, v)) (Map.toList values)
- show (Couldn'tParseField name ls) =
- "Couldn't parse the field " ++ show name ++ " from lines: " ++ show ls
-
-- | Convert a stream of bytes into a stream of @DumpPackage@s
conduitDumpPackage :: MonadThrow m
=> ConduitM Text DumpPackage m ()
@@ -161,14 +172,14 @@
let m = Map.fromList pairs
let parseS k =
case Map.lookup k m of
- Just [v] -> return v
+ Just [v] -> pure v
_ -> throwM $ MissingSingleField k m
-- Can't fail: if not found, same as an empty list. See:
-- https://github.com/commercialhaskell/stack/issues/182
parseM k = Map.findWithDefault [] k m
parseDepend :: MonadThrow m => Text -> m (Maybe GhcPkgId)
- parseDepend "builtin_rts" = return Nothing
+ parseDepend "builtin_rts" = pure Nothing
parseDepend bs =
liftM Just $ parseGhcPkgId bs'
where
@@ -180,7 +191,7 @@
Just x -> (x, True)
Just x -> (x, True)
case Map.lookup "id" m of
- Just ["builtin_rts"] -> return Nothing
+ Just ["builtin_rts"] -> pure Nothing
_ -> do
name <- parseS "name" >>= parsePackageNameThrowing . T.unpack
version <- parseS "version" >>= parseVersionThrowing . T.unpack
@@ -206,14 +217,14 @@
let parseQuoted key =
case mapM (P.parseOnly (argsParser NoEscaping)) val of
Left{} -> throwM (Couldn'tParseField key val)
- Right dirs -> return (concat dirs)
+ Right dirs -> pure (concat dirs)
where
val = parseM key
libDirPaths <- parseQuoted libDirKey
haddockInterfaces <- parseQuoted "haddock-interfaces"
haddockHtml <- parseQuoted "haddock-html"
- return $ Just DumpPackage
+ pure $ Just DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpPackageIdent = PackageIdentifier name version
, dpParentLibIdent = parentLib
@@ -257,12 +268,12 @@
CL.map (T.filter (/= '\r')) .| CT.lines .| start
where
- peekText = await >>= maybe (return Nothing) (\bs ->
+ peekText = await >>= maybe (pure Nothing) (\bs ->
if T.null bs
then peekText
- else leftover bs >> return (Just bs))
+ else leftover bs >> pure (Just bs))
- start = peekText >>= maybe (return ()) (const go)
+ start = peekText >>= maybe (pure ()) (const go)
go = do
x <- toConsumer $ takeWhileC (/= "---") .| inner
@@ -277,23 +288,23 @@
eachPair inner =
start
where
- start = await >>= maybe (return ()) start'
+ start = await >>= maybe (pure ()) start'
start' bs1 =
toConsumer (valSrc .| inner key) >>= yield >> start
where
(key, bs2) = T.break (== ':') bs1
(spaces, bs3) = T.span (== ' ') $ T.drop 1 bs2
- indent = T.length key + 1 + T.length spaces
+ ind = T.length key + 1 + T.length spaces
valSrc
| T.null bs3 = noIndent
- | otherwise = yield bs3 >> loopIndent indent
+ | otherwise = yield bs3 >> loopIndent ind
noIndent = do
mx <- await
case mx of
- Nothing -> return ()
+ Nothing -> pure ()
Just bs -> do
let (spaces, val) = T.span (== ' ') bs
if T.length spaces == 0
@@ -305,7 +316,7 @@
loopIndent i =
loop
where
- loop = await >>= maybe (return ()) go
+ loop = await >>= maybe (pure ()) go
go bs
| T.length spaces == i && T.all (== ' ') spaces =
@@ -319,7 +330,7 @@
takeWhileC f =
loop
where
- loop = await >>= maybe (return ()) go
+ loop = await >>= maybe (pure ()) go
go x
| f x = yield x >> loop
diff --git a/src/Stack/PackageFile.hs b/src/Stack/PackageFile.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/PackageFile.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | A module which exports all package-level file-gathering logic.
+module Stack.PackageFile
+ ( packageDescModulesAndFiles
+ ) where
+
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Distribution.CabalSpecVersion ( CabalSpecVersion )
+import Distribution.ModuleName ( ModuleName )
+import Distribution.PackageDescription hiding ( FlagName )
+import Distribution.Simple.Glob ( matchDirFileGlob )
+import qualified Distribution.Types.UnqualComponentName as Cabal
+import Path as FL hiding ( replaceExtension )
+import Path.Extra
+import Path.IO hiding ( findFiles )
+import Stack.ComponentFile
+import Stack.Prelude hiding ( Display (..) )
+import Stack.Types.NamedComponent
+import Stack.Types.PackageFile
+ ( DotCabalPath (..), GetPackageFileContext (..)
+ , PackageWarning (..)
+ )
+import qualified System.FilePath as FilePath
+import System.IO.Error ( isUserError )
+
+-- | Resolve the file, if it can't be resolved, warn for the user
+-- (purely to be helpful).
+resolveFileOrWarn :: FilePath.FilePath
+ -> RIO GetPackageFileContext (Maybe (Path Abs File))
+resolveFileOrWarn = resolveOrWarn "File" f
+ where
+ f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile
+
+-- | Get all files referenced by the package.
+packageDescModulesAndFiles
+ :: PackageDescription
+ -> RIO
+ GetPackageFileContext
+ ( Map NamedComponent (Map ModuleName (Path Abs File))
+ , Map NamedComponent [DotCabalPath]
+ , Set (Path Abs File)
+ , [PackageWarning]
+ )
+packageDescModulesAndFiles pkg = do
+ (libraryMods, libDotCabalFiles, libWarnings) <-
+ maybe
+ (pure (M.empty, M.empty, []))
+ (asModuleAndFileMap libComponent libraryFiles)
+ (library pkg)
+ (subLibrariesMods, subLibDotCabalFiles, subLibWarnings) <-
+ liftM
+ foldTuples
+ ( mapM
+ (asModuleAndFileMap internalLibComponent libraryFiles)
+ (subLibraries pkg)
+ )
+ (executableMods, exeDotCabalFiles, exeWarnings) <-
+ liftM
+ foldTuples
+ ( mapM
+ (asModuleAndFileMap exeComponent executableFiles)
+ (executables pkg)
+ )
+ (testMods, testDotCabalFiles, testWarnings) <-
+ liftM
+ foldTuples
+ (mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg))
+ (benchModules, benchDotCabalPaths, benchWarnings) <-
+ liftM
+ foldTuples
+ ( mapM
+ (asModuleAndFileMap benchComponent benchmarkFiles)
+ (benchmarks pkg)
+ )
+ dfiles <- resolveGlobFiles
+ (specVersion pkg)
+ ( extraSrcFiles pkg
+ ++ map (dataDir pkg FilePath.) (dataFiles pkg)
+ )
+ let modules = libraryMods <> subLibrariesMods <> executableMods <> testMods <>
+ benchModules
+ files = libDotCabalFiles <> subLibDotCabalFiles <> exeDotCabalFiles <>
+ testDotCabalFiles <> benchDotCabalPaths
+ warnings = libWarnings <> subLibWarnings <> exeWarnings <> testWarnings <>
+ benchWarnings
+ pure (modules, files, dfiles, warnings)
+ where
+ libComponent = const CLib
+ internalLibComponent =
+ CInternalLib . T.pack . maybe
+ "" Cabal.unUnqualComponentName . libraryNameString . libName
+ exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName
+ testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName
+ benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName
+ asModuleAndFileMap label f lib = do
+ (a, b, c) <- f (label lib) lib
+ pure (M.singleton (label lib) a, M.singleton (label lib) b, c)
+ foldTuples = foldl' (<>) (M.empty, M.empty, [])
+
+
+-- | Resolve globbing of files (e.g. data files) to absolute paths.
+resolveGlobFiles
+ :: CabalSpecVersion -- ^ Cabal file version
+ -> [String]
+ -> RIO GetPackageFileContext (Set (Path Abs File))
+resolveGlobFiles cabalFileVersion =
+ liftM (S.fromList . catMaybes . concat) .
+ mapM resolve
+ where
+ resolve name =
+ if '*' `elem` name
+ then explode name
+ else liftM pure (resolveFileOrWarn name)
+ explode name = do
+ dir <- asks (parent . ctxFile)
+ names <- matchDirFileGlob' (FL.toFilePath dir) name
+ mapM resolveFileOrWarn names
+ matchDirFileGlob' dir glob =
+ catch
+ (liftIO (matchDirFileGlob minBound cabalFileVersion dir glob))
+ ( \(e :: IOException) ->
+ if isUserError e
+ then do
+ prettyWarnL
+ [ flow "Wildcard does not match any files:"
+ , style File $ fromString glob
+ , line <> flow "in directory:"
+ , style Dir $ fromString dir
+ ]
+ pure []
+ else throwIO e
+ )
diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs
--- a/src/Stack/Path.hs
+++ b/src/Stack/Path.hs
@@ -5,59 +5,65 @@
-- | Handy path information.
module Stack.Path
- ( path
- , pathParser
- ) where
+ ( path
+ , pathParser
+ ) where
-import Stack.Prelude
-import Data.List (intercalate)
+import Data.List ( intercalate )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Options.Applicative as OA
-import Path
-import Path.Extra
+import Path ( (), parent )
+import Path.Extra ( toFilePathNoTrailingSep )
+import RIO.Process ( HasProcessContext (..), exeSearchPathL )
import Stack.Constants
import Stack.Constants.Config
import Stack.GhcPkg as GhcPkg
+import Stack.Prelude
import Stack.Runners
import Stack.Types.Config
import qualified System.FilePath as FP
-import RIO.PrettyPrint
-import RIO.Process (HasProcessContext (..), exeSearchPathL)
-- | Print out useful path information in a human-readable format (and
-- support others later).
path :: [Text] -> RIO Runner ()
-path keys =
- do let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys
- forM_ deprecated $ \(oldOption, newOption) -> logWarn $
- "\n" <>
- "'--" <> display oldOption <> "' will be removed in a future release.\n" <>
- "Please use '--" <> display newOption <> "' instead.\n" <>
- "\n"
- let -- filter the chosen paths in flags (keys),
- -- or show all of them if no specific paths chosen.
- goodPaths = filter
- (\(_,key,_) ->
- (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys)
- paths
- singlePath = length goodPaths == 1
- toEither (_, k, UseHaddocks p) = Left (k, p)
- toEither (_, k, WithoutHaddocks p) = Right (k, p)
- (with, without) = partitionEithers $ map toEither goodPaths
- runHaddock True $ printKeys with singlePath
- runHaddock False $ printKeys without singlePath
+path keys = do
+ let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys
+ forM_ deprecated $ \(oldOption, newOption) ->
+ logWarn $
+ "\n"
+ <> "'--"
+ <> display oldOption
+ <> "' will be removed in a future release.\n"
+ <> "Please use '--"
+ <> display newOption
+ <> "' instead.\n"
+ <> "\n"
+ let -- filter the chosen paths in flags (keys),
+ -- or show all of them if no specific paths chosen.
+ goodPaths = filter
+ ( \(_, key, _) ->
+ (null keys && key /= T.pack deprecatedStackRootOptionName)
+ || elem key keys
+ )
+ paths
+ singlePath = length goodPaths == 1
+ toEither (_, k, UseHaddocks p) = Left (k, p)
+ toEither (_, k, WithoutHaddocks p) = Right (k, p)
+ (with, without) = partitionEithers $ map toEither goodPaths
+ runHaddock True $ printKeys with singlePath
+ runHaddock False $ printKeys without singlePath
-printKeys
- :: HasEnvConfig env
+printKeys ::
+ HasEnvConfig env
=> [(Text, PathInfo -> Text)]
-> Bool
-> RIO env ()
printKeys extractors single = do
- pathInfo <- fillPathInfo
- liftIO $ forM_ extractors $ \(key, extractPath) -> do
- let prefix = if single then "" else key <> ": "
- T.putStrLn $ prefix <> extractPath pathInfo
+ pathInfo <- fillPathInfo
+ liftIO $ forM_ extractors $ \(key, extractPath) -> do
+ let prefix = if single then "" else key <> ": "
+ T.putStrLn $ prefix <> extractPath pathInfo
runHaddock :: Bool -> RIO EnvConfig () -> RIO Runner ()
runHaddock x action = local modifyConfig $
@@ -69,58 +75,60 @@
fillPathInfo :: HasEnvConfig env => RIO env PathInfo
fillPathInfo = do
- -- We must use a BuildConfig from an EnvConfig to ensure that it contains the
- -- full environment info including GHC paths etc.
- piBuildConfig <- view $ envConfigL.buildConfigL
- -- This is the modified 'bin-path',
- -- including the local GHC or MSYS if not configured to operate on
- -- global GHC.
- -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.
- -- So it's not the *minimal* override path.
- piSnapDb <- packageDatabaseDeps
- piLocalDb <- packageDatabaseLocal
- piExtraDbs <- packageDatabaseExtra
- piGlobalDb <- view $ compilerPathsL.to cpGlobalDB
- piSnapRoot <- installationRootDeps
- piLocalRoot <- installationRootLocal
- piToolsDir <- bindirCompilerTools
- piHoogleRoot <- hoogleRoot
- piDistDir <- distRelativeDir
- piHpcDir <- hpcReportDir
- piCompiler <- getCompilerPath
- return PathInfo {..}
+ -- We must use a BuildConfig from an EnvConfig to ensure that it contains the
+ -- full environment info including GHC paths etc.
+ piBuildConfig <- view $ envConfigL.buildConfigL
+ -- This is the modified 'bin-path',
+ -- including the local GHC or MSYS if not configured to operate on
+ -- global GHC.
+ -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.
+ -- So it's not the *minimal* override path.
+ piSnapDb <- packageDatabaseDeps
+ piLocalDb <- packageDatabaseLocal
+ piExtraDbs <- packageDatabaseExtra
+ piGlobalDb <- view $ compilerPathsL.to cpGlobalDB
+ piSnapRoot <- installationRootDeps
+ piLocalRoot <- installationRootLocal
+ piToolsDir <- bindirCompilerTools
+ piHoogleRoot <- hoogleRoot
+ piDistDir <- distRelativeDir
+ piHpcDir <- hpcReportDir
+ piCompiler <- getCompilerPath
+ pure PathInfo {..}
pathParser :: OA.Parser [Text]
pathParser =
- mapMaybeA
- (\(desc,name,_) ->
- OA.flag Nothing
- (Just name)
- (OA.long (T.unpack name) <>
- OA.help desc))
- paths
+ mapMaybeA
+ ( \(desc,name,_) ->
+ OA.flag Nothing
+ (Just name)
+ ( OA.long (T.unpack name)
+ <> OA.help desc
+ )
+ )
+ paths
-- | Passed to all the path printers as a source of info.
data PathInfo = PathInfo
- { piBuildConfig :: !BuildConfig
- , piSnapDb :: !(Path Abs Dir)
- , piLocalDb :: !(Path Abs Dir)
- , piGlobalDb :: !(Path Abs Dir)
- , piSnapRoot :: !(Path Abs Dir)
- , piLocalRoot :: !(Path Abs Dir)
- , piToolsDir :: !(Path Abs Dir)
- , piHoogleRoot :: !(Path Abs Dir)
- , piDistDir :: Path Rel Dir
- , piHpcDir :: !(Path Abs Dir)
- , piExtraDbs :: ![Path Abs Dir]
- , piCompiler :: !(Path Abs File)
- }
+ { piBuildConfig :: !BuildConfig
+ , piSnapDb :: !(Path Abs Dir)
+ , piLocalDb :: !(Path Abs Dir)
+ , piGlobalDb :: !(Path Abs Dir)
+ , piSnapRoot :: !(Path Abs Dir)
+ , piLocalRoot :: !(Path Abs Dir)
+ , piToolsDir :: !(Path Abs Dir)
+ , piHoogleRoot :: !(Path Abs Dir)
+ , piDistDir :: Path Rel Dir
+ , piHpcDir :: !(Path Abs Dir)
+ , piExtraDbs :: ![Path Abs Dir]
+ , piCompiler :: !(Path Abs File)
+ }
instance HasPlatform PathInfo
instance HasLogFunc PathInfo where
- logFuncL = configL.logFuncL
+ logFuncL = configL.logFuncL
instance HasRunner PathInfo where
- runnerL = configL.runnerL
+ runnerL = configL.runnerL
instance HasStylesUpdate PathInfo where
stylesUpdateL = runnerL.stylesUpdateL
instance HasTerm PathInfo where
@@ -129,11 +137,11 @@
instance HasGHCVariant PathInfo
instance HasConfig PathInfo
instance HasPantryConfig PathInfo where
- pantryConfigL = configL.pantryConfigL
+ pantryConfigL = configL.pantryConfigL
instance HasProcessContext PathInfo where
- processContextL = configL.processContextL
+ processContextL = configL.processContextL
instance HasBuildConfig PathInfo where
- buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y })
+ buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y })
. buildConfigL
data UseHaddocks a = UseHaddocks a | WithoutHaddocks a
@@ -149,86 +157,108 @@
-- removed, see #506
paths :: [(String, Text, UseHaddocks (PathInfo -> Text))]
paths =
- [ ( "Global stack root directory"
- , T.pack stackRootOptionName
- , WithoutHaddocks $ view (stackRootL.to toFilePathNoTrailingSep.to T.pack))
- , ( "Project root (derived from stack.yaml file)"
- , "project-root"
- , WithoutHaddocks $ view (projectRootL.to toFilePathNoTrailingSep.to T.pack))
- , ( "Configuration location (where the stack.yaml file is)"
- , "config-location"
- , WithoutHaddocks $ view (stackYamlL.to toFilePath.to T.pack))
- , ( "PATH environment variable"
- , "bin-path"
- , WithoutHaddocks $ T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL)
- , ( "Install location for GHC and other core tools (see 'stack ls tools' command)"
- , "programs"
- , WithoutHaddocks $ view (configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack))
- , ( "Compiler binary (e.g. ghc)"
- , "compiler-exe"
- , WithoutHaddocks $ T.pack . toFilePath . piCompiler )
- , ( "Directory containing the compiler binary (e.g. ghc)"
- , "compiler-bin"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . piCompiler )
- , ( "Directory containing binaries specific to a particular compiler (e.g. intero)"
- , "compiler-tools-bin"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piToolsDir )
- , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin (Unix-like OSs) or %APPDATA%\\local\\bin (Windows))"
- , "local-bin"
- , WithoutHaddocks $ view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack)
- , ( "Extra include directories"
- , "extra-include-dirs"
- , WithoutHaddocks $ T.intercalate ", " . map T.pack . configExtraIncludeDirs . view configL )
- , ( "Extra library directories"
- , "extra-library-dirs"
- , WithoutHaddocks $ T.intercalate ", " . map T.pack . configExtraLibDirs . view configL )
- , ( "Snapshot package database"
- , "snapshot-pkg-db"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapDb )
- , ( "Local project package database"
- , "local-pkg-db"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalDb )
- , ( "Global package database"
- , "global-pkg-db"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piGlobalDb )
- , ( "GHC_PACKAGE_PATH environment variable"
- , "ghc-package-path"
- , WithoutHaddocks $ \pi' -> mkGhcPackagePath True (piLocalDb pi') (piSnapDb pi') (piExtraDbs pi') (piGlobalDb pi'))
- , ( "Snapshot installation root"
- , "snapshot-install-root"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapRoot )
- , ( "Local project installation root"
- , "local-install-root"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalRoot )
- , ( "Snapshot documentation root"
- , "snapshot-doc-root"
- , UseHaddocks $ \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' docDirSuffix)))
- , ( "Local project documentation root"
- , "local-doc-root"
- , UseHaddocks $ \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' docDirSuffix)))
- , ( "Local project documentation root"
- , "local-hoogle-root"
- , UseHaddocks $ T.pack . toFilePathNoTrailingSep . piHoogleRoot)
- , ( "Dist work directory, relative to package directory"
- , "dist-dir"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piDistDir )
- , ( "Where HPC reports and tix files are stored"
- , "local-hpc-root"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piHpcDir )
- , ( "DEPRECATED: Use '--local-bin' instead"
- , "local-bin-path"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . configLocalBin . view configL )
- , ( "DEPRECATED: Use '--programs' instead"
- , "ghc-paths"
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL )
- , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"
- , T.pack deprecatedStackRootOptionName
- , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . view stackRootL )
- ]
+ [ ( "Global Stack root directory"
+ , T.pack stackRootOptionName
+ , WithoutHaddocks $ view (stackRootL.to toFilePathNoTrailingSep.to T.pack))
+ , ( "Global Stack configuration file"
+ , T.pack stackGlobalConfigOptionName
+ , WithoutHaddocks $ view (stackGlobalConfigL.to toFilePath.to T.pack))
+ , ( "Project root (derived from stack.yaml file)"
+ , "project-root"
+ , WithoutHaddocks $ view (projectRootL.to toFilePathNoTrailingSep.to T.pack))
+ , ( "Configuration location (where the stack.yaml file is)"
+ , "config-location"
+ , WithoutHaddocks $ view (stackYamlL.to toFilePath.to T.pack))
+ , ( "PATH environment variable"
+ , "bin-path"
+ , WithoutHaddocks $
+ T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL)
+ , ( "Install location for GHC and other core tools (see 'stack ls tools' command)"
+ , "programs"
+ , WithoutHaddocks $
+ view (configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack))
+ , ( "Compiler binary (e.g. ghc)"
+ , "compiler-exe"
+ , WithoutHaddocks $ T.pack . toFilePath . piCompiler )
+ , ( "Directory containing the compiler binary (e.g. ghc)"
+ , "compiler-bin"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . piCompiler )
+ , ( "Directory containing binaries specific to a particular compiler (e.g. intero)"
+ , "compiler-tools-bin"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piToolsDir )
+ , ( "Directory where Stack installs executables (e.g. ~/.local/bin (Unix-like OSs) or %APPDATA%\\local\\bin (Windows))"
+ , "local-bin"
+ , WithoutHaddocks $
+ view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack)
+ , ( "Extra include directories"
+ , "extra-include-dirs"
+ , WithoutHaddocks $
+ T.intercalate ", " . map T.pack . configExtraIncludeDirs . view configL )
+ , ( "Extra library directories"
+ , "extra-library-dirs"
+ , WithoutHaddocks $
+ T.intercalate ", " . map T.pack . configExtraLibDirs . view configL )
+ , ( "Snapshot package database"
+ , "snapshot-pkg-db"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapDb )
+ , ( "Local project package database"
+ , "local-pkg-db"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalDb )
+ , ( "Global package database"
+ , "global-pkg-db"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piGlobalDb )
+ , ( "GHC_PACKAGE_PATH environment variable"
+ , "ghc-package-path"
+ , WithoutHaddocks $
+ \pi' -> mkGhcPackagePath
+ True
+ (piLocalDb pi')
+ (piSnapDb pi')
+ (piExtraDbs pi')
+ (piGlobalDb pi')
+ )
+ , ( "Snapshot installation root"
+ , "snapshot-install-root"
+ , WithoutHaddocks $
+ T.pack . toFilePathNoTrailingSep . piSnapRoot )
+ , ( "Local project installation root"
+ , "local-install-root"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalRoot )
+ , ( "Snapshot documentation root"
+ , "snapshot-doc-root"
+ , UseHaddocks $
+ \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' docDirSuffix))
+ )
+ , ( "Local project documentation root"
+ , "local-doc-root"
+ , UseHaddocks $
+ \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' docDirSuffix))
+ )
+ , ( "Local project documentation root"
+ , "local-hoogle-root"
+ , UseHaddocks $ T.pack . toFilePathNoTrailingSep . piHoogleRoot)
+ , ( "Dist work directory, relative to package directory"
+ , "dist-dir"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piDistDir )
+ , ( "Where HPC reports and tix files are stored"
+ , "local-hpc-root"
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piHpcDir )
+ , ( "DEPRECATED: Use '--local-bin' instead"
+ , "local-bin-path"
+ , WithoutHaddocks $
+ T.pack . toFilePathNoTrailingSep . configLocalBin . view configL )
+ , ( "DEPRECATED: Use '--programs' instead"
+ , "ghc-paths"
+ , WithoutHaddocks $
+ T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL )
+ , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"
+ , T.pack deprecatedStackRootOptionName
+ , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . view stackRootL )
+ ]
deprecatedPathKeys :: [(Text, Text)]
deprecatedPathKeys =
- [ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName)
- , ("ghc-paths", "programs")
- , ("local-bin-path", "local-bin")
- ]
+ [ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName)
+ , ("ghc-paths", "programs")
+ , ("local-bin-path", "local-bin")
+ ]
diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs
--- a/src/Stack/Prelude.hs
+++ b/src/Stack/Prelude.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Prelude
( withSystemTempDir
@@ -15,6 +16,7 @@
, promptPassword
, promptBool
, stackProgName
+ , stackProgName'
, FirstTrue (..)
, fromFirstTrue
, defaultFirstTrue
@@ -22,44 +24,114 @@
, fromFirstFalse
, defaultFirstFalse
, writeBinaryFileAtomic
+ , bugReport
+ , bugPrettyReport
+ , blankLine
, module X
+ -- * Re-exports from the rio-pretty print package
+ , HasStylesUpdate (..)
+ , HasTerm (..)
+ , Pretty (..)
+ , PrettyException (..)
+ , PrettyRawSnapshotLocation (..)
+ , StyleDoc
+ , Style (..)
+ , StyleSpec
+ , StylesUpdate (..)
+ , (<+>)
+ , align
+ , bulletedList
+ , debugBracket
+ , defaultStyles
+ , encloseSep
+ , fillSep
+ , flow
+ , hang
+ , hcat
+ , hsep
+ , indent
+ , line
+ , logLevelToStyle
+ , mkNarrativeList
+ , parens
+ , parseStylesUpdateFromString
+ , prettyDebugL
+ , prettyError
+ , prettyErrorL
+ , prettyInfo
+ , prettyInfoL
+ , prettyInfoS
+ , prettyNote
+ , prettyWarn
+ , prettyWarnL
+ , prettyWarnS
+ , punctuate
+ , sep
+ , softbreak
+ , softline
+ , string
+ , style
+ , vsep
) where
-import RIO as X
-import RIO.File as X hiding (writeBinaryFileAtomic)
-import Data.Conduit as X (ConduitM, runConduit, (.|))
-import Path as X (Abs, Dir, File, Path, Rel,
- toFilePath)
-import Pantry as X hiding (Package (..), loadSnapshot)
-
-import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..))
-
-import qualified Path.IO
-
-import System.IO.Echo (withoutInputEcho)
-
+import Data.Monoid as X
+ ( Any (..), Endo (..), First (..), Sum (..) )
+import Data.Conduit as X ( ConduitM, runConduit, (.|) )
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
-import Data.Conduit.Process.Typed (withLoggedProcess_, createSource, byteStringInput)
-import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcessWait_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL, waitExitCode)
-
+import Data.Conduit.Process.Typed
+ ( byteStringInput, createSource, withLoggedProcess_ )
import qualified Data.Text.IO as T
+import Pantry as X hiding ( Package (..), loadSnapshot )
+import Path as X
+ ( Abs, Dir, File, Path, Rel, toFilePath )
+import qualified Path.IO
+import RIO as X
+import RIO.File as X hiding ( writeBinaryFileAtomic )
+import RIO.PrettyPrint
+ ( HasStylesUpdate (..), HasTerm (..), Pretty (..), Style (..)
+ , StyleDoc, (<+>), align, bulletedList, debugBracket
+ , encloseSep, fillSep, flow, hang, hcat, hsep, indent, line
+ , logLevelToStyle, mkNarrativeList, parens, prettyDebugL
+ , prettyError, prettyErrorL, prettyInfo, prettyInfoL
+ , prettyInfoS, prettyNote, prettyWarn, prettyWarnL
+ , prettyWarnS, punctuate, sep, softbreak, softline, string
+ , style, stylesUpdateL, useColorL, vsep
+ )
+import RIO.PrettyPrint.DefaultStyles (defaultStyles)
+import RIO.PrettyPrint.PrettyException ( PrettyException (..) )
+import RIO.PrettyPrint.StylesUpdate
+ ( StylesUpdate (..), parseStylesUpdateFromString )
+import RIO.PrettyPrint.Types ( StyleSpec )
+import RIO.Process
+ ( HasProcessContext (..), ProcessConfig, ProcessContext
+ , closed, getStderr, getStdout, proc, readProcess_, setStderr
+ , setStdin, setStdout, waitExitCode, withProcessWait_
+ , workingDirL
+ )
import qualified RIO.Text as T
+import System.IO.Echo ( withoutInputEcho )
-- | Path version
withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
-withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner
+withSystemTempDir str inner = withRunInIO $ \run ->
+ Path.IO.withSystemTempDir str $ run . inner
-- | Like `withSystemTempDir`, but the temporary directory is not deleted.
-withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
+withKeepSystemTempDir :: MonadUnliftIO m
+ => String
+ -> (Path Abs Dir -> m a)
+ -> m a
withKeepSystemTempDir str inner = withRunInIO $ \run -> do
path <- Path.IO.getTempDir
dir <- Path.IO.createTempDir path str
run $ inner dir
--- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers.
+-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to
+-- the consumers.
--
--- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ExitCodeException' if the process itself fails.
+-- Throws a 'ReadProcessException' if unsuccessful in launching, or
+-- 'ExitCodeException' if the process itself fails.
sinkProcessStderrStdout
:: forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack)
=> String -- ^ Command
@@ -120,13 +192,16 @@
-- | Use the new 'ProcessContext', but retain the working directory
-- from the parent environment.
-withProcessContext :: HasProcessContext env => ProcessContext -> RIO env a -> RIO env a
+withProcessContext :: HasProcessContext env
+ => ProcessContext
+ -> RIO env a
+ -> RIO env a
withProcessContext pcNew inner = do
pcOld <- view processContextL
let pcNew' = set workingDirL (view workingDirL pcOld) pcNew
local (set processContextL pcNew') inner
--- | Remove a trailing carriage return if present
+-- | Remove a trailing carriage pure if present
stripCR :: Text -> Text
stripCR = T.dropSuffix "\r"
@@ -152,7 +227,7 @@
password <- withoutInputEcho T.getLine
-- Since the user's newline is not echoed, one needs to be inserted.
T.putStrLn ""
- return password
+ pure password
-- | Prompt the user by sending text to stdout, and collecting a line of
-- input from stdin. If something other than "y" or "n" is entered, then
@@ -162,8 +237,8 @@
promptBool txt = liftIO $ do
input <- prompt txt
case input of
- "y" -> return True
- "n" -> return False
+ "y" -> pure True
+ "n" -> pure False
_ -> do
T.putStrLn "Please press either 'y' or 'n', and then enter."
promptBool txt
@@ -175,6 +250,9 @@
stackProgName :: String
stackProgName = "stack"
+stackProgName' :: Text
+stackProgName' = T.pack stackProgName
+
-- | Like @First Bool@, but the default is @True@.
newtype FirstTrue = FirstTrue { getFirstTrue :: Maybe Bool }
deriving (Show, Eq, Ord)
@@ -216,3 +294,45 @@
writeBinaryFileAtomic fp builder =
liftIO $
withBinaryFileAtomic (toFilePath fp) WriteMode (`hPutBuilder` builder)
+
+newtype PrettyRawSnapshotLocation
+ = PrettyRawSnapshotLocation RawSnapshotLocation
+
+instance Pretty PrettyRawSnapshotLocation where
+ pretty (PrettyRawSnapshotLocation (RSLCompiler compiler)) =
+ fromString $ T.unpack $ utf8BuilderToText $ display compiler
+ pretty (PrettyRawSnapshotLocation (RSLUrl url Nothing)) =
+ style Url (fromString $ T.unpack url)
+ pretty (PrettyRawSnapshotLocation (RSLUrl url (Just blob))) =
+ fillSep
+ [ style Url (fromString $ T.unpack url)
+ , parens $ fromString $ T.unpack $ utf8BuilderToText $ display blob
+ ]
+ pretty (PrettyRawSnapshotLocation (RSLFilePath resolved)) =
+ style File (fromString $ show $ resolvedRelative resolved)
+ pretty (PrettyRawSnapshotLocation (RSLSynonym syn)) = fromString $ show syn
+
+-- | Report a bug in Stack.
+bugReport :: String -> String -> String
+bugReport code msg =
+ "Error: " ++ code ++ "\n" ++
+ bugDeclaration ++ " " ++ msg ++ " " ++ bugRequest
+
+-- | Report a pretty bug in Stack.
+bugPrettyReport :: String -> StyleDoc -> StyleDoc
+bugPrettyReport code msg =
+ "Error:" <+> fromString code
+ <> line
+ <> flow bugDeclaration <+> msg <+> flow bugRequest
+
+-- | Bug declaration message.
+bugDeclaration :: String
+bugDeclaration = "The impossible happened!"
+
+-- | Bug report message.
+bugRequest :: String
+bugRequest = "Please report this bug at Stack's repository."
+
+-- | A \'pretty\' blank line.
+blankLine :: StyleDoc
+blankLine = line <> line
diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs
--- a/src/Stack/Runners.hs
+++ b/src/Stack/Runners.hs
@@ -10,40 +10,64 @@
-- configuration parsing. For example, we want @withConfig $
-- withConfig $ ...@ to fail.
module Stack.Runners
- ( withBuildConfig
- , withEnvConfig
- , withDefaultEnvConfig
- , withConfig
- , withGlobalProject
- , withRunnerGlobal
- , ShouldReexec (..)
- ) where
+ ( withBuildConfig
+ , withEnvConfig
+ , withDefaultEnvConfig
+ , withConfig
+ , withGlobalProject
+ , withRunnerGlobal
+ , ShouldReexec (..)
+ ) where
-import Stack.Prelude
-import RIO.Process (mkDefaultProcessContext)
-import RIO.Time (addUTCTime, getCurrentTime)
-import Stack.Build.Target(NeedTargets(..))
+import RIO.Process ( mkDefaultProcessContext )
+import RIO.Time ( addUTCTime, getCurrentTime )
+import Stack.Build.Target ( NeedTargets (..) )
import Stack.Config
import Stack.Constants
-import Stack.DefaultColorWhen (defaultColorWhen)
+import Stack.DefaultColorWhen ( defaultColorWhen )
import qualified Stack.Docker as Docker
import qualified Stack.Nix as Nix
+import Stack.Prelude
import Stack.Setup
-import Stack.Storage.User (upgradeChecksSince, logUpgradeCheck)
+import Stack.Storage.User ( upgradeChecksSince, logUpgradeCheck )
import Stack.Types.Config
-import Stack.Types.Docker (dockerEnable)
-import Stack.Types.Nix (nixEnable)
-import Stack.Types.Version (stackMinorVersion, minorVersion)
-import System.Console.ANSI (hSupportsANSIWithoutEmulation)
-import System.Terminal (getTerminalWidth)
+import Stack.Types.Docker ( dockerEnable )
+import Stack.Types.Nix ( nixEnable )
+import Stack.Types.Version ( stackMinorVersion, minorVersion )
+import System.Console.ANSI ( hSupportsANSIWithoutEmulation )
+import System.Terminal ( getTerminalWidth )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Runners" module.
+data RunnersException
+ = CommandInvalid
+ | DockerAndNixInvalid
+ | NixWithinDockerInvalid
+ | DockerWithinNixInvalid
+ deriving (Show, Typeable)
+
+instance Exception RunnersException where
+ displayException CommandInvalid =
+ "Error: [S-7144]\n"
+ ++ "Cannot use this command with options which override the stack.yaml \
+ \location."
+ displayException DockerAndNixInvalid =
+ "Error: [S-8314]\n"
+ ++ "Cannot use both Docker and Nix at the same time."
+ displayException NixWithinDockerInvalid =
+ "Error: [S-8641]\n"
+ ++ "Cannot use Nix from within a Docker container."
+ displayException DockerWithinNixInvalid =
+ "Error: [S-5107]\n"
+ ++ "Cannot use Docker from within a Nix shell."
+
-- | Ensure that no project settings are used when running 'withConfig'.
withGlobalProject :: RIO Runner a -> RIO Runner a
withGlobalProject inner = do
oldSYL <- view stackYamlLocL
case oldSYL of
SYLDefault -> local (set stackYamlLocL SYLGlobalProject) inner
- _ -> throwString "Cannot use this command with options which override the stack.yaml location"
+ _ -> throwIO CommandInvalid
-- | Helper for 'withEnvConfig' which passes in some default arguments:
--
@@ -93,7 +117,10 @@
-- Catching all exceptions here, since we don't want this
-- check to ever cause Stack to stop working
shouldUpgradeCheck `catchAny` \e ->
- logError ("Error when running shouldUpgradeCheck: " <> displayShow e)
+ logError $
+ "Error: [S-7353]\n" <>
+ "Error when running shouldUpgradeCheck: " <>
+ displayShow e
case shouldReexec of
YesReexec -> reexec inner
NoReexec -> inner
@@ -105,12 +132,12 @@
nixEnable' <- asks $ nixEnable . configNix
dockerEnable' <- asks $ dockerEnable . configDocker
case (nixEnable', dockerEnable') of
- (True, True) -> throwString "Cannot use both Docker and Nix at the same time"
+ (True, True) -> throwIO DockerAndNixInvalid
(False, False) -> inner
-- Want to use Nix
(True, False) -> do
- whenM getInContainer $ throwString "Cannot use Nix from within a Docker container"
+ whenM getInContainer $ throwIO NixWithinDockerInvalid
isReexec <- view reExecL
if isReexec
then inner
@@ -118,7 +145,7 @@
-- Want to use Docker
(False, True) -> do
- whenM getInNixShell $ throwString "Cannot use Docker from within a Nix shell"
+ whenM getInNixShell $ throwIO DockerWithinNixInvalid
inContainer <- getInContainer
if inContainer
then do
@@ -136,8 +163,8 @@
maybe defaultColorWhen pure $
getFirst $ configMonoidColorWhen $ globalConfigMonoid go
useColor <- case colorWhen of
- ColorNever -> return False
- ColorAlways -> return True
+ ColorNever -> pure False
+ ColorAlways -> pure True
ColorAuto -> fromMaybe True <$>
hSupportsANSIWithoutEmulation stderr
termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
--- a/src/Stack/SDist.hs
+++ b/src/Stack/SDist.hs
@@ -8,24 +8,24 @@
-- Create a source distribution tarball
module Stack.SDist
- ( getSDistTarball
- , checkSDistTarball
- , checkSDistTarball'
- , SDistOpts (..)
- ) where
+ ( getSDistTarball
+ , checkSDistTarball
+ , checkSDistTarball'
+ , SDistOpts (..)
+ ) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
-import Control.Concurrent.Execute (ActionContext(..), Concurrency(..))
-import Stack.Prelude hiding (Display (..))
+import Control.Concurrent.Execute
+ ( ActionContext (..), Concurrency (..) )
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
-import Data.Char (toLower)
-import Data.Data (cast)
-import Data.List
+import Data.Char ( toLower )
+import Data.Data ( cast )
+import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
@@ -35,33 +35,58 @@
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock.POSIX
-import Distribution.Package (Dependency (..))
+import Distribution.Package ( Dependency (..) )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
-import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
-import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion, hasUpperBound, hasLowerBound)
+import Distribution.PackageDescription.PrettyPrint
+ ( showGenericPackageDescription )
+import Distribution.Version
+ ( simplifyVersionRange, orLaterVersion, earlierVersion
+ , hasUpperBound, hasLowerBound
+ )
import Path
-import Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir)
-import RIO.PrettyPrint
-import Stack.Build (mkBaseConfigOpts, build, buildLocalTargets)
+import Path.IO
+ hiding
+ ( getModificationTime, getPermissions, withSystemTempDir )
+import Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import Stack.Build.Execute
import Stack.Build.Installed
-import Stack.Build.Source (projectLocalPackages)
-import Stack.Types.GhcPkgId
+import Stack.Build.Source ( projectLocalPackages )
import Stack.Package
+import Stack.Prelude hiding ( Display (..) )
import Stack.SourceMap
import Stack.Types.Build
import Stack.Types.Config
+import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.SourceMap
import Stack.Types.Version
-import System.Directory (getModificationTime, getPermissions)
+import System.Directory ( getModificationTime, getPermissions )
import qualified System.FilePath as FP
--- | Special exception to throw when you want to fail because of bad results
--- of package check.
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.SDist" module.
+data SDistException
+ = CheckException (NonEmpty Check.PackageCheck)
+ | CabalFilePathsInconsistentBug (Path Abs File) (Path Abs File)
+ | ToTarPathException String
+ deriving (Show, Typeable)
+instance Exception SDistException where
+ displayException (CheckException xs) = unlines $
+ [ "Error: [S-6439]"
+ , "Package check reported the following errors:"
+ ] <> fmap show (NE.toList xs)
+ displayException (CabalFilePathsInconsistentBug cabalfp cabalfp') = concat
+ [ "Error: [S-9595]\n"
+ , "The impossible happened! Two Cabal file paths are inconsistent: "
+ , show (cabalfp, cabalfp')
+ ]
+ displayException (ToTarPathException e) =
+ "Error: [S-7875\n"
+ ++ e
+
data SDistOpts = SDistOpts
{ sdoptsDirsToWorkWith :: [String]
-- ^ Directories to package
@@ -75,17 +100,6 @@
-- ^ Where to copy the tarball
}
-newtype CheckException
- = CheckException (NonEmpty Check.PackageCheck)
- deriving (Typeable)
-
-instance Exception CheckException
-
-instance Show CheckException where
- show (CheckException xs) =
- "Package check reported the following errors:\n" ++
- (intercalate "\n" . fmap show . NE.toList $ xs)
-
-- | Given the path to a local package, creates its source
-- distribution tarball.
--
@@ -97,7 +111,7 @@
=> Maybe PvpBounds -- ^ Override Config value
-> Path Abs Dir -- ^ Path to local package
-> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString))
- -- ^ Filename, tarball contents, and option cabal file revision to upload
+ -- ^ Filename, tarball contents, and option Cabal file revision to upload
getSDistTarball mpvpBounds pkgDir = do
config <- view configL
let PvpBounds pvpBounds asRevision = fromMaybe (configPvpBounds config) mpvpBounds
@@ -110,9 +124,12 @@
eres <- buildLocalTargets nonEmptyDepTargets
case eres of
Left err ->
- logError $ "Error building custom-setup dependencies: " <> displayShow err
+ logError $
+ "Error: [S-8399]\n" <>
+ "Error building custom-setup dependencies: " <>
+ displayShow err
Right _ ->
- return ()
+ pure ()
Nothing ->
logWarn "unexpected empty custom-setup dependencies"
sourceMap <- view $ envConfigL.to envConfigSourceMap
@@ -138,8 +155,10 @@
-- for upload (both GZip.compress and Tar.write are lazy).
-- However, it seems less error prone and more predictable to read
-- everything in at once, so that's what we're doing for now:
- let tarPath isDir fp = either throwString return
- (Tar.toTarPath isDir (forceUtf8Enc (pkgId FP. fp)))
+ let tarPath isDir fp =
+ case Tar.toTarPath isDir (forceUtf8Enc (pkgId FP. fp)) of
+ Left e -> throwIO $ ToTarPathException e
+ Right tp -> pure tp
-- convert a String of proper characters to a String of bytes
-- in UTF8 encoding masquerading as characters. This is
-- necessary for tricking the tar package into proper
@@ -148,19 +167,19 @@
packWith f isDir fp = liftIO $ f (pkgFp FP. fp) =<< tarPath isDir fp
packDir = packWith Tar.packDirectoryEntry True
packFile fp
- -- This is a cabal file, we're going to tweak it, but only
+ -- This is a Cabal file, we're going to tweak it, but only
-- tweak it as a revision.
| tweakCabal && isCabalFp fp && asRevision = do
lbsIdent <- getCabalLbs pvpBounds (Just 1) cabalfp sourceMap
liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))
packWith packFileEntry False fp
- -- Same, except we'll include the cabal file in the
+ -- Same, except we'll include the Cabal file in the
-- original tarball upload.
| tweakCabal && isCabalFp fp = do
(_ident, lbs) <- getCabalLbs pvpBounds Nothing cabalfp sourceMap
currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch
tp <- liftIO $ tarPath False fp
- return $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime }
+ pure $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime }
| otherwise = packWith packFileEntry False fp
isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp
tarName = pkgId FP.<.> "tar.gz"
@@ -168,20 +187,21 @@
dirEntries <- mapM packDir (dirsFromFiles files)
fileEntries <- mapM packFile files
mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef)
- return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision)
+ pure (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision)
--- | Get the PVP bounds-enabled version of the given cabal file
+-- | Get the PVP bounds-enabled version of the given Cabal file
getCabalLbs :: HasEnvConfig env
=> PvpBoundsType
-> Maybe Int -- ^ optional revision
- -> Path Abs File -- ^ cabal file
+ -> Path Abs File -- ^ Cabal file
-> SourceMap
-> RIO env (PackageIdentifier, L.ByteString)
getCabalLbs pvpBounds mrev cabalfp sourceMap = do
- (gpdio, _name, cabalfp') <- loadCabalFilePath (parent cabalfp)
+ (gpdio, _name, cabalfp') <-
+ loadCabalFilePath (Just stackProgName') (parent cabalfp)
gpd <- liftIO $ gpdio NoPrintWarnings
- unless (cabalfp == cabalfp')
- $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp')
+ unless (cabalfp == cabalfp') $
+ throwIO $ CabalFilePathsInconsistentBug cabalfp cabalfp'
installMap <- toInstallMap sourceMap
(installedMap, _, _, _) <- getInstalled installMap
let internalPackages = Set.fromList $
@@ -210,7 +230,8 @@
-- https://github.com/haskell/cabal/issues/2353
-- https://github.com/haskell/cabal/issues/4863 (current issue)
let roundtripErrs =
- [ flow "Bug detected in Cabal library. ((parse . render . parse) === id) does not hold for the cabal file at"
+ [ flow "Bug detected in Cabal library. ((parse . render . parse) === \
+ \id) does not hold for the Cabal file at"
<+> pretty cabalfp
, ""
]
@@ -221,15 +242,18 @@
$ showGenericPackageDescription gpd
case eres of
Right roundtripped
- | roundtripped == gpd -> return ()
+ | roundtripped == gpd -> pure ()
| otherwise -> do
prettyWarn $ vsep $ roundtripErrs ++
- [ "This seems to be fixed in development versions of Cabal, but at time of writing, the fix is not in any released versions."
+ [ "This seems to be fixed in development versions of Cabal, but \
+ \at time of writing, the fix is not in any released versions."
, ""
, "Please see this GitHub issue for status:" <+> style Url "https://github.com/commercialhaskell/stack/issues/3549"
, ""
, fillSep
- [ flow "If the issue is closed as resolved, then you may be able to fix this by upgrading to a newer version of stack via"
+ [ flow "If the issue is closed as resolved, then you may be \
+ \able to fix this by upgrading to a newer version of \
+ \Stack via"
, style Shell "stack upgrade"
, flow "for latest stable version or"
, style Shell "stack upgrade --git"
@@ -237,16 +261,23 @@
]
, ""
, fillSep
- [ flow "If the issue is fixed, but updating doesn't solve the problem, please check if there are similar open issues, and if not, report a new issue to the stack issue tracker, at"
+ [ flow "If the issue is fixed, but updating doesn't solve the \
+ \problem, please check if there are similar open \
+ \issues, and if not, report a new issue to the Stack \
+ \issue tracker, at"
, style Url "https://github.com/commercialhaskell/stack/issues/new"
]
, ""
- , flow "If the issue is not fixed, feel free to leave a comment on it indicating that you would like it to be fixed."
+ , flow "If the issue is not fixed, feel free to leave a comment \
+ \on it indicating that you would like it to be fixed."
, ""
]
Left (_version, errs) -> do
prettyWarn $ vsep $ roundtripErrs ++
- [ flow "In particular, parsing the rendered cabal file is yielding a parse error. Please check if there are already issues tracking this, and if not, please report new issues to the stack and cabal issue trackers, via"
+ [ flow "In particular, parsing the rendered Cabal file is yielding a \
+ \parse error. Please check if there are already issues \
+ \tracking this, and if not, please report new issues to the \
+ \Stack and Cabal issue trackers, via"
, bulletedList
[ style Url "https://github.com/commercialhaskell/stack/issues/new"
, style Url "https://github.com/haskell/cabal/issues/new"
@@ -254,7 +285,7 @@
, flow $ "The parse error is: " ++ unlines (map show (toList errs))
, ""
]
- return
+ pure
( ident
, TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
)
@@ -302,17 +333,15 @@
readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage
readLocalPackage pkgDir = do
config <- getDefaultPackageConfig
- (gpdio, _, cabalfp) <- loadCabalFilePath pkgDir
+ (gpdio, _, cabalfp) <- loadCabalFilePath (Just stackProgName') pkgDir
gpd <- liftIO $ gpdio YesPrintWarnings
let package = resolvePackage config gpd
- return LocalPackage
+ pure LocalPackage
{ lpPackage = package
, lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file.
, 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
, lpBuildHaddocks = False
, lpForceDirty = False
@@ -323,7 +352,8 @@
, lpUnbuildable = Set.empty
}
--- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.
+-- | Returns a newline-separate list of paths, and the absolute path to the
+-- Cabal file.
getSDistFileList :: HasEnvConfig env => LocalPackage -> Map PackageIdentifier GhcPkgId -> RIO env (String, Path Abs File)
getSDistFileList lp deps =
withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do
@@ -338,7 +368,7 @@
let outFile = toFilePath tmpdir FP. "source-files-list"
cabal CloseOnException KeepTHLoading ["sdist", "--list-sources", outFile]
contents <- liftIO (S.readFile outFile)
- return (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)
+ pure (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)
where
package = lpPackage lp
ac = ActionContext Set.empty [] ConcurrencyAllowed
@@ -365,7 +395,7 @@
logWarn $
"Warning: These files are outside of the package directory, and will be omitted from the tarball: " <>
displayShow outsideDir
- return (nubOrd files)
+ pure (nubOrd files)
where
(outsideDir, files) = partitionEithers (map pathToEither fps)
pathToEither fp = maybe (Left fp) Right (normalizePath fp)
@@ -410,7 +440,7 @@
=> Path Abs Dir -- ^ Absolute path to tarball
-> RIO env ()
checkPackageInExtractedTarball pkgDir = do
- (gpdio, name, _cabalfp) <- loadCabalFilePath pkgDir
+ (gpdio, name, _cabalfp) <- loadCabalFilePath (Just stackProgName') pkgDir
gpd <- liftIO $ gpdio YesPrintWarnings
config <- getDefaultPackageConfig
let PackageDescriptionPair pkgDesc _ = resolvePackageDescription config gpd
@@ -436,12 +466,12 @@
let criticalIssue (Check.PackageBuildImpossible _) = True
criticalIssue (Check.PackageDistInexcusable _) = True
criticalIssue _ = False
- in partition criticalIssue checks
+ in List.partition criticalIssue checks
unless (null warnings) $
logWarn $ "Package check reported the following warnings:\n" <>
- mconcat (intersperse "\n" . fmap displayShow $ warnings)
+ mconcat (List.intersperse "\n" . fmap displayShow $ warnings)
case NE.nonEmpty errors of
- Nothing -> return ()
+ Nothing -> pure ()
Just ne -> throwM $ CheckException ne
buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
@@ -451,7 +481,7 @@
-- We remove the path based on the name of the package
let isPathToRemove path = do
localPackage <- readLocalPackage path
- return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild)
+ pure $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild)
pathsToKeep
<- fmap Map.fromList
$ flip filterM (Map.toList (smwProject (bcSMWanted (envConfigBuildConfig envConfig))))
@@ -506,7 +536,7 @@
perms <- getPermissions filepath
content <- S.readFile filepath
let size = fromIntegral (S.length content)
- return (Tar.simpleEntry tarpath (Tar.NormalFile (L.fromStrict content) size)) {
+ pure (Tar.simpleEntry tarpath (Tar.NormalFile (L.fromStrict content) size)) {
Tar.entryPermissions = if executable perms then Tar.executableFilePermissions
else Tar.ordinaryFilePermissions,
Tar.entryTime = mtime
@@ -515,14 +545,14 @@
getModTime :: FilePath -> IO Tar.EpochTime
getModTime path = do
t <- getModificationTime path
- return . floor . utcTimeToPOSIXSeconds $ t
+ pure . floor . utcTimeToPOSIXSeconds $ t
getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
=> m PackageConfig
getDefaultPackageConfig = do
platform <- view platformL
compilerVersion <- view actualCompilerVersionL
- return PackageConfig
+ pure PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = mempty
diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs
--- a/src/Stack/Script.hs
+++ b/src/Stack/Script.hs
@@ -6,54 +6,68 @@
( scriptCmd
) where
-import Stack.Prelude
-import Data.ByteString.Builder (toLazyByteString)
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.Conduit.List as CL
-import Data.List.Split (splitWhen)
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import Distribution.Compiler (CompilerFlavor (..))
-import Distribution.ModuleName (ModuleName)
+import Data.ByteString.Builder ( toLazyByteString )
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.Conduit.List as CL
+import Data.List.Split ( splitWhen )
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Distribution.Compiler ( CompilerFlavor (..) )
+import Distribution.ModuleName ( ModuleName )
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Types.CondTree as C
-import Distribution.Types.ModuleReexport
-import Distribution.Types.PackageName (mkPackageName)
-import Distribution.Types.VersionRange (withinRange)
-import Distribution.System (Platform (..))
+import Distribution.Types.ModuleReexport ( moduleReexportName )
+import Distribution.Types.PackageName ( mkPackageName )
+import Distribution.Types.VersionRange ( withinRange )
+import Distribution.System ( Platform (..) )
import qualified Pantry.SHA256 as SHA256
-import Path hiding (replaceExtension)
-import Path.IO
+import Path ( parent )
+import Path.IO ( getModificationTime, resolveFile' )
+import qualified RIO.Directory as Dir
+import RIO.Process ( exec, proc, readProcessStdout_, withWorkingDir )
+import qualified RIO.Text as T
import qualified Stack.Build
import Stack.Build.Installed
-import Stack.Constants (osIsWindows)
+import Stack.Constants ( osIsWindows )
import Stack.PackageDump
+import Stack.Prelude
import Stack.Options.ScriptParser
import Stack.Runners
-import Stack.Setup (withNewLocalBuildTargets)
-import Stack.SourceMap (getCompilerInfo, immutableLocSha)
+import Stack.Setup ( withNewLocalBuildTargets )
+import Stack.SourceMap ( getCompilerInfo, immutableLocSha )
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.SourceMap
-import System.FilePath (dropExtension, replaceExtension)
-import qualified RIO.Directory as Dir
-import RIO.Process
-import qualified RIO.Text as T
+import System.FilePath ( dropExtension, replaceExtension )
-data StackScriptException
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Script" module.
+data ScriptException
= MutableDependenciesForScript [PackageName]
| AmbiguousModuleName ModuleName [PackageName]
- deriving Typeable
-
-instance Exception StackScriptException
+ | ArgumentsWithNoRunInvalid
+ | NoRunWithoutCompilationInvalid
+ deriving (Show, Typeable)
-instance Show StackScriptException where
- show (MutableDependenciesForScript names) = unlines
- $ "No mutable packages are allowed in the `script` command. Mutable packages found:"
+instance Exception ScriptException where
+ displayException (MutableDependenciesForScript names) = unlines
+ $ "Error: [S-4994]"
+ : "No mutable packages are allowed in the 'script' command. Mutable \
+ \packages found:"
: map (\name -> "- " ++ packageNameString name) names
- show (AmbiguousModuleName mname pkgs) = unlines
- $ ("Module " ++ moduleNameString mname ++ " appears in multiple packages: ")
- : [unwords $ map packageNameString pkgs ]
+ displayException (AmbiguousModuleName mname pkgs) = unlines
+ $ "Error: [S-1691]"
+ : ( "Module "
+ ++ moduleNameString mname
+ ++ " appears in multiple packages: "
+ )
+ : [ unwords $ map packageNameString pkgs ]
+ displayException ArgumentsWithNoRunInvalid =
+ "Error: [S-5067]\n"
+ ++ "'--no-run' incompatible with arguments."
+ displayException NoRunWithoutCompilationInvalid =
+ "Error: [S-9469]\n"
+ ++ "'--no-run' requires either '--compile' or '--optimize'."
-- | Run a Stack Script
scriptCmd :: ScriptOpts -> RIO Runner ()
@@ -68,8 +82,8 @@
"Ignoring override stack.yaml file for script command: " <>
fromString (toFilePath fp)
SYLGlobalProject -> logError "Ignoring SYLGlobalProject for script command"
- SYLDefault -> return ()
- SYLNoProject _ -> assert False (return ())
+ SYLDefault -> pure ()
+ SYLNoProject _ -> assert False (pure ())
file <- resolveFile' $ soFile opts
@@ -90,9 +104,9 @@
case shouldRun of
YesRun -> pure ()
NoRun -> do
- unless (null $ soArgs opts) $ throwString "--no-run incompatible with arguments"
+ unless (null $ soArgs opts) $ throwIO ArgumentsWithNoRunInvalid
case shouldCompile of
- SEInterpret -> throwString "--no-run requires either --compile or --optimize"
+ SEInterpret -> throwIO NoRunWithoutCompilationInvalid
SECompile -> pure ()
SEOptimize -> pure ()
@@ -135,7 +149,7 @@
packages -> do
let targets = concatMap wordsComma packages
targets' <- mapM parsePackageNameThrowing targets
- return $ Set.fromList targets'
+ pure $ Set.fromList targets'
unless (Set.null targetsSet) $ do
-- Optimization: use the relatively cheap ghc-pkg list
@@ -206,7 +220,7 @@
getPackagesFromImports scriptFP = do
(pns, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP
if Set.null mns
- then return pns
+ then pure pns
else Set.union pns <$> getPackagesFromModuleNames mns
getPackagesFromModuleNames
@@ -218,10 +232,10 @@
pns <- forM (Set.toList mns) $ \mn -> do
pkgs <- getModulePackages mn
case pkgs of
- [] -> return Set.empty
- [pn] -> return $ Set.singleton pn
+ [] -> pure Set.empty
+ [pn] -> pure $ Set.singleton pn
_ -> throwM $ AmbiguousModuleName mn pkgs
- return $ Set.unions pns `Set.difference` blacklist
+ pure $ Set.unions pns `Set.difference` blacklist
hashSnapshot :: RIO EnvConfig SnapshotCacheHash
hashSnapshot = do
@@ -256,7 +270,7 @@
Set.fromList <$> allExposedModules gpd
-- source map construction process should guarantee unique package names
-- in these maps
- return $ globals <> installedDeps <> otherDeps
+ pure $ globals <> installedDeps <> otherDeps
dumpedPackageModules :: Map PackageName a
-> [DumpPackage]
@@ -345,7 +359,7 @@
parseImports =
fold . mapMaybe (parseLine . stripCR') . S8.lines
where
- -- Remove any carriage return character present at the end, to
+ -- Remove any carriage pure character present at the end, to
-- support Windows-style line endings (CRLF)
stripCR' bs
| S8.null bs = bs
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
--- a/src/Stack/Setup.hs
+++ b/src/Stack/Setup.hs
@@ -6,7 +6,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -28,79 +27,393 @@
, downloadStackExe
) where
-import qualified Codec.Archive.Tar as Tar
-import Conduit
-import Control.Applicative (empty)
-import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..))
-import Pantry.Internal.AesonExtended
-import qualified Data.Aeson.KeyMap as KeyMap
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Conduit.Binary as CB
-import Data.Conduit.Lazy (lazyConsume)
-import qualified Data.Conduit.List as CL
-import Data.Conduit.Process.Typed (createSource)
-import Data.Conduit.Zlib (ungzip)
-import Data.List hiding (concat, elem, maximumBy, any)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Lazy.Encoding as TL
-import qualified Data.Text.Encoding.Error as T
-import qualified Data.Yaml as Yaml
-import Distribution.System (OS, Arch (..), Platform (..))
-import qualified Distribution.System as Cabal
-import Distribution.Text (simpleParse)
-import Distribution.Types.PackageName (mkPackageName)
-import Distribution.Version (mkVersion)
-import Network.HTTP.Client (redirectCount)
-import Network.HTTP.StackClient (CheckHexDigest (..), HashCheck (..),
- getResponseBody, getResponseStatusCode, httpLbs, httpJSON,
- mkDownloadRequest, parseRequest, parseUrlThrow, setGitHubHeaders,
- setHashChecks, setLengthCheck, verifiedDownloadWithProgress, withResponse,
- setRequestMethod)
-import Network.HTTP.Simple (getResponseHeader)
-import Path hiding (fileExtension)
-import Path.CheckInstall (warnInstallSearchPathIssues)
-import Path.Extended (fileExtension)
-import Path.Extra (toFilePathNoTrailingSep)
-import Path.IO hiding (findExecutable, withSystemTempDir)
-import qualified Pantry
-import qualified RIO
-import RIO.List
-import RIO.PrettyPrint
-import RIO.Process
-import Stack.Build.Haddock (shouldHaddockDeps)
-import Stack.Build.Source (loadSourceMap, hashSourceMapData)
-import Stack.Build.Target (NeedTargets(..), parseTargets)
-import Stack.Constants
-import Stack.Constants.Config (distRelativeDir)
-import Stack.GhcPkg (createDatabase, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)
-import Stack.Prelude hiding (Display (..))
-import Stack.SourceMap
-import Stack.Setup.Installed (Tool (..), extraDirs, filterTools,
- installDir, getCompilerVersion,
- listInstalled, markInstalled, tempInstallDir,
- toolString, unmarkInstalled)
-import Stack.Storage.User (loadCompilerPaths, saveCompilerPaths)
-import Stack.Types.Build
-import Stack.Types.Compiler
-import Stack.Types.CompilerBuild
-import Stack.Types.Config
-import Stack.Types.Docker
-import Stack.Types.SourceMap
-import Stack.Types.Version
-import qualified System.Directory as D
-import System.Environment (getExecutablePath, lookupEnv)
-import System.IO.Error (isPermissionError)
-import System.FilePath (searchPathSeparator)
-import qualified System.FilePath as FP
-import System.Permissions (setFileExecutable)
-import System.Uname (getRelease)
-import Data.List.Split (splitOn)
+import qualified Codec.Archive.Tar as Tar
+import Conduit
+ ( ConduitT, await, concatMapMC, filterCE, foldMC, yield )
+import Control.Applicative ( empty )
+import Crypto.Hash ( SHA1 (..), SHA256 (..) )
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Conduit.Binary as CB
+import Data.Conduit.Lazy ( lazyConsume )
+import qualified Data.Conduit.List as CL
+import Data.Conduit.Process.Typed ( createSource )
+import Data.Conduit.Zlib ( ungzip )
+import Data.List.Split ( splitOn )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy.Encoding as TL
+import qualified Data.Text.Encoding.Error as T
+import qualified Data.Yaml as Yaml
+import Distribution.System ( Arch (..), OS, Platform (..) )
+import qualified Distribution.System as Cabal
+import Distribution.Text ( simpleParse )
+import Distribution.Types.PackageName ( mkPackageName )
+import Distribution.Version ( mkVersion )
+import Network.HTTP.Client ( redirectCount )
+import Network.HTTP.StackClient
+ ( CheckHexDigest (..), HashCheck (..), getResponseBody
+ , getResponseStatusCode, httpLbs, httpJSON
+ , mkDownloadRequest, parseRequest, parseUrlThrow
+ , setGitHubHeaders, setHashChecks, setLengthCheck
+ , verifiedDownloadWithProgress, withResponse
+ , setRequestMethod
+ )
+import Network.HTTP.Simple ( getResponseHeader )
+import Pantry.Internal.AesonExtended
+ ( Value (..), WithJSONWarnings (..), logJSONWarnings )
+import Path
+ ( (), dirname, filename, parent, parseAbsDir, parseAbsFile
+ , parseRelDir, parseRelFile, toFilePath
+ )
+import Path.CheckInstall ( warnInstallSearchPathIssues )
+import Path.Extended ( fileExtension )
+import Path.Extra ( toFilePathNoTrailingSep )
+import Path.IO hiding ( findExecutable, withSystemTempDir )
+import RIO.List
+ ( headMaybe, intercalate, intersperse, isPrefixOf
+ , maximumByMaybe, sort, sortBy, stripPrefix )
+import RIO.Process
+ ( EnvVars, HasProcessContext (..), ProcessContext
+ , augmentPath, augmentPathMap, doesExecutableExist, envVarsL
+ , exeSearchPathL, getStdout, mkProcessContext, modifyEnvVars
+ , proc, readProcess_, readProcessStdout, runProcess
+ , runProcess_, setStdout, waitExitCode, withModifyEnvVars
+ , withProcessWait, withWorkingDir, workingDirL
+ )
+import Stack.Build.Haddock ( shouldHaddockDeps )
+import Stack.Build.Source ( hashSourceMapData, loadSourceMap )
+import Stack.Build.Target ( NeedTargets (..), parseTargets )
+import Stack.Constants
+import Stack.Constants.Config ( distRelativeDir )
+import Stack.GhcPkg
+ ( createDatabase, getGlobalDB, ghcPkgPathEnvVar
+ , mkGhcPackagePath )
+import Stack.Prelude
+import Stack.SourceMap
+import Stack.Setup.Installed
+ ( Tool (..), extraDirs, filterTools, getCompilerVersion
+ , installDir, listInstalled, markInstalled, tempInstallDir
+ , toolString, unmarkInstalled
+ )
+import Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths )
+import Stack.Types.Build
+import Stack.Types.Compiler
+import Stack.Types.CompilerBuild
+import Stack.Types.Config
+import Stack.Types.Docker
+import Stack.Types.SourceMap
+import Stack.Types.Version
+import qualified System.Directory as D
+import System.Environment ( getExecutablePath, lookupEnv )
+import System.IO.Error ( isPermissionError )
+import System.FilePath ( searchPathSeparator )
+import qualified System.FilePath as FP
+import System.Permissions ( setFileExecutable )
+import System.Uname ( getRelease )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Setup" module
+data SetupException
+ = UnsupportedSetupCombo OS Arch
+ | MissingDependencies [String]
+ | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)
+ | UnknownOSKey Text
+ | GHCSanityCheckCompileFailed SomeException (Path Abs File)
+ | WantedMustBeGHC
+ | RequireCustomGHCVariant
+ | ProblemWhileDecompressing (Path Abs File)
+ | SetupInfoMissingSevenz
+ | DockerStackExeNotFound Version Text
+ | UnsupportedSetupConfiguration
+ | InvalidGhcAt (Path Abs File) SomeException
+ | MSYS2NotFound Text
+ | UnwantedCompilerVersion
+ | UnwantedArchitecture
+ | SandboxedCompilerNotFound
+ | CompilerNotFound [String]
+ | GHCInfoNotValidUTF8 UnicodeException
+ | GHCInfoNotListOfPairs
+ | GHCInfoMissingGlobalPackageDB
+ | GHCInfoMissingTargetPlatform
+ | GHCInfoTargetPlatformInvalid String
+ | CabalNotFound (Path Abs File)
+ | HadrianScriptNotFound
+ | URLInvalid String
+ | UnknownArchiveExtension String
+ | Unsupported7z
+ | TarballInvalid String
+ | TarballFileInvalid String (Path Abs File)
+ | UnknownArchiveStructure (Path Abs File)
+ | StackReleaseInfoNotFound String
+ | StackBinaryArchiveNotFound [String]
+ | WorkingDirectoryInvalidBug
+ | HadrianBindistNotFound
+ | DownloadAndInstallCompilerError
+ | StackBinaryArchiveZipUnsupportedBug
+ | StackBinaryArchiveUnsupported Text
+ | StackBinaryNotInArchive String Text
+ | FileTypeInArchiveInvalid Tar.Entry Text
+ | BinaryUpgradeOnOSUnsupported Cabal.OS
+ | BinaryUpgradeOnArchUnsupported Cabal.Arch
+ | ExistingMSYS2NotDeleted (Path Abs Dir) IOException
+ deriving (Show, Typeable)
+
+instance Exception SetupException where
+ displayException (UnsupportedSetupCombo os arch) = concat
+ [ "Error: [S-1852]\n"
+ , "I don't know how to install GHC for "
+ , show (os, arch)
+ , ", please install manually"
+ ]
+ displayException (MissingDependencies tools) = concat
+ [ "Error: [S-2126]\n"
+ , "The following executables are missing and must be installed: "
+ , intercalate ", " tools
+ ]
+ displayException (UnknownCompilerVersion oskeys wanted known) = concat
+ [ "Error: [S-9443]\n"
+ , "No setup information found for "
+ , T.unpack $ utf8BuilderToText $ display wanted
+ , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"
+ , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys))
+ , "'.\nSupported versions: "
+ , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known)))
+ ]
+ displayException (UnknownOSKey oskey) = concat
+ [ "Error: [S-6810]\n"
+ , "Unable to find installation URLs for OS key: "
+ , T.unpack oskey
+ ]
+ displayException (GHCSanityCheckCompileFailed e ghc) = concat
+ [ "Error: [S-5159]\n"
+ , "The GHC located at "
+ , toFilePath ghc
+ , " failed to compile a sanity check. Please see:\n\n"
+ , " http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"
+ , "for more information. Exception was:\n"
+ , displayException e
+ ]
+ displayException WantedMustBeGHC =
+ "Error: [S-9030]\n"
+ ++ "The wanted compiler must be GHC."
+ displayException RequireCustomGHCVariant =
+ "Error: [S-8948]\n"
+ ++ "A custom '--ghc-variant' must be specified to use '--ghc-bindist'."
+ displayException (ProblemWhileDecompressing archive) = concat
+ [ "Error: [S-2905]\n"
+ , "Problem while decompressing "
+ , toFilePath archive
+ ]
+ displayException SetupInfoMissingSevenz =
+ "Error: [S-9561]\n"
+ ++ "SetupInfo missing Sevenz EXE/DLL."
+ displayException (DockerStackExeNotFound stackVersion' osKey) = concat
+ [ "Error: [S-1457]\n"
+ , stackProgName
+ , "-"
+ , versionString stackVersion'
+ , " executable not found for "
+ , T.unpack osKey
+ , "\nUse the '"
+ , T.unpack dockerStackExeArgName
+ , "' option to specify a location."]
+ displayException UnsupportedSetupConfiguration =
+ "Error: [S-7748]\n"
+ ++ "Stack does not know how to install GHC on your system \
+ \configuration, please install manually."
+ displayException (InvalidGhcAt compiler e) = concat
+ [ "Error: [S-2476]\n"
+ , "Found an invalid compiler at "
+ , show (toFilePath compiler)
+ , ": "
+ , displayException e
+ ]
+ displayException (MSYS2NotFound osKey) = concat
+ [ "Error: [S-5308]\n"
+ , "MSYS2 not found for "
+ , T.unpack osKey
+ ]
+ displayException UnwantedCompilerVersion =
+ "Error: [S-5127]\n"
+ ++ "Not the compiler version we want."
+ displayException UnwantedArchitecture =
+ "Error: [S-1540]\n"
+ ++ "Not the architecture we want."
+ displayException SandboxedCompilerNotFound =
+ "Error: [S-9953]\n"
+ ++ "Could not find sandboxed compiler."
+ displayException (CompilerNotFound toTry) = concat
+ [ "Error: [S-4764]\n"
+ , "Could not find any of: "
+ , show toTry
+ ]
+ displayException (GHCInfoNotValidUTF8 e) = concat
+ [ "Error: [S-8668]\n"
+ , "GHC info is not valid UTF-8: "
+ , displayException e
+ ]
+ displayException GHCInfoNotListOfPairs =
+ "Error: [S-4878]\n"
+ ++ "GHC info does not parse as a list of pairs."
+ displayException GHCInfoMissingGlobalPackageDB =
+ "Error: [S-2965]\n"
+ ++ "Key 'Global Package DB' not found in GHC info."
+ displayException GHCInfoMissingTargetPlatform =
+ "Error: [S-5219]\n"
+ ++ "Key 'Target platform' not found in GHC info."
+ displayException (GHCInfoTargetPlatformInvalid targetPlatform) = concat
+ [ "Error: [S-8299]\n"
+ , "Invalid target platform in GHC info: "
+ , targetPlatform
+ ]
+ displayException (CabalNotFound compiler) = concat
+ [ "Error: [S-2574]\n"
+ , "Cabal library not found in global package database for "
+ , toFilePath compiler
+ ]
+ displayException HadrianScriptNotFound =
+ "Error: [S-1128]\n"
+ ++ "No Hadrian build script found."
+ displayException (URLInvalid url) = concat
+ [ "Error: [S-1906]\n"
+ , "`url` must be either an HTTP URL or a file path: "
+ , url
+ ]
+ displayException (UnknownArchiveExtension url) = concat
+ [ "Error: [S-1648]\n"
+ , "Unknown extension for url: "
+ , url
+ ]
+ displayException Unsupported7z =
+ "Error: [S-4509]\n"
+ ++ "Don't know how to deal with .7z files on non-Windows."
+ displayException (TarballInvalid name) = concat
+ [ "Error: [S-3158]\n"
+ , name
+ , " must be a tarball file."
+ ]
+ displayException (TarballFileInvalid name archiveFile) = concat
+ [ "Error: [S-5252]\n"
+ , "Invalid "
+ , name
+ , " filename: "
+ , show archiveFile
+ ]
+ displayException (UnknownArchiveStructure archiveFile) = concat
+ [ "Error: [S-1827]\n"
+ , "Expected a single directory within unpacked "
+ , toFilePath archiveFile
+ ]
+ displayException (StackReleaseInfoNotFound url) = concat
+ [ "Error: [S-9476]\n"
+ , "Could not get release information for Stack from: "
+ , url
+ ]
+ displayException (StackBinaryArchiveNotFound platforms) = concat
+ [ "Error: [S-4461]\n"
+ , "Unable to find binary Stack archive for platforms: "
+ , unwords platforms
+ ]
+ displayException WorkingDirectoryInvalidBug = bugReport "[S-2076]"
+ "Invalid working directory."
+ displayException HadrianBindistNotFound =
+ "Error: [S-6617]\n"
+ ++ "Can't find Hadrian-generated binary distribution."
+ displayException DownloadAndInstallCompilerError =
+ "Error: [S-7227]\n"
+ ++ "'downloadAndInstallCompiler' should not be reached with ghc-git."
+ displayException StackBinaryArchiveZipUnsupportedBug = bugReport "[S-3967]"
+ "FIXME: Handle zip files."
+ displayException (StackBinaryArchiveUnsupported archiveURL) = concat
+ [ "Error: [S-6636]\n"
+ , "Unknown archive format for Stack archive: "
+ , T.unpack archiveURL
+ ]
+ displayException (StackBinaryNotInArchive exeName url) = concat
+ [ "Error: [S-7871]\n"
+ , "Stack executable "
+ , exeName
+ , " not found in archive from "
+ , T.unpack url
+ ]
+ displayException (FileTypeInArchiveInvalid e url) = concat
+ [ "Error: [S-5046]\n"
+ , "Invalid file type for tar entry named "
+ , Tar.entryPath e
+ , " downloaded from "
+ , T.unpack url
+ ]
+ displayException (BinaryUpgradeOnOSUnsupported os) = concat
+ [ "Error: [S-4132]\n"
+ , "Binary upgrade not yet supported on OS: "
+ , show os
+ ]
+ displayException (BinaryUpgradeOnArchUnsupported arch) = concat
+ [ "Error: [S-3249]\n"
+ , "Binary upgrade not yet supported on arch: "
+ , show arch
+ ]
+ displayException (ExistingMSYS2NotDeleted destDir e) = concat
+ [ "Error: [S-4230]\n"
+ , "Could not delete existing MSYS2 directory: "
+ , toFilePath destDir
+ , "\n"
+ , displayException e
+ ]
+
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
+-- "Stack.Setup" module
+data SetupPrettyException
+ = GHCInstallFailed SomeException String String [String] (Path Abs Dir)
+ (Path Abs Dir) (Path Abs Dir)
+ deriving (Show, Typeable)
+
+instance Pretty SetupPrettyException where
+ pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =
+ "[S-7441]"
+ <> line
+ <> string (displayException ex)
+ <> line
+ <> hang 2 ( flow "Error encountered while" <+> fromString step <+> flow "GHC with"
+ <> line
+ <> style Shell (fromString (unwords (cmd : args)))
+ <> line
+ -- TODO: Figure out how to insert \ in the appropriate spots
+ -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
+ <> flow "run in" <+> pretty wd
+ )
+ <> blankLine
+ <> flow "The following directories may now contain files, but won't be \
+ \used by Stack:"
+ <> line
+ <> " -" <+> pretty tempDir
+ <> line
+ <> " -" <+> pretty destDir
+ <> blankLine
+ <> flow "For more information consider rerunning with --verbose flag"
+ <> line
+
+instance Exception SetupPrettyException
+
+-- | Type representing exceptions thrown by 'performPathChecking'
+data PerformPathCheckingException
+ = ProcessExited ExitCode String [String]
+ deriving (Show, Typeable)
+
+instance Exception PerformPathCheckingException where
+ displayException (ProcessExited ec cmd args) = concat
+ [ "Error: [S-1991]\n"
+ , "Process exited with "
+ , displayException ec
+ , ": "
+ , unwords (cmd:args)
+ ]
+
-- | Default location of the stack-setup.yaml file
defaultSetupInfoYaml :: String
defaultSetupInfoYaml =
@@ -127,70 +440,6 @@
-- ^ Alternate GHC binary distribution (requires custom GHCVariant)
}
deriving Show
-data SetupException = UnsupportedSetupCombo OS Arch
- | MissingDependencies [String]
- | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)
- | UnknownOSKey Text
- | GHCSanityCheckCompileFailed SomeException (Path Abs File)
- | WantedMustBeGHC
- | RequireCustomGHCVariant
- | ProblemWhileDecompressing (Path Abs File)
- | SetupInfoMissingSevenz
- | DockerStackExeNotFound Version Text
- | UnsupportedSetupConfiguration
- | InvalidGhcAt (Path Abs File) SomeException
- deriving Typeable
-instance Exception SetupException
-instance Show SetupException where
- show (UnsupportedSetupCombo os arch) = concat
- [ "I don't know how to install GHC for "
- , show (os, arch)
- , ", please install manually"
- ]
- show (MissingDependencies tools) =
- "The following executables are missing and must be installed: " ++
- intercalate ", " tools
- show (UnknownCompilerVersion oskeys wanted known) = concat
- [ "No setup information found for "
- , T.unpack $ utf8BuilderToText $ RIO.display wanted
- , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"
- , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys))
- , "'.\nSupported versions: "
- , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known)))
- ]
- show (UnknownOSKey oskey) =
- "Unable to find installation URLs for OS key: " ++
- T.unpack oskey
- show (GHCSanityCheckCompileFailed e ghc) = concat
- [ "The GHC located at "
- , toFilePath ghc
- , " failed to compile a sanity check. Please see:\n\n"
- , " http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"
- , "for more information. Exception was:\n"
- , show e
- ]
- show WantedMustBeGHC =
- "The wanted compiler must be GHC"
- show RequireCustomGHCVariant =
- "A custom --ghc-variant must be specified to use --ghc-bindist"
- show (ProblemWhileDecompressing archive) =
- "Problem while decompressing " ++ toFilePath archive
- show SetupInfoMissingSevenz =
- "SetupInfo missing Sevenz EXE/DLL"
- show (DockerStackExeNotFound stackVersion' osKey) = concat
- [ stackProgName
- , "-"
- , versionString stackVersion'
- , " executable not found for "
- , T.unpack osKey
- , "\nUse the '"
- , T.unpack dockerStackExeArgName
- , "' option to specify a location"]
- show UnsupportedSetupConfiguration =
- "I don't know how to install GHC on your system configuration, please install manually"
- show (InvalidGhcAt compiler e) =
- "Found an invalid compiler at " ++ show (toFilePath compiler) ++ ": " ++ displayException e
-
-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too
setupEnv :: NeedTargets
-> BuildOptsCLI
@@ -225,7 +474,7 @@
-- Modify the initial environment to include the GHC path, if a local GHC
-- is being used
menv0 <- view processContextL
- env <- either throwM (return . removeHaskellEnvVars)
+ env <- either throwM (pure . removeHaskellEnvVars)
$ augmentPathMap
(map toFilePath $ edBins ghcBin)
(view envVarsL menv0)
@@ -255,8 +504,8 @@
-- extra installation bin directories
mkDirs <- runRIO envConfig0 extraBinDirs
let mpath = Map.lookup "PATH" env
- depsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs False) mpath
- localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath
+ depsPath <- either throwM pure $ augmentPath (toFilePath <$> mkDirs False) mpath
+ localsPath <- either throwM pure $ augmentPath (toFilePath <$> mkDirs True) mpath
deps <- runRIO envConfig0 packageDatabaseDeps
runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) deps
@@ -277,7 +526,7 @@
let getProcessContext' es = do
m <- readIORef envRef
case Map.lookup es m of
- Just eo -> return eo
+ Just eo -> pure eo
Nothing -> do
eo <- mkProcessContext
$ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)
@@ -334,10 +583,10 @@
() <- atomicModifyIORef envRef $ \m' ->
(Map.insert es eo m', ())
- return eo
+ pure eo
envOverride <- liftIO $ getProcessContext' minimalEnvSettings
- return EnvConfig
+ pure EnvConfig
{ envConfigBuildConfig = bc
{ bcConfig = addIncludeLib ghcBin
$ set processContextL envOverride
@@ -387,7 +636,7 @@
env <- ask
let envg
= WithGHC cp $
- set envOverrideSettingsL (\_ -> return pc) $
+ set envOverrideSettingsL (\_ -> pure pc) $
set processContextL pc env
runRIO envg inner
@@ -411,7 +660,7 @@
}
targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual
sourceMap <- loadSourceMap targets boptsCLI smActual
- return $
+ pure $
envConfig
{envConfigSourceMap = sourceMap, envConfigBuildOptsCLI = boptsCLI}
@@ -519,7 +768,7 @@
case platform of
Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->
case getInstalledTool installed (mkPackageName "msys2") (const True) of
- Just tool -> return (Just tool)
+ Just tool -> pure (Just tool)
Nothing
| soptsInstallIfMissing sopts -> do
si <- runMemoized getSetupInfo'
@@ -527,14 +776,14 @@
config <- view configL
VersionedDownloadInfo version info <-
case Map.lookup osKey $ siMsys2 si of
- Just x -> return x
- Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey
+ Just x -> pure x
+ Nothing -> throwIO $ MSYS2NotFound osKey
let tool = Tool (PackageIdentifier (mkPackageName "msys2") version)
Just <$> downloadAndInstallTool (configLocalPrograms config) info tool (installMsys2Windows si)
| otherwise -> do
logWarn "Continuing despite missing tool: msys2"
- return Nothing
- _ -> return Nothing
+ pure Nothing
+ _ -> pure Nothing
installGhcBindist
:: HasBuildConfig env
@@ -555,7 +804,7 @@
ghcBuilds <- getGhcBuilds
forM ghcBuilds $ \ghcBuild -> do
ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
- return (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild)
+ pure (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild)
let existingCompilers = concatMap
(\(installedCompiler, compilerBuild) ->
case (installedCompiler, soptsForceReinstall sopts) of
@@ -566,7 +815,7 @@
"Found already installed GHC builds: " <>
mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers))
case existingCompilers of
- (tool, build_):_ -> return (tool, build_)
+ (tool, build_):_ -> pure (tool, build_)
[]
| soptsInstallIfMissing sopts -> do
si <- runMemoized getSetupInfo'
@@ -581,8 +830,10 @@
(mconcat
[ "To install the correct GHC into "
, T.pack (toFilePath (configLocalPrograms config))
- , ", try running \"stack setup\" or use the \"--install-ghc\" flag."
- , " To use your system GHC installation, run \"stack config set system-ghc --global true\", or use the \"--system-ghc\" flag."
+ , ", try running 'stack setup' or use the '--install-ghc' flag."
+ , " To use your system GHC installation, run \
+ \'stack config set system-ghc --global true', \
+ \or use the '--system-ghc' flag."
])
(soptsResolveMissingGHC sopts)
throwM $ CompilerVersionMismatch
@@ -615,8 +866,8 @@
let canUseCompiler cp
| soptsSkipGhcCheck sopts = pure cp
- | not $ isWanted $ cpCompilerVersion cp = throwString "Not the compiler version we want"
- | cpArch cp /= expectedArch = throwString "Not the architecture we want"
+ | not $ isWanted $ cpCompilerVersion cp = throwIO UnwantedCompilerVersion
+ | cpArch cp /= expectedArch = throwIO UnwantedArchitecture
| otherwise = pure cp
isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)
@@ -640,7 +891,7 @@
-- if the hook fails, we fall through to stacks sandboxed installation
hookGHC <- runGHCInstallHook sopts hook
maybe (pure Nothing) checkCompiler hookGHC
- | otherwise -> return Nothing
+ | otherwise -> pure Nothing
case mcp of
Nothing -> ensureSandboxedCompiler sopts getSetupInfo'
Just cp -> do
@@ -723,7 +974,7 @@
wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted
menv0 <- view processContextL
- m <- either throwM return
+ m <- either throwM pure
$ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0)
menv <- mkProcessContext (removeHaskellEnvVars m)
@@ -741,7 +992,7 @@
let loop [] = do
logError $ "Looked for sandboxed compiler named one of: " <> displayShow names
logError $ "Could not find it on the paths " <> displayShow (edBins paths)
- throwString "Could not find sandboxed compiler"
+ throwIO SandboxedCompilerNotFound
loop (x:xs) = do
res <- liftIO $ D.findExecutablesInDirectories (map toFilePath (edBins paths)) x
case res of
@@ -786,7 +1037,7 @@
findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)
findHelper getNames = do
let toTry = [dir ++ name ++ suffix | suffix <- suffixes, name <- getNames wc]
- loop [] = throwString $ "Could not find any of: " <> show toTry
+ loop [] = throwIO $ CompilerNotFound toTry
loop (guessedPath':rest) = do
guessedPath <- parseAbsFile guessedPath'
exists <- doesFileExist guessedPath
@@ -811,25 +1062,25 @@
$ fmap (toStrictBytes . fst) . readProcess_
infotext <-
case decodeUtf8' infobs of
- Left e -> throwString $ "GHC info is not valid UTF-8: " ++ show e
+ Left e -> throwIO $ GHCInfoNotValidUTF8 e
Right info -> pure info
infoPairs :: [(String, String)] <-
case readMaybe $ T.unpack infotext of
- Nothing -> throwString "GHC info does not parse as a list of pairs"
+ Nothing -> throwIO GHCInfoNotListOfPairs
Just infoPairs -> pure infoPairs
let infoMap = Map.fromList infoPairs
eglobaldb <- tryAny $
case Map.lookup "Global Package DB" infoMap of
- Nothing -> throwString "Key 'Global Package DB' not found in GHC info"
+ Nothing -> throwIO GHCInfoMissingGlobalPackageDB
Just db -> parseAbsDir db
arch <-
case Map.lookup "Target platform" infoMap of
- Nothing -> throwString "Key 'Target platform' not found in GHC info"
+ Nothing -> throwIO GHCInfoMissingTargetPlatform
Just targetPlatform ->
case simpleParse $ takeWhile (/= '-') targetPlatform of
- Nothing -> throwString $ "Invalid target platform in GHC info: " ++ show targetPlatform
+ Nothing -> throwIO $ GHCInfoTargetPlatformInvalid targetPlatform
Just arch -> pure arch
compilerVer <-
case wc of
@@ -851,10 +1102,10 @@
globalDump <- withProcessContext menv $ globalsFromDump pkg
cabalPkgVer <-
case Map.lookup cabalPackageName globalDump of
- Nothing -> throwString $ "Cabal library not found in global package database for " ++ toFilePath compiler
+ Nothing -> throwIO $ CabalNotFound compiler
Just dp -> pure $ pkgVersion $ dpPackageIdent dp
- return CompilerPaths
+ pure CompilerPaths
{ cpBuild = compilerBuild
, cpArch = arch
, cpSandboxed = isSandboxed
@@ -899,14 +1150,13 @@
-- detect when the correct GHC is already installed
if compilerTool `elem` installed
- then return (compilerTool,CompilerBuildStandard)
+ then pure (compilerTool,CompilerBuildStandard)
else do
-- clone the repository and execute the given commands
- Pantry.withRepo (Pantry.SimpleRepo url commitId RepoGit) $ do
+ withRepo (SimpleRepo url commitId RepoGit) $ do
-- withRepo is guaranteed to set workingDirL, so let's get it
mcwd <- traverse parseAbsDir =<< view workingDirL
- let cwd = fromMaybe (error "Invalid working directory") mcwd
-
+ cwd <- maybe (throwIO WorkingDirectoryInvalidBug) pure mcwd
threads <- view $ configL.to configJobs
let
hadrianArgs = fmap T.unpack
@@ -920,10 +1170,11 @@
| otherwise = hadrianScriptsPosix
foundHadrianPaths <- filterM doesFileExist $ (cwd ) <$> hadrianScripts
- hadrianPath <- maybe (throwString "No Hadrian build script found") pure $ listToMaybe foundHadrianPaths
+ hadrianPath <-
+ maybe (throwIO HadrianScriptNotFound) pure $ listToMaybe foundHadrianPaths
logSticky $ "Building GHC from source with `"
- <> RIO.display flavour
+ <> display flavour
<> "` flavour. It can take a long time (more than one hour)..."
-- We need to provide an absolute path to the script since
@@ -938,7 +1189,7 @@
isBindist p = do
extension <- fileExtension (filename p)
- return $ "ghc-" `isPrefixOf` (toFilePath (filename p))
+ pure $ "ghc-" `isPrefixOf` (toFilePath (filename p))
&& extension == ".xz"
mbindist <- filterM isBindist files
@@ -962,11 +1213,10 @@
dlinfo
compilerTool
(installer si)
- return (compilerTool, CompilerBuildStandard)
+ pure (compilerTool, CompilerBuildStandard)
_ -> do
forM_ files (logDebug . fromString . (" - " ++) . toFilePath)
- error "Can't find hadrian generated bindist"
-
+ throwIO HadrianBindistNotFound
-- | Determine which GHC builds to use depending on which shared libraries are available
-- on the system.
@@ -975,7 +1225,7 @@
config <- view configL
case configGHCBuild config of
- Just ghcBuild -> return [ghcBuild]
+ Just ghcBuild -> pure [ghcBuild]
Nothing -> determineGhcBuild
where
determineGhcBuild = do
@@ -1017,10 +1267,10 @@
checkLib lib
| libT `elem` firstWords = do
logDebug ("Found shared library " <> libD <> " in 'ldconfig -p' output")
- return True
+ pure True
| osIsWindows =
-- Cannot parse /usr/lib on Windows
- return False
+ pure False
| otherwise = do
-- This is a workaround for the fact that libtinfo.so.x doesn't appear in
-- the 'ldconfig -p' output on Arch or Slackware even when it exists.
@@ -1029,10 +1279,10 @@
matches <- filterM (doesFileExist .( lib)) usrLibDirs
case matches of
[] -> logDebug ("Did not find shared library " <> libD)
- >> return False
+ >> pure False
(path:_) -> logDebug ("Found shared library " <> libD
<> " in " <> fromString (Path.toFilePath path))
- >> return True
+ >> pure True
where
libT = T.pack (toFilePath lib)
libD = fromString (toFilePath lib)
@@ -1067,7 +1317,7 @@
logDebug $
"Potential GHC builds: " <>
mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))
- return builds
+ pure builds
-- | Encode an OpenBSD version (like "6.1") into a valid argument for
-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed
@@ -1086,7 +1336,7 @@
sysRelease =
handleIO (\e -> do
logWarn $ "Could not query OS version: " <> displayShow e
- return "")
+ pure "")
(liftIO getRelease)
-- | Ensure Docker container-compatible 'stack' executable is downloaded
@@ -1106,8 +1356,8 @@
" executable"
sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion))
platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone)
- downloadStackExe platforms sri stackExeDir False (const $ return ())
- return stackExePath
+ downloadStackExe platforms sri stackExeDir False (const $ pure ())
+ pure stackExePath
-- | Get all executables on the path that might match the wanted compiler
sourceSystemCompilers
@@ -1142,17 +1392,17 @@
locations = if null locations' then [defaultSetupInfoYaml] else locations'
resolvedSetupInfos <- mapM loadSetupInfo locations
- return (inlineSetupInfo <> mconcat resolvedSetupInfos)
+ pure (inlineSetupInfo <> mconcat resolvedSetupInfos)
where
loadSetupInfo urlOrFile = do
bs <-
case parseUrlThrow urlOrFile of
Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLbs req
Nothing -> liftIO $ S.readFile urlOrFile
- WithJSONWarnings si warnings <- either throwM return (Yaml.decodeEither' bs)
+ WithJSONWarnings si warnings <- either throwM pure (Yaml.decodeEither' bs)
when (urlOrFile /= defaultSetupInfoYaml) $
logJSONWarnings urlOrFile warnings
- return si
+ pure si
getInstalledTool :: [Tool] -- ^ already installed
-> PackageName -- ^ package to find
@@ -1178,7 +1428,7 @@
installer file at tempDir dir
markInstalled programsDir tool
liftIO $ ignoringAbsence (removeDirRecur tempDir)
- return tool
+ pure tool
downloadAndInstallCompiler :: (HasBuildConfig env, HasGHCVariant env)
=> CompilerBuild
@@ -1192,9 +1442,9 @@
(selectedVersion, downloadInfo) <- case mbindistURL of
Just bindistURL -> do
case ghcVariant of
- GHCCustom _ -> return ()
+ GHCCustom _ -> pure ()
_ -> throwM RequireCustomGHCVariant
- return (version, GHCDownloadInfo mempty mempty DownloadInfo
+ pure (version, GHCDownloadInfo mempty mempty DownloadInfo
{ downloadInfoUrl = T.pack bindistURL
, downloadInfoContentLength = Nothing
, downloadInfoSha1 = Nothing
@@ -1227,7 +1477,7 @@
downloadAndInstallCompiler _ _ WCGhcjs{} _ _ = throwIO GhcjsNotSupported
downloadAndInstallCompiler _ _ WCGhcGit{} _ _ =
- error "downloadAndInstallCompiler: shouldn't be reached with ghc-git"
+ throwIO DownloadAndInstallCompilerError
getWantedCompilerInfo :: (Ord k, MonadThrow m)
=> Text
@@ -1238,7 +1488,7 @@
-> m (k, a)
getWantedCompilerInfo key versionCheck wanted toCV pairs_ =
case mpair of
- Just pair -> return pair
+ Just pair -> pure pair
Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_))
where
mpair =
@@ -1287,7 +1537,7 @@
go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs
Just x -> throwM x
Left e' -> throwM e'
- Right r -> return (r, b)
+ Right r -> pure (r, b)
getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
=> CompilerBuild -> m Text
@@ -1295,27 +1545,27 @@
ghcVariant <- view ghcVariantL
platform <- view platformL
osKey <- getOSKey platform
- return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)
+ pure $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)
getOSKey :: (MonadThrow m)
=> Platform -> m Text
getOSKey platform =
case platform of
- Platform I386 Cabal.Linux -> return "linux32"
- Platform X86_64 Cabal.Linux -> return "linux64"
- 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 Arm Cabal.Linux -> return "linux-armv7"
- Platform AArch64 Cabal.Linux -> return "linux-aarch64"
- Platform Sparc Cabal.Linux -> return "linux-sparc"
- Platform AArch64 Cabal.OSX -> return "macosx-aarch64"
- Platform AArch64 Cabal.FreeBSD -> return "freebsd-aarch64"
+ Platform I386 Cabal.Linux -> pure "linux32"
+ Platform X86_64 Cabal.Linux -> pure "linux64"
+ Platform I386 Cabal.OSX -> pure "macosx"
+ Platform X86_64 Cabal.OSX -> pure "macosx"
+ Platform I386 Cabal.FreeBSD -> pure "freebsd32"
+ Platform X86_64 Cabal.FreeBSD -> pure "freebsd64"
+ Platform I386 Cabal.OpenBSD -> pure "openbsd32"
+ Platform X86_64 Cabal.OpenBSD -> pure "openbsd64"
+ Platform I386 Cabal.Windows -> pure "windows32"
+ Platform X86_64 Cabal.Windows -> pure "windows64"
+ Platform Arm Cabal.Linux -> pure "linux-armv7"
+ Platform AArch64 Cabal.Linux -> pure "linux-aarch64"
+ Platform Sparc Cabal.Linux -> pure "linux-sparc"
+ Platform AArch64 Cabal.OSX -> pure "macosx-aarch64"
+ Platform AArch64 Cabal.FreeBSD -> pure "freebsd-aarch64"
Platform arch os -> throwM $ UnsupportedSetupCombo os arch
downloadOrUseLocal
@@ -1326,16 +1576,15 @@
(parseUrlThrow -> Just _) -> do
ensureDir (parent destination)
chattyDownload downloadLabel downloadInfo destination
- return destination
+ pure destination
(parseAbsFile -> Just path) -> do
warnOnIgnoredChecks
- return path
+ pure path
(parseRelFile -> Just path) -> do
warnOnIgnoredChecks
root <- view projectRootL
- return (root path)
- _ ->
- throwString $ "Error: `url` must be either an HTTP URL or a file path: " ++ url
+ pure (root path)
+ _ -> throwIO $ URLInvalid url
where
url = T.unpack $ downloadInfoUrl downloadInfo
warnOnIgnoredChecks = do
@@ -1354,16 +1603,16 @@
downloadFromInfo programsDir downloadInfo tool = do
archiveType <-
case extension of
- ".tar.xz" -> return TarXz
- ".tar.bz2" -> return TarBz2
- ".tar.gz" -> return TarGz
- ".7z.exe" -> return SevenZ
- _ -> throwString $ "Error: Unknown extension for url: " ++ url
+ ".tar.xz" -> pure TarXz
+ ".tar.bz2" -> pure TarBz2
+ ".tar.gz" -> pure TarGz
+ ".7z.exe" -> pure SevenZ
+ _ -> throwIO $ UnknownArchiveExtension url
relativeFile <- parseRelFile $ toolString tool ++ extension
let destinationPath = programsDir relativeFile
localPath <- downloadOrUseLocal (T.pack (toolString tool)) downloadInfo destinationPath
- return (localPath, archiveType)
+ pure (localPath, archiveType)
where
url = T.unpack $ downloadInfoUrl downloadInfo
@@ -1397,10 +1646,10 @@
logDebug $ "menv = " <> displayShow (view envVarsL menv)
(zipTool', compOpt) <-
case archiveType of
- TarXz -> return ("xz", 'J')
- TarBz2 -> return ("bzip2", 'j')
- TarGz -> return ("gzip", 'z')
- SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows"
+ TarXz -> pure ("xz", 'J')
+ TarBz2 -> pure ("bzip2", 'j')
+ TarGz -> pure ("gzip", 'z')
+ SevenZ -> throwIO Unsupported7z
-- Slight hack: OpenBSD's tar doesn't support xz.
-- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986
let tarDep =
@@ -1424,27 +1673,9 @@
void $ withWorkingDir (toFilePath wd) $
withProcessContext menv' $
sinkProcessStderrStdout cmd args logStderr logStdout
- `catchAny` \ex -> do
- logError $ displayShow ex
- prettyError $ hang 2 (
- "Error encountered while" <+> step <+> "GHC with"
- <> line <>
- style Shell (fromString (unwords (cmd : args)))
- <> line <>
- -- TODO: Figure out how to insert \ in the appropriate spots
- -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
- "run in " <> pretty wd
- )
- <> line <> line <>
- "The following directories may now contain files, but won't be used by stack:"
- <> line <>
- " -" <+> pretty tempDir
- <> line <>
- " -" <+> pretty destDir
- <> line <> line <>
- "For more information consider rerunning with --verbose flag"
- <> line
- exitFailure
+ `catchAny` \ex ->
+ throwIO $ PrettyException
+ (GHCInstallFailed ex step cmd args wd tempDir destDir)
logSticky $
"Unpacking GHC into " <>
@@ -1482,33 +1713,33 @@
-- | Check if given processes appear to be present, throwing an exception if
-- missing.
checkDependencies :: CheckDependency env a -> RIO env a
-checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) return
+checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) pure
checkDependency :: HasProcessContext env => String -> CheckDependency env String
checkDependency tool = CheckDependency $ do
exists <- doesExecutableExist tool
- return $ if exists then Right tool else Left [tool]
+ pure $ if exists then Right tool else Left [tool]
newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a))
deriving Functor
instance Applicative (CheckDependency env) where
- pure x = CheckDependency $ return (Right x)
+ pure x = CheckDependency $ pure (Right x)
CheckDependency f <*> CheckDependency x = CheckDependency $ do
f' <- f
x' <- x
- return $
+ pure $
case (f', x') of
(Left e1, Left e2) -> Left $ e1 ++ e2
(Left e, Right _) -> Left e
(Right _, Left e) -> Left e
(Right f'', Right x'') -> Right $ f'' x''
instance Alternative (CheckDependency env) where
- empty = CheckDependency $ return $ Left []
+ empty = CheckDependency $ pure $ Left []
CheckDependency x <|> CheckDependency y = CheckDependency $ do
res1 <- x
case res1 of
Left _ -> y
- Right x' -> return $ Right x'
+ Right x' -> pure $ Right x'
installGHCWindows :: HasBuildConfig env
=> SetupInfo
@@ -1531,10 +1762,7 @@
installMsys2Windows si archiveFile archiveType _tempDir destDir = do
exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir
when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do
- logError $
- "Could not delete existing msys directory: " <>
- fromString (toFilePath destDir)
- throwM e
+ throwM $ ExistingMSYS2NotDeleted destDir e
withUnpackedTarball7z "MSYS2" si archiveFile archiveType destDir
@@ -1544,7 +1772,7 @@
-- run happens, you can just run commands as usual.
menv0 <- view processContextL
newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS"
- newEnv <- either throwM return $ augmentPathMap
+ newEnv <- either throwM pure $ augmentPathMap
[toFilePath $ destDir relDirUsr relDirBin]
(view envVarsL newEnv0)
menv <- mkProcessContext newEnv
@@ -1570,13 +1798,13 @@
withUnpackedTarball7z name si archiveFile archiveType destDir = do
suffix <-
case archiveType of
- TarXz -> return ".xz"
- TarBz2 -> return ".bz2"
- TarGz -> return ".gz"
- _ -> throwString $ name ++ " must be a tarball file"
+ TarXz -> pure ".xz"
+ TarBz2 -> pure ".bz2"
+ TarGz -> pure ".gz"
+ _ -> throwIO $ TarballInvalid name
tarFile <-
case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of
- Nothing -> throwString $ "Invalid " ++ name ++ " filename: " ++ show archiveFile
+ Nothing -> throwIO $ TarballFileInvalid name archiveFile
Just x -> parseRelFile $ T.unpack x
run7z <- setup7z si
let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"
@@ -1592,8 +1820,8 @@
expectSingleUnpackedDir archiveFile destDir = do
contents <- listDir destDir
case contents of
- ([dir], _ ) -> return dir
- _ -> throwString $ "Expected a single directory within unpacked " ++ toFilePath archiveFile
+ ([dir], _ ) -> pure dir
+ _ -> throwIO $ UnknownArchiveStructure archiveFile
-- | Download 7z as necessary, and get a function for unpacking things.
--
@@ -1610,7 +1838,7 @@
(Just sevenzDll, Just sevenzExe) -> do
_ <- downloadOrUseLocal "7z.dll" sevenzDll dllDestination
exePath <- downloadOrUseLocal "7z.exe" sevenzExe exeDestination
- withRunInIO $ \run -> return $ \outdir archive -> liftIO $ run $ do
+ withRunInIO $ \run -> pure $ \outdir archive -> liftIO $ run $ do
let cmd = toFilePath exePath
args =
[ "x"
@@ -1633,13 +1861,13 @@
.| foldMC
(\count bs -> do
let count' = count + S.length bs
- logSticky $ "Extracted " <> RIO.display count' <> " files"
+ logSticky $ "Extracted " <> display count' <> " files"
pure count'
)
0
logStickyDone $
"Extracted total of " <>
- RIO.display total <>
+ display total <>
" files from " <>
archiveDisplay
waitExitCode p
@@ -1658,11 +1886,11 @@
req <- parseUrlThrow $ T.unpack url
logSticky $
"Preparing to download " <>
- RIO.display label <>
+ display label <>
" ..."
logDebug $
"Downloading from " <>
- RIO.display url <>
+ display url <>
" to " <>
fromString (toFilePath path) <>
" ..."
@@ -1678,8 +1906,8 @@
name <>
" hash: " <>
displayBytesUtf8 bs
- return $ Just $ constr $ CheckHexDigestByteString bs
- Nothing -> return Nothing
+ pure $ Just $ constr $ CheckHexDigestByteString bs
+ Nothing -> pure Nothing
when (null hashChecks) $ logWarn $
"No sha1 or sha256 found in metadata," <>
" download hash won't be checked."
@@ -1688,7 +1916,7 @@
mkDownloadRequest req
x <- verifiedDownloadWithProgress dReq path label mtotalSize
if x
- then logStickyDone ("Downloaded " <> RIO.display label <> ".")
+ then logStickyDone ("Downloaded " <> display label <> ".")
else logStickyDone "Already downloaded."
where
mtotalSize = downloadInfoContentLength downloadInfo
@@ -1709,7 +1937,7 @@
] $ try . readProcess_
case eres of
Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc
- Right _ -> return () -- TODO check that the output of running the command is correct
+ Right _ -> pure () -- TODO check that the output of running the command is correct
-- Remove potentially confusing environment variables
removeHaskellEnvVars :: Map Text Text -> Map Text Text
@@ -1732,7 +1960,7 @@
getUtf8EnvVars compilerVer =
if getGhcVersion compilerVer >= mkVersion [7, 10, 3]
-- GHC_CHARENC supported by GHC >=7.10.3
- then return $ Map.singleton "GHC_CHARENC" "UTF-8"
+ then pure $ Map.singleton "GHC_CHARENC" "UTF-8"
else legacyLocale
where
legacyLocale = do
@@ -1742,7 +1970,7 @@
then
-- On Windows, locale is controlled by the code page, so we don't set any environment
-- variables.
- return
+ pure
Map.empty
else do
let checkedVars = map checkVar (Map.toList $ view envVarsL menv)
@@ -1758,7 +1986,7 @@
then
-- If no variables need changes and at least one "global" variable is set, no
-- changes to environment need to be made.
- return
+ pure
Map.empty
else do
-- Get a list of known locales by running @locale -a@.
@@ -1800,7 +2028,7 @@
Nothing -> Map.empty
Just fallback ->
Map.singleton "LANG" fallback
- return (Map.union changes adds)
+ pure (Map.union changes adds)
-- Determines whether an environment variable is locale-related and, if so, whether it needs to
-- be adjusted.
checkVar
@@ -1958,8 +2186,8 @@
res <- httpJSON $ setGitHubHeaders req
let code = getResponseStatusCode res
if code >= 200 && code < 300
- then return $ SRIGitHub $ getResponseBody res
- else throwString $ "Could not get release information for Stack from: " ++ url
+ then pure $ SRIGitHub $ getResponseBody res
+ else throwIO $ StackReleaseInfoNotFound url
preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)
=> m [(Bool, String)]
@@ -1967,22 +2195,22 @@
Platform arch' os' <- view platformL
(isWindows, os) <-
case os' of
- Cabal.Linux -> return (False, "linux")
- Cabal.Windows -> return (True, "windows")
- Cabal.OSX -> return (False, "osx")
- Cabal.FreeBSD -> return (False, "freebsd")
- _ -> throwM $ stringException $ "Binary upgrade not yet supported on OS: " ++ show os'
+ Cabal.Linux -> pure (False, "linux")
+ Cabal.Windows -> pure (True, "windows")
+ Cabal.OSX -> pure (False, "osx")
+ Cabal.FreeBSD -> pure (False, "freebsd")
+ _ -> throwM $ BinaryUpgradeOnOSUnsupported os'
arch <-
case arch' of
- I386 -> return "i386"
- X86_64 -> return "x86_64"
- Arm -> return "arm"
- _ -> throwM $ stringException $ "Binary upgrade not yet supported on arch: " ++ show arch'
- hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")
+ I386 -> pure "i386"
+ X86_64 -> pure "x86_64"
+ Arm -> pure "arm"
+ _ -> throwM $ BinaryUpgradeOnArchUnsupported arch'
+ hasgmp4 <- pure False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")
let suffixes
| hasgmp4 = ["-static", "-gmp4", ""]
| otherwise = ["-static", ""]
- return $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes
+ pure $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes
downloadStackExe
:: HasConfig env
@@ -1994,13 +2222,12 @@
-> RIO env ()
downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do
(isWindows, archiveURL) <-
- let loop [] = throwString $ "Unable to find binary Stack archive for platforms: "
- ++ unwords (map snd platforms0)
+ let loop [] = throwIO $ StackBinaryArchiveNotFound (map snd platforms0)
loop ((isWindows, p'):ps) = do
let p = T.pack p'
logInfo $ "Querying for archive location for platform: " <> fromString p'
case findArchive archiveInfo p of
- Just x -> return (isWindows, x)
+ Just x -> pure (isWindows, x)
Nothing -> loop ps
in loop platforms0
@@ -2014,14 +2241,16 @@
, destDir relFileStackDotTmp
)
- logInfo $ "Downloading from: " <> RIO.display archiveURL
+ logInfo $ "Downloading from: " <> display archiveURL
liftIO $ do
case () of
()
- | ".tar.gz" `T.isSuffixOf` archiveURL -> handleTarball tmpFile isWindows archiveURL
- | ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files"
- | otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL
+ | ".tar.gz" `T.isSuffixOf` archiveURL ->
+ handleTarball tmpFile isWindows archiveURL
+ | ".zip" `T.isSuffixOf` archiveURL ->
+ throwIO StackBinaryArchiveZipUnsupportedBug
+ | otherwise -> throwIO $ StackBinaryArchiveUnsupported archiveURL
logInfo "Download complete, testing executable"
@@ -2047,14 +2276,14 @@
destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir
warnInstallSearchPathIssues destDir' ["stack"]
- logInfo $ "New stack executable available at " <> fromString (toFilePath destFile)
+ logInfo $ "New Stack executable available at " <> fromString (toFilePath destFile)
when checkPath $ performPathChecking destFile currExe
`catchAny` (logError . displayShow)
where
findArchive (SRIGitHub val) pattern = do
- Object top <- return val
+ Object top <- pure val
Array assets <- KeyMap.lookup "assets" top
getFirst $ fold $ fmap (First . findMatch pattern') assets
where
@@ -2076,12 +2305,7 @@
entries <- fmap (Tar.read . LBS.fromChunks)
$ lazyConsume
$ getResponseBody res .| ungzip
- let loop Tar.Done = error $ concat
- [ "Stack executable "
- , show exeName
- , " not found in archive from "
- , T.unpack url
- ]
+ let loop Tar.Done = throwIO $ StackBinaryNotInArchive exeName url
loop (Tar.Fail e) = throwM e
loop (Tar.Next e es) =
case FP.splitPath (Tar.entryPath e) of
@@ -2091,12 +2315,7 @@
Tar.NormalFile lbs _ -> do
ensureDir destDir
LBS.writeFile (toFilePath tmpFile) lbs
- _ -> error $ concat
- [ "Invalid file type for tar entry named "
- , Tar.entryPath e
- , " downloaded from "
- , T.unpack url
- ]
+ _ -> throwIO $ FileTypeInArchiveInvalid e url
_ -> loop es
loop entries
where
@@ -2115,7 +2334,7 @@
performPathChecking newFile executablePath = do
executablePath' <- parseAbsFile executablePath
unless (toFilePath newFile == executablePath) $ do
- logInfo $ "Also copying stack executable to " <> fromString executablePath
+ logInfo $ "Also copying Stack executable to " <> fromString executablePath
tmpFile <- parseAbsFile $ executablePath ++ ".tmp"
eres <- tryIO $ do
liftIO $ copyFile newFile tmpFile
@@ -2123,7 +2342,7 @@
liftIO $ renameFile tmpFile executablePath'
logInfo "Stack executable copied successfully!"
case eres of
- Right () -> return ()
+ Right () -> pure ()
Left e
| isPermissionError e -> do
logWarn $ "Permission error when trying to copy: " <> displayShow e
@@ -2132,12 +2351,8 @@
when toSudo $ do
let run cmd args = do
ec <- proc cmd args runProcess
- when (ec /= ExitSuccess) $ error $ concat
- [ "Process exited with "
- , show ec
- , ": "
- , unwords (cmd:args)
- ]
+ when (ec /= ExitSuccess) $
+ throwIO $ ProcessExited ec cmd args
commands =
[ ("sudo",
[ "cp"
diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs
--- a/src/Stack/Setup/Installed.hs
+++ b/src/Stack/Setup/Installed.hs
@@ -21,20 +21,21 @@
, tempInstallDir
) where
-import Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
-import Data.List hiding (concat, elem, maximumBy)
+import Data.Char ( isDigit )
+import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import Distribution.System (Platform (..))
+import Distribution.System ( Platform (..) )
import qualified Distribution.System as Cabal
import Path
import Path.IO
+import RIO.Process
import Stack.Constants
+import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.Config
-import RIO.Process
data Tool
= Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512
@@ -92,9 +93,9 @@
-> m [Tool]
listInstalled programsPath = do
doesDirExist programsPath >>= \case
- False -> return []
+ False -> pure []
True -> do (_, files) <- listDir programsPath
- return $ mapMaybe toTool files
+ pure $ mapMaybe toTool files
where
toTool fp = do
x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp
@@ -122,10 +123,10 @@
let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs
x <- ACGhc <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion)
logDebug $ "GHC version is: " <> display x
- return x
+ pure x
where
versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid
- isValid c = c == '.' || ('0' <= c && c <= '9')
+ isValid c = c == '.' || isDigit c
-- | Binary directories for the given installed package
extraDirs :: HasConfig env => Tool -> RIO env ExtraDirs
@@ -133,13 +134,13 @@
config <- view configL
dir <- installDir (configLocalPrograms config) tool
case (configPlatform config, toolNameString tool) of
- (Platform _ Cabal.Windows, isGHC -> True) -> return mempty
+ (Platform _ Cabal.Windows, isGHC -> True) -> pure mempty
{ edBins =
[ dir relDirBin
, dir relDirMingw relDirBin
]
}
- (Platform Cabal.I386 Cabal.Windows, "msys2") -> return mempty
+ (Platform Cabal.I386 Cabal.Windows, "msys2") -> pure mempty
{ edBins =
[ dir relDirMingw32 relDirBin
, dir relDirUsr relDirBin
@@ -153,7 +154,7 @@
, dir relDirMingw32 relDirBin
]
}
- (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty
+ (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> pure mempty
{ edBins =
[ dir relDirMingw64 relDirBin
, dir relDirUsr relDirBin
@@ -167,16 +168,16 @@
, dir relDirMingw64 relDirBin
]
}
- (_, isGHC -> True) -> return mempty
+ (_, isGHC -> True) -> pure mempty
{ edBins =
[ dir relDirBin
]
}
(Platform _ x, toolName) -> do
logWarn $ "binDirs: unexpected OS/tool combo: " <> displayShow (x, toolName)
- return mempty
+ pure mempty
where
- isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n
+ isGHC n = "ghc" == n || "ghc-" `L.isPrefixOf` n
installDir :: (MonadReader env m, MonadThrow m)
=> Path Abs Dir
@@ -184,7 +185,7 @@
-> m (Path Abs Dir)
installDir programsDir tool = do
relativeDir <- parseRelDir $ toolString tool
- return $ programsDir relativeDir
+ pure $ programsDir relativeDir
tempInstallDir :: (MonadReader env m, MonadThrow m)
=> Path Abs Dir
@@ -192,4 +193,4 @@
-> m (Path Abs Dir)
tempInstallDir programsDir tool = do
relativeDir <- parseRelDir $ toolString tool ++ ".temp"
- return $ programsDir relativeDir
+ pure $ programsDir relativeDir
diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs
--- a/src/Stack/SetupCmd.hs
+++ b/src/Stack/SetupCmd.hs
@@ -7,13 +7,12 @@
-- | Install GHC/GHCJS and Cabal.
module Stack.SetupCmd
- ( setup
- , setupParser
- , SetupCmdOpts(..)
- ) where
+ ( setup
+ , setupParser
+ , SetupCmdOpts (..)
+ ) where
import Control.Applicative
-import Control.Monad.Reader
import qualified Data.Text as T
import qualified Options.Applicative as OA
import qualified Options.Applicative.Builder.Extra as OA
@@ -61,8 +60,8 @@
Left _ ->
case parseWantedCompiler (T.pack s) of
Left _ -> OA.readerError $ "Invalid version: " ++ s
- Right x -> return x
- Right x -> return x
+ Right x -> pure x
+ Right x -> pure x
setup
:: (HasBuildConfig env, HasGHCVariant env)
@@ -91,8 +90,8 @@
WCGhcGit{} -> "GHC (built from source)"
WCGhcjs {} -> "GHCJS"
if sandboxedGhc
- then logInfo $ "stack will use a sandboxed " <> compiler <> " it installed"
- else logInfo $ "stack will use the " <> compiler <> " on your PATH"
- logInfo "For more information on paths, see 'stack path' and 'stack exec env'"
+ then logInfo $ "Stack will use a sandboxed " <> compiler <> " it installed."
+ else logInfo $ "Stack will use the " <> compiler <> " on your PATH."
+ logInfo "For more information on paths, see 'stack path' and 'stack exec env'."
logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:"
- logInfo "stack ghc, stack ghci, stack runghc, or stack exec"
+ logInfo "'stack ghc', 'stack ghci', 'stack runghc', or 'stack exec'."
diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs
--- a/src/Stack/SourceMap.hs
+++ b/src/Stack/SourceMap.hs
@@ -3,68 +3,69 @@
{-# LANGUAGE RecordWildCards #-}
module Stack.SourceMap
- ( mkProjectPackage
- , snapToDepPackage
- , additionalDepPackage
- , loadVersion
- , getPLIVersion
- , loadGlobalHints
- , DumpedGlobalPackage
- , actualFromGhc
- , actualFromHints
- , checkFlagsUsedThrowing
- , globalCondCheck
- , pruneGlobals
- , globalsFromHints
- , getCompilerInfo
- , immutableLocSha
- , loadProjectSnapshotCandidate
- , SnapshotCandidate
- , globalsFromDump
- ) where
+ ( mkProjectPackage
+ , snapToDepPackage
+ , additionalDepPackage
+ , loadVersion
+ , getPLIVersion
+ , loadGlobalHints
+ , DumpedGlobalPackage
+ , actualFromGhc
+ , actualFromHints
+ , checkFlagsUsedThrowing
+ , globalCondCheck
+ , pruneGlobals
+ , globalsFromHints
+ , getCompilerInfo
+ , immutableLocSha
+ , loadProjectSnapshotCandidate
+ , SnapshotCandidate
+ , globalsFromDump
+ ) where
-import Data.ByteString.Builder (byteString)
+import Data.ByteString.Builder ( byteString )
import qualified Data.Conduit.List as CL
import qualified Distribution.PackageDescription as PD
-import Distribution.System (Platform(..))
+import Distribution.System ( Platform (..) )
import qualified Pantry.SHA256 as SHA256
-import qualified RIO
import qualified RIO.Map as Map
+import RIO.Process
import qualified RIO.Set as Set
-import RIO.Process
-import Stack.PackageDump
-import Stack.Prelude
-import Stack.Types.Build
-import Stack.Types.Compiler
-import Stack.Types.Config
-import Stack.Types.SourceMap
+import Stack.PackageDump
+import Stack.Prelude
+import Stack.Types.Build
+import Stack.Types.Compiler
+import Stack.Types.Config
+import Stack.Types.SourceMap
-- | Create a 'ProjectPackage' from a directory containing a package.
mkProjectPackage ::
- forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
- => PrintWarnings
- -> ResolvedPath Dir
- -> Bool
- -> RIO env ProjectPackage
+ forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => PrintWarnings
+ -> ResolvedPath Dir
+ -> Bool
+ -> RIO env ProjectPackage
mkProjectPackage printWarnings dir buildHaddocks = do
- (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
- return ProjectPackage
- { ppCabalFP = cabalfp
- , ppResolvedDir = dir
- , ppCommon = CommonPackage
- { cpGPD = gpd printWarnings
- , cpName = name
- , cpFlags = mempty
- , cpGhcOptions = mempty
- , cpCabalConfigOpts = mempty
- , cpHaddocks = buildHaddocks
- }
- }
+ (gpd, name, cabalfp) <-
+ loadCabalFilePath (Just stackProgName') (resolvedAbsolute dir)
+ pure ProjectPackage
+ { ppCabalFP = cabalfp
+ , ppResolvedDir = dir
+ , ppCommon =
+ CommonPackage
+ { cpGPD = gpd printWarnings
+ , cpName = name
+ , cpFlags = mempty
+ , cpGhcOptions = mempty
+ , cpCabalConfigOpts = mempty
+ , cpHaddocks = buildHaddocks
+ }
+ }
-- | Create a 'DepPackage' from a 'PackageLocation', from some additional
-- to a snapshot setting (extra-deps or command line)
-additionalDepPackage
- :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+additionalDepPackage ::
+ forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Bool
-> PackageLocation
-> RIO env DepPackage
@@ -72,52 +73,55 @@
(name, gpdio) <-
case pl of
PLMutable dir -> do
- (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
+ (gpdio, name, _cabalfp) <-
+ loadCabalFilePath (Just stackProgName') (resolvedAbsolute dir)
pure (name, gpdio NoPrintWarnings)
PLImmutable pli -> do
let PackageIdentifier name _ = packageLocationIdent pli
run <- askRunInIO
pure (name, run $ loadCabalFileImmutable pli)
- return DepPackage
+ pure DepPackage
{ dpLocation = pl
, dpHidden = False
, dpFromSnapshot = NotFromSnapshot
- , dpCommon = CommonPackage
- { cpGPD = gpdio
- , cpName = name
- , cpFlags = mempty
- , cpGhcOptions = mempty
- , cpCabalConfigOpts = mempty
- , cpHaddocks = buildHaddocks
- }
+ , dpCommon =
+ CommonPackage
+ { cpGPD = gpdio
+ , cpName = name
+ , cpFlags = mempty
+ , cpGhcOptions = mempty
+ , cpCabalConfigOpts = mempty
+ , cpHaddocks = buildHaddocks
+ }
}
snapToDepPackage ::
- forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
- => Bool
- -> PackageName
- -> SnapshotPackage
- -> RIO env DepPackage
+ forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => Bool
+ -> PackageName
+ -> SnapshotPackage
+ -> RIO env DepPackage
snapToDepPackage buildHaddocks name SnapshotPackage{..} = do
run <- askRunInIO
- return DepPackage
+ pure DepPackage
{ dpLocation = PLImmutable spLocation
, dpHidden = spHidden
, dpFromSnapshot = FromSnapshot
- , dpCommon = CommonPackage
- { cpGPD = run $ loadCabalFileImmutable spLocation
- , cpName = name
- , cpFlags = spFlags
- , cpGhcOptions = spGhcOptions
- , cpCabalConfigOpts = [] -- No spCabalConfigOpts, not present in snapshots
- , cpHaddocks = buildHaddocks
- }
+ , dpCommon =
+ CommonPackage
+ { cpGPD = run $ loadCabalFileImmutable spLocation
+ , cpName = name
+ , cpFlags = spFlags
+ , cpGhcOptions = spGhcOptions
+ , cpCabalConfigOpts = [] -- No spCabalConfigOpts, not present in snapshots
+ , cpHaddocks = buildHaddocks
+ }
}
loadVersion :: MonadIO m => CommonPackage -> m Version
loadVersion common = do
- gpd <- liftIO $ cpGPD common
- return (pkgVersion $ PD.package $ PD.packageDescription gpd)
+ gpd <- liftIO $ cpGPD common
+ pure (pkgVersion $ PD.package $ PD.packageDescription gpd)
getPLIVersion :: PackageLocationImmutable -> Version
getPLIVersion (PLIHackage (PackageIdentifier _ v) _ _) = v
@@ -125,119 +129,120 @@
getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm
globalsFromDump ::
- (HasLogFunc env, HasProcessContext env)
- => GhcPkgExe
- -> RIO env (Map PackageName DumpedGlobalPackage)
+ (HasLogFunc env, HasProcessContext env)
+ => GhcPkgExe
+ -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump pkgexe = do
- let pkgConduit =
- conduitDumpPackage .|
- CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)
- toGlobals ds =
- Map.fromList $ map (pkgName . dpPackageIdent &&& id) $ Map.elems ds
- toGlobals <$> ghcPkgDump pkgexe [] pkgConduit
+ let pkgConduit = conduitDumpPackage
+ .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)
+ toGlobals ds =
+ Map.fromList $ map (pkgName . dpPackageIdent &&& id) $ Map.elems ds
+ toGlobals <$> ghcPkgDump pkgexe [] pkgConduit
globalsFromHints ::
- HasConfig env
- => WantedCompiler
- -> RIO env (Map PackageName Version)
+ HasConfig env
+ => WantedCompiler
+ -> RIO env (Map PackageName Version)
globalsFromHints compiler = do
- mglobalHints <- loadGlobalHints compiler
- case mglobalHints of
- Just hints -> pure hints
- Nothing -> do
- logWarn $ "Unable to load global hints for " <> RIO.display compiler
- pure mempty
+ mglobalHints <- loadGlobalHints compiler
+ case mglobalHints of
+ Just hints -> pure hints
+ Nothing -> do
+ logWarn $ "Unable to load global hints for " <> display compiler
+ pure mempty
type DumpedGlobalPackage = DumpPackage
actualFromGhc ::
- (HasConfig env, HasCompiler env)
- => SMWanted
- -> ActualCompiler
- -> RIO env (SMActual DumpedGlobalPackage)
+ (HasConfig env, HasCompiler env)
+ => SMWanted
+ -> ActualCompiler
+ -> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc smw ac = do
- globals <- view $ compilerPathsL.to cpGlobalDump
- return
- SMActual
- { smaCompiler = ac
- , smaProject = smwProject smw
- , smaDeps = smwDeps smw
- , smaGlobal = globals
- }
+ globals <- view $ compilerPathsL.to cpGlobalDump
+ pure
+ SMActual
+ { smaCompiler = ac
+ , smaProject = smwProject smw
+ , smaDeps = smwDeps smw
+ , smaGlobal = globals
+ }
actualFromHints ::
- (HasConfig env)
- => SMWanted
- -> ActualCompiler
- -> RIO env (SMActual GlobalPackageVersion)
+ (HasConfig env)
+ => SMWanted
+ -> ActualCompiler
+ -> RIO env (SMActual GlobalPackageVersion)
actualFromHints smw ac = do
- globals <- globalsFromHints (actualToWanted ac)
- return
- SMActual
- { smaCompiler = ac
- , smaProject = smwProject smw
- , smaDeps = smwDeps smw
- , smaGlobal = Map.map GlobalPackageVersion globals
- }
+ globals <- globalsFromHints (actualToWanted ac)
+ pure
+ SMActual
+ { smaCompiler = ac
+ , smaProject = smwProject smw
+ , smaDeps = smwDeps smw
+ , smaGlobal = Map.map GlobalPackageVersion globals
+ }
-- | Simple cond check for boot packages - checks only OS and Arch
-globalCondCheck :: (HasConfig env) => RIO env (PD.ConfVar -> Either PD.ConfVar Bool)
+globalCondCheck ::
+ (HasConfig env)
+ => RIO env (PD.ConfVar
+ -> Either PD.ConfVar Bool)
globalCondCheck = do
Platform arch os <- view platformL
let condCheck (PD.OS os') = pure $ os' == os
condCheck (PD.Arch arch') = pure $ arch' == arch
condCheck c = Left c
- return condCheck
+ pure condCheck
checkFlagsUsedThrowing ::
- (MonadIO m, MonadThrow m)
- => Map PackageName (Map FlagName Bool)
- -> FlagSource
- -> Map PackageName ProjectPackage
- -> Map PackageName DepPackage
- -> m ()
+ (MonadIO m, MonadThrow m)
+ => Map PackageName (Map FlagName Bool)
+ -> FlagSource
+ -> Map PackageName ProjectPackage
+ -> Map PackageName DepPackage
+ -> m ()
checkFlagsUsedThrowing packageFlags source prjPackages deps = do
- unusedFlags <-
- forMaybeM (Map.toList packageFlags) $ \(pname, flags) ->
- getUnusedPackageFlags (pname, flags) source prjPackages deps
- unless (null unusedFlags) $
- throwM $ InvalidFlagSpecification $ Set.fromList unusedFlags
+ unusedFlags <-
+ forMaybeM (Map.toList packageFlags) $ \(pname, flags) ->
+ getUnusedPackageFlags (pname, flags) source prjPackages deps
+ unless (null unusedFlags) $
+ throwM $ InvalidFlagSpecification $ Set.fromList unusedFlags
getUnusedPackageFlags ::
- MonadIO m
- => (PackageName, Map FlagName Bool)
- -> FlagSource
- -> Map PackageName ProjectPackage
- -> Map PackageName DepPackage
- -> m (Maybe UnusedFlags)
+ MonadIO m
+ => (PackageName, Map FlagName Bool)
+ -> FlagSource
+ -> Map PackageName ProjectPackage
+ -> Map PackageName DepPackage
+ -> m (Maybe UnusedFlags)
getUnusedPackageFlags (name, userFlags) source prj deps =
- let maybeCommon =
- fmap ppCommon (Map.lookup name prj) <|>
- fmap dpCommon (Map.lookup name deps)
- in case maybeCommon of
+ let maybeCommon = fmap ppCommon (Map.lookup name prj)
+ <|> fmap dpCommon (Map.lookup name deps)
+ in case maybeCommon of
-- Package is not available as project or dependency
Nothing ->
- pure $ Just $ UFNoPackage source name
+ pure $ Just $ UFNoPackage source name
-- Package exists, let's check if the flags are defined
Just common -> do
- gpd <- liftIO $ cpGPD common
- let pname = pkgName $ PD.package $ PD.packageDescription gpd
- pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd
- unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags
- if Set.null unused
- -- All flags are defined, nothing to do
- then pure Nothing
- -- Error about the undefined flags
- else pure $ Just $ UFFlagsNotDefined source pname pkgFlags unused
+ gpd <- liftIO $ cpGPD common
+ let pname = pkgName $ PD.package $ PD.packageDescription gpd
+ pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd
+ unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags
+ if Set.null unused
+ -- All flags are defined, nothing to do
+ then pure Nothing
+ -- Error about the undefined flags
+ else pure $ Just $ UFFlagsNotDefined source pname pkgFlags unused
pruneGlobals ::
- Map PackageName DumpedGlobalPackage
- -> Set PackageName
- -> Map PackageName GlobalPackage
+ Map PackageName DumpedGlobalPackage
+ -> Set PackageName
+ -> Map PackageName GlobalPackage
pruneGlobals globals deps =
let (prunedGlobals, keptGlobals) =
partitionReplacedDependencies globals (pkgName . dpPackageIdent)
- dpGhcPkgId dpDepends deps
+ dpGhcPkgId dpDepends deps
in Map.map (GlobalPackage . pkgVersion . dpPackageIdent) keptGlobals <>
Map.map ReplacedGlobalPackage prunedGlobals
@@ -246,36 +251,36 @@
immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha = byteString . treeKeyToBs . locationTreeKey
- where
- locationTreeKey (PLIHackage _ _ tk) = tk
- locationTreeKey (PLIArchive _ pm) = pmTreeKey pm
- locationTreeKey (PLIRepo _ pm) = pmTreeKey pm
- treeKeyToBs (TreeKey (BlobKey sha _)) = SHA256.toHexBytes sha
+ where
+ locationTreeKey (PLIHackage _ _ tk) = tk
+ locationTreeKey (PLIArchive _ pm) = pmTreeKey pm
+ locationTreeKey (PLIRepo _ pm) = pmTreeKey pm
+ treeKeyToBs (TreeKey (BlobKey sha _)) = SHA256.toHexBytes sha
type SnapshotCandidate env
- = [ResolvedPath Dir] -> RIO env (SMActual GlobalPackageVersion)
+ = [ResolvedPath Dir] -> RIO env (SMActual GlobalPackageVersion)
loadProjectSnapshotCandidate ::
- (HasConfig env)
- => RawSnapshotLocation
- -> PrintWarnings
- -> Bool
- -> RIO env (SnapshotCandidate env)
+ (HasConfig env)
+ => RawSnapshotLocation
+ -> PrintWarnings
+ -> Bool
+ -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do
- debugRSL <- view rslInLogL
- (snapshot, _, _) <- loadAndCompleteSnapshotRaw' debugRSL loc Map.empty Map.empty
- deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot)
- let wc = snapshotCompiler snapshot
- globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc
- return $ \projectPackages -> do
- prjPkgs <- fmap Map.fromList . for projectPackages $ \resolved -> do
- pp <- mkProjectPackage printWarnings resolved buildHaddocks
- pure (cpName $ ppCommon pp, pp)
- compiler <- either throwIO pure $ wantedToActual
- $ snapshotCompiler snapshot
- return SMActual
- { smaCompiler = compiler
- , smaProject = prjPkgs
- , smaDeps = Map.difference deps prjPkgs
- , smaGlobal = globals
- }
+ debugRSL <- view rslInLogL
+ (snapshot, _, _) <- loadAndCompleteSnapshotRaw' debugRSL loc Map.empty Map.empty
+ deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot)
+ let wc = snapshotCompiler snapshot
+ globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc
+ pure $ \projectPackages -> do
+ prjPkgs <- fmap Map.fromList . for projectPackages $ \resolved -> do
+ pp <- mkProjectPackage printWarnings resolved buildHaddocks
+ pure (cpName $ ppCommon pp, pp)
+ compiler <- either throwIO pure $ wantedToActual $ snapshotCompiler snapshot
+ pure
+ SMActual
+ { smaCompiler = compiler
+ , smaProject = prjPkgs
+ , smaDeps = Map.difference deps prjPkgs
+ , smaGlobal = globals
+ }
diff --git a/src/Stack/Storage/Project.hs b/src/Stack/Storage/Project.hs
--- a/src/Stack/Storage/Project.hs
+++ b/src/Stack/Storage/Project.hs
@@ -28,16 +28,20 @@
import qualified Data.ByteString as S
import qualified Data.Set as Set
-import Database.Persist.Sqlite
-import Database.Persist.TH
+import Database.Persist.Sqlite
+import Database.Persist.TH
import qualified Pantry.Internal as SQLite
-import Path
-import Stack.Prelude hiding (MigrationFailure)
-import Stack.Storage.Util
-import Stack.Types.Build
-import Stack.Types.Cache
-import Stack.Types.Config (HasBuildConfig, buildConfigL, bcProjectStorage, ProjectStorage (..))
-import Stack.Types.GhcPkgId
+import Path
+import Stack.Prelude
+import Stack.Storage.Util
+ ( handleMigrationException, updateList, updateSet )
+import Stack.Types.Build
+import Stack.Types.Cache
+import Stack.Types.Config
+ ( HasBuildConfig, ProjectStorage (..), bcProjectStorage
+ , buildConfigL
+ )
+import Stack.Types.GhcPkgId
share [ mkPersist sqlSettings
, mkMigrate "migrateAll"
@@ -86,7 +90,8 @@
=> Path Abs File -- ^ storage file
-> (ProjectStorage -> RIO env a)
-> RIO env a
-initProjectStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage
+initProjectStorage fp f = handleMigrationException $
+ SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage
-- | Run an action in a database transaction
withProjectStorage ::
@@ -130,7 +135,7 @@
selectList [ConfigCacheComponentParent ==. parentId] []
let configCachePathEnvVar = configCacheParentPathEnvVar
let configCacheHaddock = configCacheParentHaddock
- return ConfigCache {..}
+ pure ConfigCache {..}
-- | Load 'ConfigCache' from the database.
loadConfigCache ::
@@ -141,11 +146,11 @@
withProjectStorage $ do
mparent <- getBy key
case mparent of
- Nothing -> return Nothing
+ Nothing -> pure Nothing
Just parentEntity@(Entity _ ConfigCacheParent {..})
| configCacheParentActive ->
Just <$> readConfigCache parentEntity
- | otherwise -> return Nothing
+ | otherwise -> pure Nothing
-- | Insert or update 'ConfigCache' to the database.
saveConfigCache ::
@@ -177,7 +182,7 @@
, ConfigCacheParentActive =. True
, ConfigCacheParentPathEnvVar =. configCachePathEnvVar new
]
- return (parentId, Just old)
+ pure (parentId, Just old)
updateList
ConfigCacheDirOption
ConfigCacheDirOptionParent
diff --git a/src/Stack/Storage/User.hs b/src/Stack/Storage/User.hs
--- a/src/Stack/Storage/User.hs
+++ b/src/Stack/Storage/User.hs
@@ -33,25 +33,55 @@
import qualified Data.Set as Set
import qualified Data.Text as T
-import Data.Time.Clock (UTCTime)
-import Database.Persist.Sqlite
-import Database.Persist.TH
-import Distribution.Text (simpleParse, display)
-import Foreign.C.Types (CTime (..))
+import Data.Time.Clock ( UTCTime )
+import Database.Persist.Sqlite
+import Database.Persist.TH
+import Distribution.Text ( simpleParse, display )
+import Foreign.C.Types ( CTime (..) )
import qualified Pantry.Internal as SQLite
-import Path
-import Path.IO (resolveFile', resolveDir')
+import Path
+import Path.IO ( resolveFile', resolveDir' )
import qualified RIO.FilePath as FP
-import Stack.Prelude hiding (MigrationFailure)
-import Stack.Storage.Util
-import Stack.Types.Build
-import Stack.Types.Cache
-import Stack.Types.Compiler
-import Stack.Types.CompilerBuild (CompilerBuild)
-import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..))
-import System.Posix.Types (COff (..))
-import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)
+import Stack.Prelude hiding ( MigrationFailure )
+import Stack.Storage.Util ( handleMigrationException, updateSet )
+import Stack.Types.Build
+import Stack.Types.Cache
+import Stack.Types.Compiler
+import Stack.Types.CompilerBuild ( CompilerBuild )
+import Stack.Types.Config
+ ( CompilerPaths (..), GhcPkgExe (..), HasConfig
+ , UserStorage (..), configL, configUserStorage
+ )
+import System.Posix.Types ( COff (..) )
+import System.PosixCompat.Files
+ ( fileSize, getFileStatus, modificationTime )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Storage.User" module.
+data StorageUserException
+ = CompilerFileMetadataMismatch
+ | GlobalPackageCacheFileMetadataMismatch
+ | GlobalDumpParseFailure
+ | CompilerCacheArchitectureInvalid Text
+ deriving (Show, Typeable)
+
+instance Exception StorageUserException where
+ displayException CompilerFileMetadataMismatch =
+ "Error: [S-8196]\n"
+ ++ "Compiler file metadata mismatch, ignoring cache."
+ displayException GlobalPackageCacheFileMetadataMismatch =
+ "Error: [S-5378]\n"
+ ++ "Global package cache file metadata mismatch, ignoring cache."
+ displayException GlobalDumpParseFailure =
+ "Error: [S-2673]\n"
+ ++ "Global dump did not parse correctly."
+ displayException
+ (CompilerCacheArchitectureInvalid compilerCacheArch) = concat
+ [ "Error: [S-8441]\n"
+ , "Invalid arch: "
+ , show compilerCacheArch
+ ]
+
share [ mkPersist sqlSettings
, mkMigrate "migrateAll"
]
@@ -127,7 +157,8 @@
=> Path Abs File -- ^ storage file
-> (UserStorage -> RIO env a)
-> RIO env a
-initUserStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage
+initUserStorage fp f = handleMigrationException $
+ SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage
-- | Run an action in a database transaction
withUserStorage ::
@@ -172,7 +203,7 @@
pcExes <-
mapM (parseRelFile . precompiledCacheExeValue . entityVal) =<<
selectList [PrecompiledCacheExeParent ==. parentId] []
- return (parentId, PrecompiledCache {..})
+ pure (parentId, PrecompiledCache {..})
-- | Load 'PrecompiledCache' from the database.
loadPrecompiledCache ::
@@ -200,7 +231,7 @@
[ PrecompiledCacheParentLibrary =.
precompiledCacheParentLibrary
]
- return (parentId, Just old)
+ pure (parentId, Just old)
updateSet
PrecompiledCacheSubLib
PrecompiledCacheSubLibParent
@@ -274,12 +305,12 @@
when
(compilerCacheGhcSize /= sizeToInt64 (fileSize compilerStatus) ||
compilerCacheGhcModified /= timeToInt64 (modificationTime compilerStatus))
- (throwString "Compiler file metadata mismatch, ignoring cache")
+ (throwIO CompilerFileMetadataMismatch)
globalDbStatus <- liftIO $ getFileStatus $ compilerCacheGlobalDb FP. "package.cache"
when
(compilerCacheGlobalDbCacheSize /= sizeToInt64 (fileSize globalDbStatus) ||
compilerCacheGlobalDbCacheModified /= timeToInt64 (modificationTime globalDbStatus))
- (throwString "Global package cache file metadata mismatch, ignoring cache")
+ (throwIO GlobalPackageCacheFileMetadataMismatch)
-- We could use parseAbsFile instead of resolveFile' below to
-- bypass some system calls, at the cost of some really wonky
@@ -292,11 +323,11 @@
cabalVersion <- parseVersionThrowing $ T.unpack compilerCacheCabalVersion
globalDump <-
case readMaybe $ T.unpack compilerCacheGlobalDump of
- Nothing -> throwString "Global dump did not parse correctly"
+ Nothing -> throwIO GlobalDumpParseFailure
Just globalDump -> pure globalDump
arch <-
case simpleParse $ T.unpack compilerCacheArch of
- Nothing -> throwString $ "Invalid arch: " ++ show compilerCacheArch
+ Nothing -> throwIO $ CompilerCacheArchitectureInvalid compilerCacheArch
Just arch -> pure arch
pure CompilerPaths
diff --git a/src/Stack/Storage/Util.hs b/src/Stack/Storage/Util.hs
--- a/src/Stack/Storage/Util.hs
+++ b/src/Stack/Storage/Util.hs
@@ -7,13 +7,15 @@
-- | Utils for the other Stack.Storage modules
module Stack.Storage.Util
- ( updateList
+ ( handleMigrationException
+ , updateList
, updateSet
) where
import qualified Data.Set as Set
-import Database.Persist
-import Stack.Prelude hiding (MigrationFailure)
+import Database.Persist
+import Stack.Prelude
+import Stack.Types.Storage ( StoragePrettyException (..) )
-- | Efficiently update a set of values stored in a database table
updateSet ::
@@ -69,3 +71,16 @@
insertMany_ $
map (uncurry $ recordCons parentId) $
Set.toList (Set.difference newSet oldSet)
+
+handleMigrationException :: HasLogFunc env => RIO env a -> RIO env a
+handleMigrationException inner = do
+ eres <- try inner
+ either
+ ( \e -> case e :: PantryException of
+ MigrationFailure desc fp ex ->
+ throwIO $
+ PrettyException $ StorageMigrationFailure desc fp ex
+ _ -> throwIO e
+ )
+ pure
+ eres
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
@@ -9,61 +9,68 @@
-- | Build-specific types.
module Stack.Types.Build
- (StackBuildException(..)
- ,FlagSource(..)
- ,UnusedFlags(..)
- ,InstallLocation(..)
- ,Installed(..)
- ,psVersion
- ,Task(..)
- ,taskIsTarget
- ,taskLocation
- ,taskTargetIsMutable
- ,LocalPackage(..)
- ,BaseConfigOpts(..)
- ,Plan(..)
- ,TestOpts(..)
- ,BenchmarkOpts(..)
- ,FileWatchOpts(..)
- ,BuildOpts(..)
- ,BuildSubset(..)
- ,defaultBuildOpts
- ,TaskType(..)
- ,IsMutable(..)
- ,installLocationIsMutable
- ,TaskConfigOpts(..)
- ,BuildCache(..)
- ,ConfigCache(..)
- ,configureOpts
- ,CachePkgSrc (..)
- ,toCachePkgSrc
- ,isStackOpt
- ,wantedLocalPackages
- ,FileCacheInfo (..)
- ,ConfigureOpts (..)
- ,PrecompiledCache (..)
- )
- where
+ ( BuildException (..)
+ , BuildPrettyException (..)
+ , ConstructPlanException (..)
+ , BadDependency (..)
+ , ParentMap
+ , FlagSource (..)
+ , UnusedFlags (..)
+ , InstallLocation (..)
+ , Installed (..)
+ , psVersion
+ , Task (..)
+ , taskIsTarget
+ , taskLocation
+ , taskTargetIsMutable
+ , LocalPackage (..)
+ , BaseConfigOpts (..)
+ , Plan (..)
+ , TestOpts (..)
+ , BenchmarkOpts (..)
+ , FileWatchOpts (..)
+ , BuildOpts (..)
+ , BuildSubset (..)
+ , defaultBuildOpts
+ , TaskType (..)
+ , IsMutable (..)
+ , installLocationIsMutable
+ , TaskConfigOpts (..)
+ , BuildCache (..)
+ , ConfigCache (..)
+ , configureOpts
+ , CachePkgSrc (..)
+ , toCachePkgSrc
+ , isStackOpt
+ , wantedLocalPackages
+ , FileCacheInfo (..)
+ , ConfigureOpts (..)
+ , PrecompiledCache (..)
+ ) where
-import Stack.Prelude
-import Data.Aeson (ToJSON, FromJSON)
-import qualified Data.ByteString as S
-import Data.Char (isSpace)
-import Data.List.Extra
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import Database.Persist.Sql (PersistField(..)
- ,PersistFieldSql(..)
- ,PersistValue(PersistText)
- ,SqlType(SqlString))
-import Distribution.PackageDescription (TestSuiteInterface)
-import Distribution.System (Arch)
-import qualified Distribution.Text as C
-import Distribution.Version (mkVersion)
-import Path (parseRelDir, (), parent)
-import Path.Extra (toFilePathNoTrailingSep)
+import Data.Aeson ( ToJSON, FromJSON )
+import qualified Data.ByteString as S
+import Data.Char ( isSpace )
+import Data.List as L
+import qualified Data.Map as Map
+import qualified Data.Map.Strict as M
+import Data.Monoid.Map ( MonoidMap (..) )
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Database.Persist.Sql
+ ( PersistField (..), PersistFieldSql (..)
+ , PersistValue (PersistText), SqlType (SqlString)
+ )
+import Distribution.PackageDescription
+ ( TestSuiteInterface, mkPackageName )
+import Distribution.System ( Arch )
+import qualified Distribution.Text as C
+import qualified Distribution.Version as C
+import Path ( parseRelDir, (), parent )
+import Path.Extra ( toFilePathNoTrailingSep )
+import RIO.Process ( showProcessArgDebug )
import Stack.Constants
+import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.CompilerBuild
import Stack.Types.Config
@@ -71,12 +78,11 @@
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.Version
-import System.FilePath (pathSeparator)
-import RIO.Process (showProcessArgDebug)
+import System.FilePath ( pathSeparator )
-----------------------------------------------
--- Exceptions
-data StackBuildException
+-- | Type representing exceptions thrown by functions exported by modules with
+-- names beginning @Stack.Build@.
+data BuildException
= Couldn'tFindPkgId PackageName
| CompilerVersionMismatch
(Maybe (ActualCompiler, Arch)) -- found
@@ -93,22 +99,6 @@
(Path Abs File) -- stack.yaml
| TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
| TestSuiteTypeUnsupported TestSuiteInterface
- | ConstructPlanFailed String
- | CabalExitedUnsuccessfully
- ExitCode
- PackageIdentifier
- (Path Abs File) -- cabal Executable
- [String] -- cabal arguments
- (Maybe (Path Abs File)) -- logfiles location
- [Text] -- log contents
- | SetupHsBuildFailure
- ExitCode
- (Maybe PackageIdentifier) -- which package's custom setup, is simple setup if Nothing
- (Path Abs File) -- ghc Executable
- [String] -- ghc arguments
- (Maybe (Path Abs File)) -- logfiles location
- [Text] -- log contents
- | ExecutionFailure [SomeException]
| LocalPackageDoesn'tMatchTarget
PackageName
Version -- local version
@@ -122,62 +112,63 @@
| CabalCopyFailed Bool String
| LocalPackagesPresent [PackageIdentifier]
| CouldNotLockDistDir !(Path Abs File)
- deriving Typeable
-
-data FlagSource = FSCommandLine | FSStackYaml
- deriving (Show, Eq, Ord)
-
-data UnusedFlags = UFNoPackage FlagSource PackageName
- | UFFlagsNotDefined
- FlagSource
- PackageName
- (Set FlagName) -- defined in package
- (Set FlagName) -- not defined
- | UFSnapshot PackageName
- deriving (Show, Eq, Ord)
+ | TaskCycleBug PackageIdentifier
+ | PackageIdMissingBug PackageIdentifier
+ | AllInOneBuildBug
+ | MulipleResultsBug PackageName [DumpPackage]
+ | TemplateHaskellNotFoundBug
+ | HaddockIndexNotFound
+ | ShowBuildErrorBug
+ deriving (Show, Typeable)
-instance Show StackBuildException where
- show (Couldn'tFindPkgId name) =
- "After installing " <> packageNameString name <>
- ", the package id couldn't be found " <> "(via ghc-pkg describe " <>
- packageNameString name <> "). This shouldn't happen, " <>
- "please report as a bug"
- show (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) = concat
- [ case mactual of
- Nothing -> "No compiler found, expected "
- Just (actual, arch) -> concat
- [ "Compiler version mismatched, found "
- , compilerVersionString actual
- , " ("
- , C.display arch
- , ")"
- , ", but expected "
- ]
- , case check of
- MatchMinor -> "minor version match with "
- MatchExact -> "exact version "
- NewerMinor -> "minor version match or newer with "
- , T.unpack $ utf8BuilderToText $ display expected
+instance Exception BuildException where
+ displayException (Couldn'tFindPkgId name) = bugReport "[S-7178]" $ concat
+ [ "After installing "
+ , packageNameString name
+ ,", the package id couldn't be found (via ghc-pkg describe "
+ , packageNameString name
+ , ")."
+ ]
+ displayException (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) = concat
+ [ "Error: [S-6362]\n"
+ , case mactual of
+ Nothing -> "No compiler found, expected "
+ Just (actual, arch) -> concat
+ [ "Compiler version mismatched, found "
+ , compilerVersionString actual
, " ("
- , C.display eArch
- , ghcVariantSuffix ghcVariant
- , compilerBuildSuffix ghcBuild
- , ") (based on "
- , case mstack of
- Nothing -> "command line arguments"
- Just stack -> "resolver setting in " ++ toFilePath stack
- , ").\n"
- , T.unpack resolution
+ , C.display arch
+ , ")"
+ , ", but expected "
]
- show (Couldn'tParseTargets targets) = unlines
- $ "The following targets could not be parsed as package names or directories:"
- : map T.unpack targets
- show (UnknownTargets noKnown notInSnapshot stackYaml) =
- unlines $ noKnown' ++ notInSnapshot'
+ , case check of
+ MatchMinor -> "minor version match with "
+ MatchExact -> "exact version "
+ NewerMinor -> "minor version match or newer with "
+ , T.unpack $ utf8BuilderToText $ display expected
+ , " ("
+ , C.display eArch
+ , ghcVariantSuffix ghcVariant
+ , compilerBuildSuffix ghcBuild
+ , ") (based on "
+ , case mstack of
+ Nothing -> "command line arguments"
+ Just stack -> "resolver setting in " ++ toFilePath stack
+ , ").\n"
+ , T.unpack resolution
+ ]
+ displayException (Couldn'tParseTargets targets) = unlines
+ $ "Error: [S-3127]"
+ : "The following targets could not be parsed as package names or \
+ \directories:"
+ : map T.unpack targets
+ displayException (UnknownTargets noKnown notInSnapshot stackYaml) = unlines
+ $ "Error: [S-2154]"
+ : (noKnown' ++ notInSnapshot')
where
noKnown'
| Set.null noKnown = []
- | otherwise = return $
+ | otherwise = pure $
"The following target packages were not found: " ++
intercalate ", " (map packageNameString $ Set.toList noKnown) ++
"\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."
@@ -194,37 +185,38 @@
(\(name, version') -> "- " ++ packageIdentifierString
(PackageIdentifier name version'))
(Map.toList notInSnapshot)
- show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat
- [ ["Test suite failure for package " ++ packageIdentifierString ident]
- , flip map (Map.toList codes) $ \(name, mcode) -> concat
- [ " "
- , T.unpack name
- , ": "
- , case mcode of
- Nothing -> " executable not found"
- Just ec -> " exited with: " ++ show ec
+ displayException (TestSuiteFailure ident codes mlogFile bs) = unlines
+ $ "Error: [S-1995]"
+ : concat
+ [ ["Test suite failure for package " ++ packageIdentifierString ident]
+ , flip map (Map.toList codes) $ \(name, mcode) -> concat
+ [ " "
+ , T.unpack name
+ , ": "
+ , case mcode of
+ Nothing -> " executable not found"
+ Just ec -> " exited with: " ++ displayException ec
+ ]
+ , pure $ case mlogFile of
+ Nothing -> "Logs printed to console"
+ -- TODO Should we load up the full error output and print it here?
+ Just logFile -> "Full log available at " ++ toFilePath logFile
+ , if S.null bs
+ then []
+ else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]
]
- , return $ case mlogFile of
- Nothing -> "Logs printed to console"
- -- TODO Should we load up the full error output and print it here?
- Just logFile -> "Full log available at " ++ toFilePath logFile
- , if S.null bs
- then []
- else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]
+ where
+ indent' = dropWhileEnd isSpace . unlines . fmap (\l -> " " ++ l) . lines
+ doubleIndent = indent' . indent'
+ displayException (TestSuiteTypeUnsupported interface) = concat
+ [ "Error: [S-3819]\n"
+ , "Unsupported test suite type: "
+ , show interface
]
- where
- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
- doubleIndent = indent . indent
- show (TestSuiteTypeUnsupported interface) =
- "Unsupported test suite type: " <> show interface
-- Suppressing duplicate output
- show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
- showBuildError False exitCode (Just taskProvides') execName fullArgs logFiles bss
- show (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) =
- showBuildError True exitCode mtaskProvides execName fullArgs logFiles bss
- show (ExecutionFailure es) = intercalate "\n\n" $ map show es
- show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
- [ "Version for local package "
+ displayException (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
+ [ "Error: [S-5797]\n"
+ , "Version for local package "
, packageNameString name
, " is "
, versionString localV
@@ -232,10 +224,14 @@
, versionString requestedV
, " on the command line"
]
- show (NoSetupHsFound dir) =
- "No Setup.hs or Setup.lhs file found in " ++ toFilePath dir
- show (InvalidFlagSpecification unused) = unlines
- $ "Invalid flag specification:"
+ displayException (NoSetupHsFound dir) = concat
+ [ "Error: [S-3118]\n"
+ , "No Setup.hs or Setup.lhs file found in "
+ , toFilePath dir
+ ]
+ displayException (InvalidFlagSpecification unused) = unlines
+ $ "Error: [S-8664]"
+ : "Invalid flag specification:"
: map go (Set.toList unused)
where
showFlagSrc :: FlagSource -> String
@@ -269,8 +265,9 @@
, packageNameString name
, ", please add to extra-deps"
]
- show (InvalidGhcOptionsSpecification unused) = unlines
- $ "Invalid GHC options specification:"
+ displayException (InvalidGhcOptionsSpecification unused) = unlines
+ $ "Error: [S-4925]"
+ : "Invalid GHC options specification:"
: map showGhcOptionSrc unused
where
showGhcOptionSrc name = concat
@@ -278,17 +275,26 @@
, packageNameString name
, "' not found"
]
- show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err
- show (TargetParseException errs) = unlines
- $ "The following errors occurred while parsing the build targets:"
+ displayException (TargetParseException [err]) = concat
+ [ "Error: [S-8506]\n"
+ , "Error parsing targets: "
+ , T.unpack err
+ ]
+ displayException (TargetParseException errs) = unlines
+ $ "Error [S-8506]"
+ : "The following errors occurred while parsing the build targets:"
: map (("- " ++) . T.unpack) errs
-
- show (SomeTargetsNotBuildable xs) =
- "The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n " ++
- T.unpack (renderPkgComponents xs) ++
- "\nTo resolve this, either provide flags such that these components are buildable, or only specify buildable targets."
- show (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) =
- missingExeError isSimpleBuildType $ concat
+ displayException (SomeTargetsNotBuildable xs) = unlines
+ [ "Error: [S-7086]"
+ , "The following components have 'buildable: False' set in the Cabal \
+ \configuration, and so cannot be targets:"
+ , " " <> T.unpack (renderPkgComponents xs)
+ , "To resolve this, either provide flags such that these components \
+ \are buildable, or only specify buildable targets."
+ ]
+ displayException (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) =
+ missingExeError "[S-7987]"
+ isSimpleBuildType $ concat
[ "Test suite executable \""
, exeName
, " not found for "
@@ -296,75 +302,449 @@
, ":test:"
, testName
]
- show (CabalCopyFailed isSimpleBuildType innerMsg) =
- missingExeError isSimpleBuildType $ concat
+ displayException (CabalCopyFailed isSimpleBuildType innerMsg) =
+ missingExeError "[S-8027]"
+ isSimpleBuildType $ concat
[ "'cabal copy' failed. Error message:\n"
, innerMsg
, "\n"
]
- show (ConstructPlanFailed msg) = msg
- show (LocalPackagesPresent locals) = unlines
- $ "Local packages are not allowed when using the script command. Packages found:"
- : map (\ident -> "- " ++ packageIdentifierString ident) locals
- show (CouldNotLockDistDir lockFile) = unlines
- [ "Locking the dist directory failed, try to lock file:"
- , " " ++ toFilePath lockFile
- , "Maybe you're running another copy of Stack?"
- ]
+ displayException (LocalPackagesPresent locals) = unlines
+ $ "Error: [S-5510]"
+ : "Local packages are not allowed when using the 'script' command. \
+ \Packages found:"
+ : map (\ident -> "- " ++ packageIdentifierString ident) locals
+ displayException (CouldNotLockDistDir lockFile) = unlines
+ [ "Error: [S-7168]"
+ , "Locking the dist directory failed, try to lock file:"
+ , " " ++ toFilePath lockFile
+ , "Maybe you're running another copy of Stack?"
+ ]
+ displayException (TaskCycleBug pid) = bugReport "[S-7868]" $
+ "Error: The impossible happened! Unexpected task cycle for "
+ ++ packageNameString (pkgName pid)
+ displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $
+ "The impossible happened! singleBuild: missing package ID missing: "
+ ++ show ident
+ displayException AllInOneBuildBug = bugReport "[S-7371]"
+ "Cannot have an all-in-one build that also has a final build step."
+ displayException (MulipleResultsBug name dps) = bugReport "[S-6739]"
+ "singleBuild: multiple results when describing installed package "
+ ++ show (name, dps)
+ displayException TemplateHaskellNotFoundBug = bugReport "[S-3121]"
+ "template-haskell is a wired-in GHC boot library but it wasn't found."
+ displayException HaddockIndexNotFound =
+ "Error: [S-6901]\n"
+ ++ "No local or snapshot doc index found to open."
+ displayException ShowBuildErrorBug = bugReport "[S-5452]"
+ "Unexpected case in showBuildError."
-missingExeError :: Bool -> String -> String
-missingExeError isSimpleBuildType msg =
- unlines $ msg : "Possible causes of this issue:" :
- map ("* " <>) possibleCauses
+data BuildPrettyException
+ = ConstructPlanFailed
+ [ConstructPlanException]
+ (Path Abs File)
+ (Path Abs Dir)
+ ParentMap
+ (Set PackageName)
+ (Map PackageName [PackageName])
+ | ExecutionFailure [SomeException]
+ | CabalExitedUnsuccessfully
+ ExitCode
+ PackageIdentifier
+ (Path Abs File) -- cabal Executable
+ [String] -- cabal arguments
+ (Maybe (Path Abs File)) -- logfiles location
+ [Text] -- log contents
+ | SetupHsBuildFailure
+ ExitCode
+ (Maybe PackageIdentifier) -- which package's custom setup, is simple setup if Nothing
+ (Path Abs File) -- ghc Executable
+ [String] -- ghc arguments
+ (Maybe (Path Abs File)) -- logfiles location
+ [Text] -- log contents
+ deriving (Show, Typeable)
+
+instance Pretty BuildPrettyException where
+ pretty ( ConstructPlanFailed errs stackYaml stackRoot parents wanted prunedGlobalDeps ) =
+ "[S-4804]"
+ <> line
+ <> flow "Stack failed to construct a build plan."
+ <> blankLine
+ <> pprintExceptions
+ errs stackYaml stackRoot parents wanted prunedGlobalDeps
+ pretty (ExecutionFailure es) =
+ "[S-7282]"
+ <> line
+ <> flow "Stack failed to execute the build plan."
+ <> blankLine
+ <> flow "While executing the build plan, Stack encountered the \
+ \following errors:"
+ <> blankLine
+ <> hcat (L.intersperse blankLine (map ppExceptions es))
+ where
+ ppExceptions :: SomeException -> StyleDoc
+ ppExceptions e = case fromException e of
+ Just (PrettyException e') -> pretty e'
+ Nothing -> (string . show) e
+ pretty (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
+ showBuildError "[S-7011]"
+ False exitCode (Just taskProvides') execName fullArgs logFiles bss
+ pretty (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) =
+ showBuildError "[S-6374]"
+ True exitCode mtaskProvides execName fullArgs logFiles bss
+
+instance Exception BuildPrettyException
+
+pprintExceptions
+ :: [ConstructPlanException]
+ -> Path Abs File
+ -> Path Abs Dir
+ -> ParentMap
+ -> Set PackageName
+ -> Map PackageName [PackageName]
+ -> StyleDoc
+pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps =
+ mconcat $
+ [ flow "While constructing the build plan, Stack encountered the \
+ \following errors:"
+ , blankLine
+ , mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions'))
+ ] ++ if L.null recommendations
+ then []
+ else
+ [ blankLine
+ , flow "Some different approaches to resolving this:"
+ , blankLine
+ ] ++ recommendations
+
where
- possibleCauses =
- "No module named \"Main\". The 'main-is' source file should usually \
- \have a header indicating that it's a 'Main' module." :
+ exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions
- "A cabal file that refers to nonexistent other files (e.g. a \
- \license-file that doesn't exist). Running 'cabal check' may point \
- \out these issues." :
+ recommendations =
+ if not onlyHasDependencyMismatches
+ then []
+ else
+ [ " *" <+> align
+ ( flow "Set 'allow-newer: true' in "
+ <+> pretty (defaultUserConfigPath stackRoot)
+ <+> "to ignore all version constraints and build anyway."
+ )
+ , blankLine
+ ]
+ ++ addExtraDepsRecommendations
- if isSimpleBuildType
+ addExtraDepsRecommendations
+ | Map.null extras = []
+ | (Just _) <- Map.lookup (mkPackageName "base") extras =
+ [ " *" <+> align (flow "Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.")
+ , line
+ ]
+ | otherwise =
+ [ " *" <+> align
+ (style Recommendation (flow "Recommended action:") <+>
+ flow "try adding the following to your extra-deps in" <+>
+ pretty stackYaml <> ":")
+ , blankLine
+ , vsep (map pprintExtra (Map.toList extras))
+ , line
+ ]
+
+ extras = Map.unions $ map getExtras exceptions'
+ getExtras DependencyCycleDetected{} = Map.empty
+ getExtras UnknownPackage{} = Map.empty
+ getExtras (DependencyPlanFailures _ m) =
+ Map.unions $ map go $ Map.toList m
+ where
+ -- TODO: Likely a good idea to distinguish these to the user. In particular, for DependencyMismatch
+ go (name, (_range, Just (version,cabalHash), NotInBuildPlan)) =
+ Map.singleton name (version,cabalHash)
+ go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) =
+ Map.singleton name (version, cabalHash)
+ go _ = Map.empty
+ pprintExtra (name, (version, BlobKey cabalHash cabalSize)) =
+ let cfInfo = CFIHash cabalHash (Just cabalSize)
+ packageIdRev = PackageIdentifierRevision name version cfInfo
+ in fromString ("- " ++ T.unpack (utf8BuilderToText (display packageIdRev)))
+
+ allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions'
+ toNotInBuildPlan (DependencyPlanFailures _ pDeps) =
+ map fst $ filter (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) $ Map.toList pDeps
+ toNotInBuildPlan _ = []
+
+ -- This checks if 'allow-newer: true' could resolve all issues.
+ onlyHasDependencyMismatches = all go exceptions'
+ where
+ go DependencyCycleDetected{} = False
+ go UnknownPackage{} = False
+ go (DependencyPlanFailures _ m) =
+ all (\(_, _, depErr) -> isMismatch depErr) (M.elems m)
+ isMismatch DependencyMismatch{} = True
+ isMismatch Couldn'tResolveItsDependencies{} = True
+ isMismatch _ = False
+
+ pprintException (DependencyCycleDetected pNames) = Just $
+ flow "Dependency cycle detected in packages:" <> line <>
+ indent 4 (encloseSep "[" "]" "," (map (style Error . fromString . packageNameString) pNames))
+ pprintException (DependencyPlanFailures pkg pDeps) =
+ case mapMaybe pprintDep (Map.toList pDeps) of
+ [] -> Nothing
+ depErrors -> Just $
+ flow "In the dependencies for" <+> pkgIdent <>
+ pprintFlags (packageFlags pkg) <> ":" <> line <>
+ indent 4 (vsep depErrors) <>
+ case getShortestDepsPath parentMap wanted' (packageName pkg) of
+ Nothing -> line <> flow "needed for unknown reason - stack invariant violated."
+ Just [] -> line <> flow "needed since" <+> pkgName' <+> flow "is a build target."
+ Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems
+ where
+ pathElems =
+ [style Target . fromString . packageIdentifierString $ target] ++
+ map (fromString . packageIdentifierString) path ++
+ [pkgIdent]
+ where
+ pkgName' = style Current . fromString . packageNameString $ packageName pkg
+ pkgIdent = style Current . fromString . packageIdentifierString $ packageIdentifier pkg
+ -- Skip these when they are redundant with 'NotInBuildPlan' info.
+ pprintException (UnknownPackage name)
+ | name `Set.member` allNotInBuildPlan = Nothing
+ | name `Set.member` wiredInPackages =
+ Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . fromString . packageNameString $ name)
+ | Just pruned <- Map.lookup name prunedGlobalDeps =
+ let prunedDeps = map (style Current . fromString . packageNameString) pruned
+ in Just $ flow "Can't use GHC boot package" <+>
+ (style Current . fromString . packageNameString $ name) <+>
+ flow "when it has an overridden dependency (issue #4510);" <+>
+ flow "you need to add the following as explicit dependencies to the project:" <+>
+ line <+> encloseSep "" "" ", " prunedDeps
+ | otherwise = Just $ flow "Unknown package:" <+> (style Current . fromString . packageNameString $ name)
+
+ pprintFlags flags
+ | Map.null flags = ""
+ | otherwise = parens $ sep $ map pprintFlag $ Map.toList flags
+ pprintFlag (name, True) = "+" <> fromString (flagNameString name)
+ pprintFlag (name, False) = "-" <> fromString (flagNameString name)
+
+ pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of
+ NotInBuildPlan
+ | name `elem` fold prunedGlobalDeps -> Just $
+ style Error (fromString $ packageNameString name) <+>
+ align ((if range == C.anyVersion
+ then flow "needed"
+ else flow "must match" <+> goodRange) <> "," <> softline <>
+ flow "but this GHC boot package has been pruned (issue #4510);" <+>
+ flow "you need to add the package explicitly to extra-deps" <+>
+ latestApplicable Nothing)
+ | otherwise -> Just $
+ style Error (fromString $ packageNameString name) <+>
+ align ((if range == C.anyVersion
+ then flow "needed"
+ else flow "must match" <+> goodRange) <> "," <> softline <>
+ flow "but the Stack configuration has no specified version" <+>
+ latestApplicable Nothing)
+ -- TODO: For local packages, suggest editing constraints
+ DependencyMismatch version -> Just $
+ (style Error . fromString . packageIdentifierString) (PackageIdentifier name version) <+>
+ align (flow "from Stack configuration does not match" <+> goodRange <+>
+ latestApplicable (Just version))
+ -- I think the main useful info is these explain why missing
+ -- packages are needed. Instead lets give the user the shortest
+ -- path from a target to the package.
+ Couldn'tResolveItsDependencies _version -> Nothing
+ HasNoLibrary -> Just $
+ style Error (fromString $ packageNameString name) <+>
+ align (flow "is a library dependency, but the package provides no library")
+ BDDependencyCycleDetected names -> Just $
+ style Error (fromString $ packageNameString name) <+>
+ align (flow $ "dependency cycle detected: " ++ L.intercalate ", " (map packageNameString names))
+ where
+ goodRange = style Good (fromString (C.display range))
+ latestApplicable mversion =
+ case mlatestApplicable of
+ Nothing
+ | isNothing mversion ->
+ flow "(no package with that name found, perhaps there \
+ \is a typo in a package's build-depends or an \
+ \omission from the stack.yaml packages list?)"
+ | otherwise -> ""
+ Just (laVer, _)
+ | Just laVer == mversion ->
+ flow "(latest matching version is specified)"
+ | otherwise ->
+ fillSep
+ [ flow "(latest matching version is"
+ , style Good (fromString $ versionString laVer) <> ")"
+ ]
+
+-- | Get the shortest reason for the package to be in the build plan. In
+-- other words, trace the parent dependencies back to a 'wanted'
+-- package.
+getShortestDepsPath
+ :: ParentMap
+ -> Set PackageName
+ -> PackageName
+ -> Maybe [PackageIdentifier]
+getShortestDepsPath (MonoidMap parentsMap) wanted' name =
+ if Set.member name wanted'
+ then Just []
+ else case M.lookup name parentsMap of
+ Nothing -> Nothing
+ Just (_, parents) -> Just $ findShortest 256 paths0
+ where
+ paths0 = M.fromList $ map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents
+ where
+ -- The 'paths' map is a map from PackageName to the shortest path
+ -- found to get there. It is the frontier of our breadth-first
+ -- search of dependencies.
+ findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
+ findShortest fuel _ | fuel <= 0 =
+ [PackageIdentifier (mkPackageName "stack-ran-out-of-jet-fuel") (C.mkVersion [0])]
+ findShortest _ paths | M.null paths = []
+ findShortest fuel paths =
+ case targets of
+ [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ concatMap extendPath recurses
+ _ -> let (DepsPath _ _ path) = L.minimum (map snd targets) in path
+ where
+ (targets, recurses) = L.partition (\(n, _) -> n `Set.member` wanted') (M.toList paths)
+ chooseBest :: DepsPath -> DepsPath -> DepsPath
+ chooseBest x y = max x y
+ -- Extend a path to all its parents.
+ extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
+ extendPath (n, dp) =
+ case M.lookup n parentsMap of
+ Nothing -> []
+ Just (_, parents) -> map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents
+
+startDepsPath :: PackageIdentifier -> DepsPath
+startDepsPath ident = DepsPath
+ { dpLength = 1
+ , dpNameLength = length (packageNameString (pkgName ident))
+ , dpPath = [ident]
+ }
+
+extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
+extendDepsPath ident dp = DepsPath
+ { dpLength = dpLength dp + 1
+ , dpNameLength = dpNameLength dp + length (packageNameString (pkgName ident))
+ , dpPath = [ident]
+ }
+
+data ConstructPlanException
+ = DependencyCycleDetected [PackageName]
+ | DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
+ | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all
+ -- ^ Recommend adding to extra-deps, give a helpful version number?
+ deriving (Typeable, Eq, Show)
+
+-- | The latest applicable version and it's latest Cabal file revision.
+-- For display purposes only, Nothing if package not found
+type LatestApplicableVersion = Maybe (Version, BlobKey)
+
+-- | Reason why a dependency was not used
+data BadDependency
+ = NotInBuildPlan
+ | Couldn'tResolveItsDependencies Version
+ | DependencyMismatch Version
+ | HasNoLibrary
+ -- ^ See description of 'DepType'
+ | BDDependencyCycleDetected ![PackageName]
+ deriving (Typeable, Eq, Ord, Show)
+
+type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])
+
+data DepsPath = DepsPath
+ { dpLength :: Int -- ^ Length of dpPath
+ , dpNameLength :: Int -- ^ Length of package names combined
+ , dpPath :: [PackageIdentifier] -- ^ A path where the packages later
+ -- in the list depend on those that
+ -- come earlier
+ }
+ deriving (Eq, Ord, Show)
+
+data FlagSource = FSCommandLine | FSStackYaml
+ deriving (Show, Eq, Ord)
+
+data UnusedFlags = UFNoPackage FlagSource PackageName
+ | UFFlagsNotDefined
+ FlagSource
+ PackageName
+ (Set FlagName) -- defined in package
+ (Set FlagName) -- not defined
+ | UFSnapshot PackageName
+ deriving (Show, Eq, Ord)
+
+missingExeError :: String -> Bool -> String -> String
+missingExeError errorCode isSimpleBuildType msg = unlines
+ $ "Error: " <> errorCode
+ : msg
+ : "Possible causes of this issue:"
+ : map ("* " <>) possibleCauses
+ where
+ possibleCauses
+ = "No module named \"Main\". The 'main-is' source file should usually \
+ \have a header indicating that it's a 'Main' module."
+ : "A Cabal file that refers to nonexistent other files (e.g. a \
+ \license-file that doesn't exist). Running 'cabal check' may point \
+ \out these issues."
+ : if isSimpleBuildType
then []
else ["The Setup.hs file is changing the installation target dir."]
showBuildError
- :: Bool
+ :: String
+ -> Bool
-> ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
- -> String
-showBuildError isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss =
+ -> StyleDoc
+showBuildError errorCode isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss =
let fullCmd = unwords
$ dropQuotes (toFilePath execName)
: map (T.unpack . showProcessArgDebug) fullArgs
- logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles
- in "\n-- While building " ++
- (case (isBuildingSetup, mtaskProvides) of
- (False, Nothing) -> error "Invariant violated: unexpected case in showBuildError"
- (False, Just taskProvides') -> "package " ++ dropQuotes (packageIdentifierString taskProvides')
- (True, Nothing) -> "simple Setup.hs"
- (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (packageIdentifierString taskProvides')
- ) ++
- " (scroll up to its section to see the error) using:\n " ++ fullCmd ++ "\n" ++
- " Process exited with code: " ++ show exitCode ++
- (if exitCode == ExitFailure (-9)
- then " (THIS MAY INDICATE OUT OF MEMORY)"
- else "") ++
- logLocations ++
- (if null bss
- then ""
- else "\n\n" ++ removeTrailingSpaces (map T.unpack bss))
+ logLocations =
+ maybe
+ mempty
+ (\fp -> line <> flow "Logs have been written to:" <+>
+ style File (pretty fp))
+ logFiles
+ in fromString errorCode
+ <> line
+ <> flow "While building" <+>
+ ( case (isBuildingSetup, mtaskProvides) of
+ (False, Nothing) -> impureThrow ShowBuildErrorBug
+ (False, Just taskProvides') ->
+ "package" <+>
+ style
+ Target
+ (fromString $ dropQuotes (packageIdentifierString taskProvides'))
+ (True, Nothing) -> "simple" <+> style File "Setup.hs"
+ (True, Just taskProvides') ->
+ "custom" <+>
+ style File "Setup.hs" <+>
+ flow "for package" <+>
+ style
+ Target
+ (fromString $ dropQuotes (packageIdentifierString taskProvides'))
+ ) <+>
+ flow "(scroll up to its section to see the error) using:"
+ <> line
+ <> style Shell (fromString fullCmd)
+ <> line
+ <> flow "Process exited with code:" <+> (fromString . show) exitCode <+>
+ ( if exitCode == ExitFailure (-9)
+ then flow "(THIS MAY INDICATE OUT OF MEMORY)"
+ else mempty
+ )
+ <> logLocations
+ <> if null bss
+ then mempty
+ else blankLine <> string (removeTrailingSpaces (map T.unpack bss))
where
removeTrailingSpaces = dropWhileEnd isSpace . unlines
dropQuotes = filter ('\"' /=)
-instance Exception StackBuildException
-
----------------------------------------------
-- | Package dependency oracle.
@@ -681,12 +1061,12 @@
wc = view (actualCompilerVersionL.to whichCompiler) econfig
cv = view (actualCompilerVersionL.to getGhcVersion) econfig
- hideSourcePaths ghcVersion = ghcVersion >= mkVersion [8, 2] && configHideSourcePaths config
+ hideSourcePaths ghcVersion = ghcVersion >= C.mkVersion [8, 2] && configHideSourcePaths config
config = view configL econfig
bopts = bcoBuildOpts bco
- newerCabal = view cabalVersionL econfig >= mkVersion [1, 22]
+ newerCabal = view cabalVersionL econfig >= C.mkVersion [1, 22]
-- Unioning atop defaults is needed so that all flags are specified
-- with --exact-configuration.
diff --git a/src/Stack/Types/Cache.hs b/src/Stack/Types/Cache.hs
--- a/src/Stack/Types/Cache.hs
+++ b/src/Stack/Types/Cache.hs
@@ -2,14 +2,14 @@
{-# LANGUAGE OverloadedStrings #-}
module Stack.Types.Cache
- ( ConfigCacheType(..)
- , Action(..)
- ) where
+ ( ConfigCacheType (..)
+ , Action (..)
+ ) where
import qualified Data.Text as T
-import Database.Persist.Sql
-import Stack.Prelude
-import Stack.Types.GhcPkgId
+import Database.Persist.Sql
+import Stack.Prelude
+import Stack.Types.GhcPkgId
-- | Type of config cache
data ConfigCacheType
diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs
--- a/src/Stack/Types/Compiler.hs
+++ b/src/Stack/Types/Compiler.hs
@@ -28,8 +28,23 @@
import qualified Data.Text as T
import Stack.Prelude
import Stack.Types.Version
-import Distribution.Version (mkVersion)
+import Distribution.Version ( mkVersion )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Types.Compiler" module.
+data CompilerException
+ = GhcjsNotSupported
+ | PantryException PantryException
+ deriving (Show, Typeable)
+
+instance Exception CompilerException where
+ displayException GhcjsNotSupported =
+ "Error: [S-7903]\n"
+ ++ "GHCJS is no longer supported by Stack."
+ displayException (PantryException p) =
+ "Error: [S-7972]\n"
+ ++ displayException p
+
-- | Variety of compiler to use.
data WhichCompiler
= Ghc
@@ -37,7 +52,7 @@
-- | Specifies a compiler and its version number(s).
--
--- Note that despite having this datatype, stack isn't in a hurry to
+-- Note that despite having this datatype, Stack isn't in a hurry to
-- support compilers other than GHC.
data ActualCompiler
= ACGhc !Version
@@ -50,28 +65,19 @@
instance ToJSON ActualCompiler where
toJSON = toJSON . compilerVersionText
instance FromJSON ActualCompiler where
- parseJSON (String t) = either (const $ fail "Failed to parse compiler version") return (parseActualCompiler t)
+ parseJSON (String t) = either (const $ fail "Failed to parse compiler version") pure (parseActualCompiler t)
parseJSON _ = fail "Invalid CompilerVersion, must be String"
instance FromJSONKey ActualCompiler where
fromJSONKey = FromJSONKeyTextParser $ \k ->
case parseActualCompiler k of
Left _ -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k
- Right parsed -> return parsed
+ Right parsed -> pure parsed
instance PersistField ActualCompiler where
toPersistValue = toPersistValue . compilerVersionText
fromPersistValue = (mapLeft tshow . parseActualCompiler) <=< fromPersistValue
instance PersistFieldSql ActualCompiler where
sqlType _ = SqlString
-data CompilerException
- = GhcjsNotSupported
- | PantryException PantryException
-
-instance Show CompilerException where
- show GhcjsNotSupported = "GHCJS is no longer supported by Stack"
- show (PantryException p) = displayException p
-instance Exception CompilerException
-
wantedToActual :: WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual (WCGhc x) = Right $ ACGhc x
wantedToActual (WCGhcjs _ _) = Left GhcjsNotSupported
@@ -118,7 +124,7 @@
deriving (Show)
instance FromJSON CompilerRepository where
- parseJSON = withText "CompilerRepository" (return . CompilerRepository)
+ parseJSON = withText "CompilerRepository" (pure . CompilerRepository)
defaultCompilerRepository :: CompilerRepository
defaultCompilerRepository = CompilerRepository "https://gitlab.haskell.org/ghc/ghc.git"
diff --git a/src/Stack/Types/CompilerBuild.hs b/src/Stack/Types/CompilerBuild.hs
--- a/src/Stack/Types/CompilerBuild.hs
+++ b/src/Stack/Types/CompilerBuild.hs
@@ -1,14 +1,14 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Stack.Types.CompilerBuild
- (CompilerBuild(..)
- ,compilerBuildName
- ,compilerBuildSuffix
- ,parseCompilerBuild
+ ( CompilerBuild (..)
+ , compilerBuildName
+ , compilerBuildSuffix
+ , parseCompilerBuild
) where
import Stack.Prelude
-import Pantry.Internal.AesonExtended (FromJSON, parseJSON, withText)
+import Pantry.Internal.AesonExtended ( FromJSON, parseJSON, withText )
import Data.Text as T
data CompilerBuild
@@ -21,7 +21,7 @@
parseJSON =
withText
"CompilerBuild"
- (either (fail . show) return . parseCompilerBuild . T.unpack)
+ (either (fail . show) pure . parseCompilerBuild . T.unpack)
-- | Descriptive name for compiler build
compilerBuildName :: CompilerBuild -> String
@@ -35,6 +35,6 @@
-- | Parse compiler build from a String.
parseCompilerBuild :: (MonadThrow m) => String -> m CompilerBuild
-parseCompilerBuild "" = return CompilerBuildStandard
-parseCompilerBuild "standard" = return CompilerBuildStandard
-parseCompilerBuild name = return (CompilerBuildSpecialized name)
+parseCompilerBuild "" = pure CompilerBuildStandard
+parseCompilerBuild "standard" = pure CompilerBuildStandard
+parseCompilerBuild name = pure (CompilerBuildSpecialized name)
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
@@ -22,207 +22,211 @@
(
-- * Main configuration types and classes
-- ** HasPlatform & HasStackRoot
- HasPlatform(..)
- ,PlatformVariant(..)
+ HasPlatform (..)
+ , PlatformVariant (..)
-- ** Runner
- ,HasRunner(..)
- ,Runner(..)
- ,ColorWhen(..)
- ,terminalL
- ,reExecL
+ , HasRunner (..)
+ , Runner (..)
+ , ColorWhen (..)
+ , terminalL
+ , reExecL
-- ** Config & HasConfig
- ,Config(..)
- ,HasConfig(..)
- ,askLatestSnapshotUrl
- ,configProjectRoot
+ , Config (..)
+ , HasConfig (..)
+ , askLatestSnapshotUrl
+ , configProjectRoot
-- ** BuildConfig & HasBuildConfig
- ,BuildConfig(..)
- ,ProjectPackage(..)
- ,DepPackage(..)
- ,ppRoot
- ,ppVersion
- ,ppComponents
- ,ppGPD
- ,stackYamlL
- ,projectRootL
- ,HasBuildConfig(..)
+ , BuildConfig (..)
+ , ProjectPackage (..)
+ , DepPackage (..)
+ , ppRoot
+ , ppVersion
+ , ppComponents
+ , ppGPD
+ , stackYamlL
+ , projectRootL
+ , HasBuildConfig (..)
-- ** Storage databases
- ,UserStorage(..)
- ,ProjectStorage(..)
+ , UserStorage (..)
+ , ProjectStorage (..)
-- ** GHCVariant & HasGHCVariant
- ,GHCVariant(..)
- ,ghcVariantName
- ,ghcVariantSuffix
- ,parseGHCVariant
- ,HasGHCVariant(..)
- ,snapshotsDir
+ , GHCVariant (..)
+ , ghcVariantName
+ , ghcVariantSuffix
+ , parseGHCVariant
+ , HasGHCVariant (..)
+ , snapshotsDir
-- ** EnvConfig & HasEnvConfig
- ,EnvConfig(..)
- ,HasSourceMap(..)
- ,HasEnvConfig(..)
- ,getCompilerPath
+ , EnvConfig (..)
+ , HasSourceMap (..)
+ , HasEnvConfig (..)
+ , getCompilerPath
-- * Details
-- ** ApplyGhcOptions
- ,ApplyGhcOptions(..)
+ , ApplyGhcOptions (..)
+ -- ** AllowNewerDeps
+ , AllowNewerDeps (..)
-- ** CabalConfigKey
- ,CabalConfigKey(..)
+ , CabalConfigKey (..)
-- ** ConfigException
- ,HpackExecutable(..)
- ,ConfigException(..)
+ , HpackExecutable (..)
+ , ConfigException (..)
+ , ConfigPrettyException (..)
+ , ParseAbsolutePathException (..)
+ , packageIndicesWarning
-- ** ConfigMonoid
- ,ConfigMonoid(..)
- ,configMonoidInstallGHCName
- ,configMonoidSystemGHCName
- ,parseConfigMonoid
+ , ConfigMonoid (..)
+ , configMonoidInstallGHCName
+ , configMonoidSystemGHCName
+ , parseConfigMonoid
-- ** DumpLogs
- ,DumpLogs(..)
+ , DumpLogs (..)
-- ** EnvSettings
- ,EnvSettings(..)
- ,minimalEnvSettings
- ,defaultEnvSettings
- ,plainEnvSettings
+ , EnvSettings (..)
+ , minimalEnvSettings
+ , defaultEnvSettings
+ , plainEnvSettings
-- ** GlobalOpts & GlobalOptsMonoid
- ,GlobalOpts(..)
- ,GlobalOptsMonoid(..)
- ,rslInLogL
- ,StackYamlLoc(..)
- ,stackYamlLocL
- ,LockFileBehavior(..)
- ,readLockFileBehavior
- ,lockFileBehaviorL
- ,defaultLogLevel
+ , GlobalOpts (..)
+ , GlobalOptsMonoid (..)
+ , rslInLogL
+ , StackYamlLoc (..)
+ , stackYamlLocL
+ , LockFileBehavior (..)
+ , readLockFileBehavior
+ , lockFileBehaviorL
+ , defaultLogLevel
-- ** Project & ProjectAndConfigMonoid
- ,Project(..)
- ,ProjectConfig(..)
- ,Curator(..)
- ,ProjectAndConfigMonoid(..)
- ,parseProjectAndConfigMonoid
+ , Project (..)
+ , ProjectConfig (..)
+ , Curator (..)
+ , ProjectAndConfigMonoid (..)
+ , parseProjectAndConfigMonoid
-- ** PvpBounds
- ,PvpBounds(..)
- ,PvpBoundsType(..)
- ,parsePvpBounds
+ , PvpBounds (..)
+ , PvpBoundsType (..)
+ , parsePvpBounds
-- ** ColorWhen
- ,readColorWhen
+ , readColorWhen
-- ** Styles
- ,readStyles
+ , readStyles
-- ** SCM
- ,SCM(..)
+ , SCM(..)
-- * Paths
- ,bindirSuffix
- ,GlobalInfoSource(..)
- ,getProjectWorkDir
- ,docDirSuffix
- ,extraBinDirs
- ,hpcReportDir
- ,installationRootDeps
- ,installationRootLocal
- ,bindirCompilerTools
- ,hoogleRoot
- ,hoogleDatabasePath
- ,packageDatabaseDeps
- ,packageDatabaseExtra
- ,packageDatabaseLocal
- ,platformOnlyRelDir
- ,platformGhcRelDir
- ,platformGhcVerOnlyRelDir
- ,useShaPathOnWindows
- ,shaPath
- ,shaPathForBytes
- ,workDirL
- ,ghcInstallHook
+ , bindirSuffix
+ , GlobalInfoSource (..)
+ , getProjectWorkDir
+ , docDirSuffix
+ , extraBinDirs
+ , hpcReportDir
+ , installationRootDeps
+ , installationRootLocal
+ , bindirCompilerTools
+ , hoogleRoot
+ , hoogleDatabasePath
+ , packageDatabaseDeps
+ , packageDatabaseExtra
+ , packageDatabaseLocal
+ , platformOnlyRelDir
+ , platformGhcRelDir
+ , platformGhcVerOnlyRelDir
+ , useShaPathOnWindows
+ , shaPath
+ , shaPathForBytes
+ , workDirL
+ , ghcInstallHook
-- * Command-related types
- ,AddCommand
+ , AddCommand
-- ** Eval
- ,EvalOpts(..)
+ , EvalOpts (..)
-- ** Exec
- ,ExecOpts(..)
- ,SpecialExecCmd(..)
- ,ExecOptsExtra(..)
+ , ExecOpts (..)
+ , SpecialExecCmd (..)
+ , ExecOptsExtra (..)
-- ** Setup
- ,DownloadInfo(..)
- ,VersionedDownloadInfo(..)
- ,GHCDownloadInfo(..)
- ,SetupInfo(..)
+ , DownloadInfo (..)
+ , VersionedDownloadInfo (..)
+ , GHCDownloadInfo (..)
+ , SetupInfo (..)
-- ** Docker entrypoint
- ,DockerEntrypoint(..)
- ,DockerUser(..)
- ,module X
+ , DockerEntrypoint (..)
+ , DockerUser (..)
+ , module X
-- * Lens helpers
- ,wantedCompilerVersionL
- ,actualCompilerVersionL
- ,HasCompiler(..)
- ,DumpPackage(..)
- ,CompilerPaths(..)
- ,GhcPkgExe(..)
- ,getGhcPkgExe
- ,cpWhich
- ,ExtraDirs(..)
- ,buildOptsL
- ,globalOptsL
- ,buildOptsInstallExesL
- ,buildOptsMonoidHaddockL
- ,buildOptsMonoidTestsL
- ,buildOptsMonoidBenchmarksL
- ,buildOptsMonoidInstallExesL
- ,buildOptsHaddockL
- ,globalOptsBuildOptsMonoidL
- ,stackRootL
- ,cabalVersionL
- ,whichCompilerL
- ,envOverrideSettingsL
- ,shouldForceGhcColorFlag
- ,appropriateGhcColorFlag
+ , wantedCompilerVersionL
+ , actualCompilerVersionL
+ , HasCompiler (..)
+ , DumpPackage (..)
+ , CompilerPaths (..)
+ , GhcPkgExe (..)
+ , getGhcPkgExe
+ , cpWhich
+ , ExtraDirs (..)
+ , buildOptsL
+ , globalOptsL
+ , buildOptsInstallExesL
+ , buildOptsMonoidHaddockL
+ , buildOptsMonoidTestsL
+ , buildOptsMonoidBenchmarksL
+ , buildOptsMonoidInstallExesL
+ , buildOptsHaddockL
+ , globalOptsBuildOptsMonoidL
+ , stackRootL
+ , stackGlobalConfigL
+ , cabalVersionL
+ , whichCompilerL
+ , envOverrideSettingsL
+ , shouldForceGhcColorFlag
+ , appropriateGhcColorFlag
-- * Helper logging functions
- ,prettyStackDevL
+ , prettyStackDevL
-- * Lens reexport
- ,view
- ,to
+ , view
+ , to
) where
-import Control.Monad.Writer (Writer, tell)
-import Control.Monad.Trans.Except (ExceptT)
-import Crypto.Hash (hashWith, SHA1(..))
-import Stack.Prelude
+import Control.Monad.Writer ( Writer, tell )
+import Control.Monad.Trans.Except ( ExceptT )
+import Crypto.Hash ( hashWith, SHA1 (..) )
import Pantry.Internal.AesonExtended
- (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,
- (.=), (..:), (...:), (..:?), (..!=), Value(Bool),
- withObjectWarnings, WarningParser, Object, jsonSubWarnings,
- jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..),
- FromJSONKeyFunction (FromJSONKeyTextParser))
-import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))
-import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
+ ( ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON
+ , withText, object, (.=), (..:), (...:), (..:?), (..!=)
+ , Value(Bool), withObjectWarnings, WarningParser, Object
+ , jsonSubWarnings, jsonSubWarningsT, jsonSubWarningsTT
+ , WithJSONWarnings (..)
+ , FromJSONKeyFunction (FromJSONKeyTextParser)
+ )
+import Data.Attoparsec.Args ( parseArgs, EscapingMode (Escaping) )
+import qualified Data.ByteArray.Encoding as Mem ( convertToBase, Base(Base16) )
import qualified Data.ByteString.Char8 as S8
-import Data.Coerce (coerce)
-import Data.List (stripPrefix)
+import Data.Coerce ( coerce )
+import Data.List ( stripPrefix )
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import qualified Data.Monoid as Monoid
-import Data.Monoid.Map (MonoidMap(..))
+import Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Set as Set
import qualified Data.Text as T
-import Data.Yaml (ParseException)
+import Data.Yaml ( ParseException )
import qualified Data.Yaml as Yaml
import qualified Distribution.License as C
-import Distribution.ModuleName (ModuleName)
-import Distribution.PackageDescription (GenericPackageDescription)
+import Distribution.ModuleName ( ModuleName )
+import Distribution.PackageDescription ( GenericPackageDescription )
import qualified Distribution.PackageDescription as C
-import Distribution.System (Platform, Arch)
+import Distribution.System ( Platform, Arch )
import qualified Distribution.Text
-import Distribution.Version (anyVersion, mkVersion', mkVersion)
-import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+import Distribution.Version ( anyVersion, mkVersion )
+import Generics.Deriving.Monoid ( memptydefault, mappenddefault )
import Lens.Micro
-import Options.Applicative (ReadM)
+import Options.Applicative ( ReadM )
import qualified Options.Applicative as OA
import qualified Options.Applicative.Types as OA
-import Pantry.Internal (Storage)
+import Pantry.Internal ( Storage )
import Path
-import qualified Paths_stack as Meta
import qualified RIO.List as List
-import RIO.PrettyPrint (HasTerm (..), StyleDoc, prettyWarnL, prettyDebugL)
-import RIO.PrettyPrint.StylesUpdate (StylesUpdate,
- parseStylesUpdateFromString, HasStylesUpdate (..))
import Stack.Constants
+import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.CompilerBuild
import Stack.Types.Docker
@@ -233,14 +237,245 @@
import Stack.Types.SourceMap
import Stack.Types.TemplateName
import Stack.Types.Version
+ ( IntersectingVersionRange (..), VersionCheck (..)
+ , VersionRange, stackVersion, versionRangeText
+ )
import qualified System.FilePath as FilePath
-import System.PosixCompat.Types (UserID, GroupID, FileMode)
-import RIO.Process (ProcessContext, HasProcessContext (..))
-import Casa.Client (CasaRepoPrefix)
+import System.PosixCompat.Types ( UserID, GroupID, FileMode )
+import RIO.Process ( ProcessContext, HasProcessContext (..) )
+import Casa.Client ( CasaRepoPrefix )
-- Re-exports
import Stack.Types.Config.Build as X
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Config" module.
+data ConfigException
+ = ParseCustomSnapshotException Text ParseException
+ | NoProjectConfigFound (Path Abs Dir) (Maybe Text)
+ | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
+ | UnableToExtractArchive Text (Path Abs File)
+ | BadStackVersionException VersionRange
+ | NoSuchDirectory FilePath
+ | ParseGHCVariantException String
+ | BadStackRoot (Path Abs Dir)
+ | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir
+ | UserDoesn'tOwnDirectory (Path Abs Dir)
+ | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
+ | NixRequiresSystemGhc
+ | NoResolverWhenUsingNoProject
+ | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]
+ | NoLTSWithMajorVersion Int
+ | NoLTSFound
+ | MultiplePackageIndices [PackageIndexConfig]
+ deriving (Show, Typeable)
+
+instance Exception ConfigException where
+ displayException (ParseCustomSnapshotException url exception) = concat
+ [ "Error: [S-8981]\n"
+ , "Could not parse '"
+ , T.unpack url
+ , "':\n"
+ , Yaml.prettyPrintParseException exception
+ , "\nSee https://docs.haskellstack.org/en/stable/custom_snapshot/"
+ ]
+ displayException (NoProjectConfigFound dir mcmd) = concat
+ [ "Error: [S-2206]\n"
+ , "Unable to find a stack.yaml file in the current directory ("
+ , toFilePath dir
+ , ") or its ancestors"
+ , case mcmd of
+ Nothing -> ""
+ Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
+ ]
+ displayException (UnexpectedArchiveContents dirs files) = concat
+ [ "Error: [S-4964]\n"
+ , "When unpacking an archive specified in your stack.yaml file, "
+ , "did not find expected contents. Expected: a single directory. Found: "
+ , show ( map (toFilePath . dirname) dirs
+ , map (toFilePath . filename) files
+ )
+ ]
+ displayException (UnableToExtractArchive url file) = concat
+ [ "Error: [S-2040]\n"
+ , "Archive extraction failed. Tarballs and zip archives are supported, \
+ \couldn't handle the following URL, "
+ , T.unpack url
+ , " downloaded to the file "
+ , toFilePath $ filename file
+ ]
+ displayException (BadStackVersionException requiredRange) = concat
+ [ "Error: [S-1641]\n"
+ , "The version of Stack you are using ("
+ , show stackVersion
+ , ") is outside the required\n"
+ ,"version range specified in stack.yaml ("
+ , T.unpack (versionRangeText requiredRange)
+ , ").\n"
+ , "You can upgrade Stack by running:\n\n"
+ , "stack upgrade"
+ ]
+ displayException (NoSuchDirectory dir) = concat
+ [ "Error: [S-8773]\n"
+ , "No directory could be located matching the supplied path: "
+ , dir
+ ]
+ displayException (ParseGHCVariantException v) = concat
+ [ "Error: [S-3938]\n"
+ , "Invalid ghc-variant value: "
+ , v
+ ]
+ displayException (BadStackRoot stackRoot) = concat
+ [ "Error: [S-8530]\n"
+ , "Invalid Stack root: '"
+ , toFilePath stackRoot
+ , "'. Please provide a valid absolute path."
+ ]
+ displayException (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat
+ [ "Error: [S-7613]\n"
+ , "Preventing creation of Stack root '"
+ , toFilePath envStackRoot
+ , "'. Parent directory '"
+ , toFilePath parentDir
+ , "' is owned by someone else."
+ ]
+ displayException (UserDoesn'tOwnDirectory dir) = concat
+ [ "Error: [S-8707]\n"
+ , "You are not the owner of '"
+ , toFilePath dir
+ , "'. Aborting to protect file permissions."
+ , "\nRetry with '--"
+ , T.unpack configMonoidAllowDifferentUserName
+ , "' to disable this precaution."
+ ]
+ displayException ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = T.unpack $ T.concat
+ [ "Error: [S-3605]\n"
+ , "Stack can only control the "
+ , configMonoidGHCVariantName
+ , " of its own GHC installations. Please use '--no-"
+ , configMonoidSystemGHCName
+ , "'."
+ ]
+ displayException NixRequiresSystemGhc = T.unpack $ T.concat
+ [ "Error: [S-6816]\n"
+ , "Stack's Nix integration is incompatible with '--no-system-ghc'. "
+ , "Please use '--"
+ , configMonoidSystemGHCName
+ , "' or disable the Nix integration."
+ ]
+ displayException NoResolverWhenUsingNoProject =
+ "Error: [S-5027]\n"
+ ++ "When using the script command, you must provide a resolver argument"
+ displayException (DuplicateLocalPackageNames pairs) = concat
+ $ "Error: [S-5470]\n"
+ : "The same package name is used in multiple local packages\n"
+ : map go pairs
+ where
+ go (name, dirs) = unlines
+ $ ""
+ : (packageNameString name ++ " used in:")
+ : map goLoc dirs
+ goLoc loc = "- " ++ show loc
+ displayException (NoLTSWithMajorVersion n) = concat
+ [ "Error: [S-3803]\n"
+ , "No LTS release found with major version "
+ , show n
+ , "."
+ ]
+ displayException NoLTSFound =
+ "Error: [S-5472]\n"
+ ++ "No LTS releases found."
+ displayException (MultiplePackageIndices pics) = concat
+ [ "Error: [S-3251]\n"
+ , "When using the 'package-indices' key to override the default "
+ , "package index, you must provide exactly one value, received: "
+ , show pics
+ , "\n"
+ , packageIndicesWarning
+ ]
+
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
+-- "Stack.Config" module.
+data ConfigPrettyException
+ = ParseConfigFileException !(Path Abs File) !ParseException
+ | NoMatchingSnapshot !(NonEmpty SnapName)
+ | ResolverMismatch !RawSnapshotLocation String
+ | ResolverPartial !RawSnapshotLocation !String
+ deriving (Show, Typeable)
+
+instance Pretty ConfigPrettyException where
+ pretty (ParseConfigFileException configFile exception) =
+ "[S-6602]"
+ <> line
+ <> fillSep
+ [ flow "Stack could not load and parse"
+ , style File (pretty configFile)
+ , flow "as a YAML configuraton file."
+ ]
+ <> blankLine
+ <> flow "While loading and parsing, Stack encountered the following \
+ \error:"
+ <> blankLine
+ <> string (Yaml.prettyPrintParseException exception)
+ <> blankLine
+ <> fillSep
+ [ flow "For help about the content of Stack's YAML configuration \
+ \files, see (for the most recent release of Stack)"
+ , style
+ Url
+ "http://docs.haskellstack.org/en/stable/yaml_configuration/"
+ <> "."
+ ]
+ pretty (NoMatchingSnapshot names) =
+ "[S-1833]"
+ <> line
+ <> flow "None of the following snapshots provides a compiler matching \
+ \your package(s):"
+ <> line
+ <> bulletedList (map (fromString . show) (NonEmpty.toList names))
+ <> blankLine
+ <> resolveOptions
+ pretty (ResolverMismatch resolver errDesc) =
+ "[S-6395]"
+ <> line
+ <> fillSep
+ [ "Snapshot"
+ , style Url (pretty $ PrettyRawSnapshotLocation resolver)
+ , flow "does not have a matching compiler to build some or all of \
+ \your package(s)."
+ ]
+ <> blankLine
+ <> indent 4 (string errDesc)
+ <> line
+ <> resolveOptions
+ pretty (ResolverPartial resolver errDesc) =
+ "[S-2422]"
+ <> line
+ <> fillSep
+ [ "Snapshot"
+ , style Url (pretty $ PrettyRawSnapshotLocation resolver)
+ , flow "does not have all the packages to match your requirements."
+ ]
+ <> blankLine
+ <> indent 4 (string errDesc)
+ <> line
+ <> resolveOptions
+
+instance Exception ConfigPrettyException
+
+data ParseAbsolutePathException
+ = ParseAbsolutePathException String String
+ deriving (Show, Typeable)
+
+instance Exception ParseAbsolutePathException where
+ displayException (ParseAbsolutePathException envVar dir) = concat
+ [ "Error: [S-9437]\n"
+ , "Failed to parse "
+ , envVar
+ , " environment variable (expected absolute directory): "
+ , dir
+ ]
+
-- | The base environment that almost everything in Stack runs in,
-- based off of parsing command line options in 'GlobalOpts'. Provides
-- logging and process execution.
@@ -259,9 +494,9 @@
parseJSON v = do
s <- parseJSON v
case s of
- "never" -> return ColorNever
- "always" -> return ColorAlways
- "auto" -> return ColorAuto
+ "never" -> pure ColorNever
+ "always" -> pure ColorAlways
+ "auto" -> pure ColorAuto
_ -> fail ("Unknown color use: " <> s <> ". Expected values of " <>
"option are 'never', 'always', or 'auto'.")
@@ -315,7 +550,7 @@
,configLocalBin :: !(Path Abs Dir)
-- ^ Directory we should install executables into
,configRequireStackVersion :: !VersionRange
- -- ^ Require a version of stack within this range.
+ -- ^ Require a version of Stack within this range.
,configJobs :: !Int
-- ^ How many concurrent jobs to run, defaults to number of capabilities
,configOverrideGccPath :: !(Maybe (Path Abs File))
@@ -354,11 +589,14 @@
,configAllowNewer :: !Bool
-- ^ Ignore version ranges in .cabal files. Funny naming chosen to
-- match cabal.
+ ,configAllowNewerDeps :: !(Maybe [PackageName])
+ -- ^ Ignore dependency upper and lower bounds only for specified
+ -- packages. No effect unless allow-newer is enabled.
,configDefaultTemplate :: !(Maybe TemplateName)
-- ^ The default template to use when none is specified.
-- (If Nothing, the 'default' default template is used.)
,configAllowDifferentUser :: !Bool
- -- ^ Allow users other than the stack root owner to use the stack
+ -- ^ Allow users other than the Stack root owner to use the Stack
-- installation.
,configDumpLogs :: !DumpLogs
-- ^ Dump logs of local non-dependencies when doing a build.
@@ -436,11 +674,24 @@
instance FromJSON ApplyGhcOptions where
parseJSON = withText "ApplyGhcOptions" $ \t ->
case t of
- "targets" -> return AGOTargets
- "locals" -> return AGOLocals
- "everything" -> return AGOEverything
+ "targets" -> pure AGOTargets
+ "locals" -> pure AGOLocals
+ "everything" -> pure AGOEverything
_ -> fail $ "Invalid ApplyGhcOptions: " ++ show t
+newtype AllowNewerDeps = AllowNewerDeps [PackageName]
+ deriving (Show, Read, Eq, Ord, Generic)
+
+instance Semigroup AllowNewerDeps where
+ (<>) = mappenddefault
+
+instance Monoid AllowNewerDeps where
+ mappend = (<>)
+ mempty = memptydefault
+
+instance FromJSON AllowNewerDeps where
+ parseJSON = fmap (AllowNewerDeps . fmap C.mkPackageName) . parseJSON
+
-- | Which build log files to dump
data DumpLogs
= DumpNoLogs -- ^ don't dump any logfiles
@@ -449,15 +700,15 @@
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance FromJSON DumpLogs where
- parseJSON (Bool True) = return DumpAllLogs
- parseJSON (Bool False) = return DumpNoLogs
+ parseJSON (Bool True) = pure DumpAllLogs
+ parseJSON (Bool False) = pure DumpNoLogs
parseJSON v =
withText
"DumpLogs"
(\t ->
- if | t == "none" -> return DumpNoLogs
- | t == "warning" -> return DumpWarningLogs
- | t == "all" -> return DumpAllLogs
+ if | t == "none" -> pure DumpNoLogs
+ | t == "warning" -> pure DumpWarningLogs
+ | t == "all" -> pure DumpAllLogs
| otherwise -> fail ("Invalid DumpLogs: " ++ show t))
v
@@ -511,7 +762,7 @@
data GlobalOpts = GlobalOpts
{ globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version
, globalDockerEntrypoint :: !(Maybe DockerEntrypoint)
- -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
+ -- ^ Data used when Stack is acting as a Docker entrypoint (internal use only)
, globalLogLevel :: !LogLevel -- ^ Log level
, globalTimeInLog :: !Bool -- ^ Whether to include timings in logs.
, globalRSLInLog :: !Bool -- ^ Whether to include raw snapshot layer (RSL) in logs.
@@ -592,7 +843,7 @@
data GlobalOptsMonoid = GlobalOptsMonoid
{ globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version
, globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)
- -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
+ -- ^ Data used when Stack is acting as a Docker entrypoint (internal use only)
, globalMonoidLogLevel :: !(First LogLevel) -- ^ Log level
, globalMonoidTimeInLog :: !FirstTrue -- ^ Whether to include timings in logs.
, globalMonoidRSLInLog :: !FirstFalse -- ^ Whether to include raw snapshot layer (RSL) in logs.
@@ -622,9 +873,9 @@
readColorWhen = do
s <- OA.readerAsk
case s of
- "never" -> return ColorNever
- "always" -> return ColorAlways
- "auto" -> return ColorAuto
+ "never" -> pure ColorNever
+ "always" -> pure ColorAlways
+ "auto" -> pure ColorAuto
_ -> OA.readerError "Expected values of color option are 'never', 'always', or 'auto'."
readStyles :: ReadM StylesUpdate
@@ -788,8 +1039,10 @@
-- ^ See: 'configPrefixTimestamps'
, configMonoidLatestSnapshot :: !(First Text)
-- ^ See: 'configLatestSnapshot'
- , configMonoidPackageIndices :: !(First [HackageSecurityConfig])
- -- ^ See: @picIndices@
+ , configMonoidPackageIndex :: !(First PackageIndexConfig)
+ -- ^ See: 'withPantryConfig'
+ , configMonoidPackageIndices :: !(First [PackageIndexConfig])
+ -- ^ Deprecated in favour of package-index
, configMonoidSystemGHC :: !(First Bool)
-- ^ See: 'configSystemGHC'
,configMonoidInstallGHC :: !FirstTrue
@@ -858,11 +1111,13 @@
-- ^ See 'configApplyGhcOptions'
,configMonoidAllowNewer :: !(First Bool)
-- ^ See 'configMonoidAllowNewer'
+ ,configMonoidAllowNewerDeps :: !(Maybe AllowNewerDeps)
+ -- ^ See 'configMonoidAllowNewerDeps'
,configMonoidDefaultTemplate :: !(First TemplateName)
-- ^ The default template to use when none is specified.
-- (If Nothing, the 'default' default template is used.)
, configMonoidAllowDifferentUser :: !(First Bool)
- -- ^ Allow users other than the stack root owner to use the stack
+ -- ^ Allow users other than the Stack root owner to use the Stack
-- installation.
, configMonoidDumpLogs :: !(First DumpLogs)
-- ^ See 'configDumpLogs'
@@ -921,6 +1176,7 @@
(\o -> First <$> o ..:? "latest-snapshot" :: WarningParser (First Text))
urls
+ configMonoidPackageIndex <- First <$> jsonSubWarningsT (obj ..:? configMonoidPackageIndexName)
configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)
configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName
configMonoidInstallGHC <- FirstTrue <$> obj ..:? configMonoidInstallGHCName
@@ -945,11 +1201,11 @@
templates <- obj ..:? "templates"
(configMonoidScmInit,configMonoidTemplateParameters) <-
case templates of
- Nothing -> return (First Nothing,M.empty)
+ Nothing -> pure (First Nothing,M.empty)
Just tobj -> do
scmInit <- tobj ..:? configMonoidScmInitName
params <- tobj ..:? configMonoidTemplateParametersName
- return (First scmInit,fromMaybe M.empty params)
+ pure (First scmInit,fromMaybe M.empty params)
configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName
configMonoidCompilerRepository <- First <$> (obj ..:? configMonoidCompilerRepositoryName)
@@ -958,11 +1214,11 @@
optionsEverything <-
case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of
(Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options"
- (Nothing, Just x) -> return x
+ (Nothing, Just x) -> pure x
(Just x, Nothing) -> do
tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything"
- return x
- (Nothing, Nothing) -> return []
+ pure x
+ (Nothing, Nothing) -> pure []
let configMonoidGhcOptionsByCat = coerce $ Map.fromList
[ (AGOEverything, optionsEverything)
@@ -985,6 +1241,7 @@
configMonoidRebuildGhcOptions <- FirstFalse <$> obj ..:? configMonoidRebuildGhcOptionsName
configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName
configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName
+ configMonoidAllowNewerDeps <- obj ..:? configMonoidAllowNewerDepsName
configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName
configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName
configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName
@@ -1010,7 +1267,7 @@
configMonoidStackDeveloperMode <- First <$> obj ..:? configMonoidStackDeveloperModeName
- return ConfigMonoid {..}
+ pure ConfigMonoid {..}
configMonoidWorkDirName :: Text
configMonoidWorkDirName = "work-dir"
@@ -1036,6 +1293,10 @@
configMonoidUrlsName :: Text
configMonoidUrlsName = "urls"
+configMonoidPackageIndexName :: Text
+configMonoidPackageIndexName = "package-index"
+
+-- Deprecated in favour of package-index
configMonoidPackageIndicesName :: Text
configMonoidPackageIndicesName = "package-indices"
@@ -1129,6 +1390,9 @@
configMonoidAllowNewerName :: Text
configMonoidAllowNewerName = "allow-newer"
+configMonoidAllowNewerDepsName :: Text
+configMonoidAllowNewerDepsName = "allow-newer-deps"
+
configMonoidDefaultTemplateName :: Text
configMonoidDefaultTemplateName = "default-template"
@@ -1174,147 +1438,26 @@
configMonoidStackDeveloperModeName :: Text
configMonoidStackDeveloperModeName = "stack-developer-mode"
-data ConfigException
- = ParseConfigFileException (Path Abs File) ParseException
- | ParseCustomSnapshotException Text ParseException
- | NoProjectConfigFound (Path Abs Dir) (Maybe Text)
- | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
- | UnableToExtractArchive Text (Path Abs File)
- | BadStackVersionException VersionRange
- | NoMatchingSnapshot (NonEmpty SnapName)
- | ResolverMismatch !RawSnapshotLocation String
- | ResolverPartial !RawSnapshotLocation String
- | NoSuchDirectory FilePath
- | ParseGHCVariantException String
- | BadStackRoot (Path Abs Dir)
- | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir
- | UserDoesn'tOwnDirectory (Path Abs Dir)
- | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
- | NixRequiresSystemGhc
- | NoResolverWhenUsingNoProject
- | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]
- deriving Typeable
-instance Show ConfigException where
- show (ParseConfigFileException configFile exception) = concat
- [ "Could not parse '"
- , toFilePath configFile
- , "':\n"
- , Yaml.prettyPrintParseException exception
- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"
- ]
- show (ParseCustomSnapshotException url exception) = concat
- [ "Could not parse '"
- , T.unpack url
- , "':\n"
- , Yaml.prettyPrintParseException exception
- , "\nSee https://docs.haskellstack.org/en/stable/custom_snapshot/"
- ]
- show (NoProjectConfigFound dir mcmd) = concat
- [ "Unable to find a stack.yaml file in the current directory ("
- , toFilePath dir
- , ") or its ancestors"
- , case mcmd of
- Nothing -> ""
- Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
- ]
- show (UnexpectedArchiveContents dirs files) = concat
- [ "When unpacking an archive specified in your stack.yaml file, "
- , "did not find expected contents. Expected: a single directory. Found: "
- , show ( map (toFilePath . dirname) dirs
- , map (toFilePath . filename) files
- )
- ]
- show (UnableToExtractArchive url file) = concat
- [ "Archive extraction failed. Tarballs and zip archives are supported, couldn't handle the following URL, "
- , T.unpack url, " downloaded to the file ", toFilePath $ filename file
- ]
- show (BadStackVersionException requiredRange) = concat
- [ "The version of stack you are using ("
- , show (mkVersion' Meta.version)
- , ") is outside the required\n"
- ,"version range specified in stack.yaml ("
- , T.unpack (versionRangeText requiredRange)
- , ").\n"
- , "You can upgrade stack by running:\n\n"
- , "stack upgrade"
- ]
- show (NoMatchingSnapshot names) = concat
- [ "None of the following snapshots provides a compiler matching "
- , "your package(s):\n"
- , unlines $ map (\name -> " - " <> show name)
- (NonEmpty.toList names)
- , resolveOptions
- ]
- show (ResolverMismatch resolver errDesc) = concat
- [ "Resolver '"
- , T.unpack $ utf8BuilderToText $ display resolver
- , "' does not have a matching compiler to build some or all of your "
- , "package(s).\n"
- , errDesc
- , resolveOptions
- ]
- show (ResolverPartial resolver errDesc) = concat
- [ "Resolver '"
- , T.unpack $ utf8BuilderToText $ display resolver
- , "' does not have all the packages to match your requirements.\n"
- , unlines $ fmap (" " <>) (lines errDesc)
- , resolveOptions
- ]
- show (NoSuchDirectory dir) =
- "No directory could be located matching the supplied path: " ++ dir
- show (ParseGHCVariantException v) =
- "Invalid ghc-variant value: " ++ v
- show (BadStackRoot stackRoot) = concat
- [ "Invalid stack root: '"
- , toFilePath stackRoot
- , "'. Please provide a valid absolute path."
- ]
- show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat
- [ "Preventing creation of stack root '"
- , toFilePath envStackRoot
- , "'. Parent directory '"
- , toFilePath parentDir
- , "' is owned by someone else."
- ]
- show (UserDoesn'tOwnDirectory dir) = concat
- [ "You are not the owner of '"
- , toFilePath dir
- , "'. Aborting to protect file permissions."
- , "\nRetry with '--"
- , T.unpack configMonoidAllowDifferentUserName
- , "' to disable this precaution."
- ]
- show ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = T.unpack $ T.concat
- [ "stack can only control the "
- , configMonoidGHCVariantName
- , " of its own GHC installations. Please use '--no-"
- , configMonoidSystemGHCName
- , "'."
- ]
- show NixRequiresSystemGhc = T.unpack $ T.concat
- [ "stack's Nix integration is incompatible with '--no-system-ghc'. "
- , "Please use '--"
- , configMonoidSystemGHCName
- , "' or disable the Nix integration."
- ]
- show NoResolverWhenUsingNoProject = "When using the script command, you must provide a resolver argument"
- 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 goLoc dirs
- goLoc loc = "- " ++ show loc
-instance Exception ConfigException
+packageIndicesWarning :: String
+packageIndicesWarning =
+ "The 'package-indices' key is deprecated in favour of 'package-index'."
-resolveOptions :: String
+resolveOptions :: StyleDoc
resolveOptions =
- unlines [ "\nThis may be resolved by:"
- , " - Using '--omit-packages' to exclude mismatching package(s)."
- , " - Using '--resolver' to specify a matching snapshot/resolver"
- ]
+ flow "This may be resolved by:"
+ <> line
+ <> bulletedList
+ [ fillSep
+ [ "Using"
+ , style Shell "--omit-packages"
+ , "to exclude mismatching package(s)."
+ ]
+ , fillSep
+ [ "Using"
+ , style Shell "--resolver"
+ , "to specify a matching snapshot/resolver."
+ ]
+ ]
-- | Get the URL to request the information on the latest snapshots
askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
@@ -1341,7 +1484,7 @@
getProjectWorkDir = do
root <- view projectRootL
workDir <- view workDirL
- return (root workDir)
+ pure (root workDir)
-- | Relative directory for the platform identifier
platformOnlyRelDir
@@ -1357,7 +1500,7 @@
snapshotsDir = do
root <- view stackRootL
platform <- platformGhcRelDir
- return $ root relDirSnapshots platform
+ pure $ root relDirSnapshots platform
-- | Installation root for dependencies
installationRootDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)
@@ -1365,14 +1508,14 @@
root <- view stackRootL
-- TODO: also useShaPathOnWindows here, once #1173 is resolved.
psc <- platformSnapAndCompilerRel
- return $ root relDirSnapshots psc
+ pure $ root relDirSnapshots psc
-- | Installation root for locals
installationRootLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)
installationRootLocal = do
workDir <- getProjectWorkDir
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
- return $ workDir relDirInstall psc
+ pure $ workDir relDirInstall psc
-- | Installation root for compiler tools
bindirCompilerTools :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
@@ -1381,7 +1524,7 @@
platform <- platformGhcRelDir
compilerVersion <- view actualCompilerVersionL
compiler <- parseRelDir $ compilerVersionString compilerVersion
- return $
+ pure $
view stackRootL config
relDirCompilerTools
platform
@@ -1393,13 +1536,13 @@
hoogleRoot = do
workDir <- getProjectWorkDir
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
- return $ workDir relDirHoogle psc
+ pure $ workDir relDirHoogle psc
-- | Get the hoogle database path.
hoogleDatabasePath :: (HasEnvConfig env) => RIO env (Path Abs File)
hoogleDatabasePath = do
dir <- hoogleRoot
- return (dir relFileDatabaseHoo)
+ pure (dir relFileDatabaseHoo)
-- | Path for platform followed by snapshot name followed by compiler
-- name.
@@ -1439,11 +1582,11 @@
platform <- view platformL
platformVariant <- view platformVariantL
ghcVariant <- view ghcVariantL
- return $ mconcat [ Distribution.Text.display platform
+ pure $ mconcat [ Distribution.Text.display platform
, platformVariantSuffix platformVariant
, ghcVariantSuffix ghcVariant ]
--- | This is an attempt to shorten stack paths on Windows to decrease our
+-- | This is an attempt to shorten Stack paths on Windows to decrease our
-- chances of hitting 260 symbol path limit. The idea is to calculate
-- SHA1 hash of the path used on other architectures, encode with base
-- 16 and take first 8 symbols of it.
@@ -1481,13 +1624,13 @@
packageDatabaseDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)
packageDatabaseDeps = do
root <- installationRootDeps
- return $ root relDirPkgdb
+ pure $ root relDirPkgdb
-- | Package database for installing local packages into
packageDatabaseLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)
packageDatabaseLocal = do
root <- installationRootLocal
- return $ root relDirPkgdb
+ pure $ root relDirPkgdb
-- | Extra package databases
packageDatabaseExtra :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
@@ -1506,7 +1649,7 @@
=> RIO env (Path Abs Dir)
hpcReportDir = do
root <- installationRootLocal
- return $ root relDirHpc
+ pure $ root relDirHpc
-- | Get the extra bin directories (for the PATH). Puts more local first
--
@@ -1517,7 +1660,7 @@
deps <- installationRootDeps
local' <- installationRootLocal
tools <- bindirCompilerTools
- return $ \locals -> if locals
+ pure $ \locals -> if locals
then [local' bindirSuffix, deps bindirSuffix, tools]
else [deps bindirSuffix, tools]
@@ -1582,7 +1725,7 @@
extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
mcurator <- jsonSubWarningsT (o ..:? "curator")
drops <- o ..:? "drop-packages" ..!= mempty
- return $ do
+ pure $ do
deps' <- mapM (resolvePaths (Just rootDir)) deps
resolver' <- resolvePaths (Just rootDir) resolver
let project = Project
@@ -1606,7 +1749,7 @@
parseJSON v = do
s <- parseJSON v
case s of
- "git" -> return Git
+ "git" -> pure Git
_ -> fail ("Unknown or unsupported SCM: " <> s)
instance ToJSON SCM where
@@ -1638,7 +1781,7 @@
parseJSON =
withText
"GHCVariant"
- (either (fail . show) return . parseGHCVariant . T.unpack)
+ (either (fail . show) pure . parseGHCVariant . T.unpack)
-- | Render a GHC variant to a String.
ghcVariantName :: GHCVariant -> String
@@ -1656,13 +1799,13 @@
parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant
parseGHCVariant s =
case stripPrefix "custom-" s of
- Just name -> return (GHCCustom name)
+ Just name -> pure (GHCCustom name)
Nothing
- | s == "" -> return GHCStandard
- | s == "standard" -> return GHCStandard
- | s == "integersimple" -> return GHCIntegerSimple
- | s == "int-native" -> return GHCNativeBignum
- | otherwise -> return (GHCCustom s)
+ | s == "" -> pure GHCStandard
+ | s == "standard" -> pure GHCStandard
+ | s == "integersimple" -> pure GHCIntegerSimple
+ | s == "int-native" -> pure GHCNativeBignum
+ | otherwise -> pure (GHCCustom s)
-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)
-- | Information for a file to download.
@@ -1684,7 +1827,7 @@
contentLength <- o ..:? "content-length"
sha1TextMay <- o ..:? "sha1"
sha256TextMay <- o ..:? "sha256"
- return
+ pure
DownloadInfo
{ downloadInfoUrl = url
, downloadInfoContentLength = contentLength
@@ -1702,7 +1845,7 @@
parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do
CabalString version <- o ..: "version"
downloadInfo <- parseDownloadInfoFromObject o
- return VersionedDownloadInfo
+ pure VersionedDownloadInfo
{ vdiVersion = version
, vdiDownloadInfo = downloadInfo
}
@@ -1719,7 +1862,7 @@
configureOpts <- o ..:? "configure-opts" ..!= mempty
configureEnv <- o ..:? "configure-env" ..!= mempty
downloadInfo <- parseDownloadInfoFromObject o
- return GHCDownloadInfo
+ pure GHCDownloadInfo
{ gdiConfigureOpts = configureOpts
, gdiConfigureEnv = configureEnv
, gdiDownloadInfo = downloadInfo
@@ -1741,7 +1884,7 @@
siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)
(fmap unCabalStringMap -> siGHCs) <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)
(fmap unCabalStringMap -> siStack) <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)
- return SetupInfo {..}
+ pure SetupInfo {..}
-- | For the @siGHCs@ field maps are deeply merged.
-- For all fields the values from the first @SetupInfo@ win.
@@ -1805,7 +1948,7 @@
toJSON (PvpBounds typ asRevision) =
toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))
instance FromJSON PvpBounds where
- parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
+ parseJSON = withText "PvpBounds" (either fail pure . parsePvpBounds)
-- | Data passed into Docker container for the Docker entrypoint's use
newtype DockerEntrypoint = DockerEntrypoint
@@ -1832,14 +1975,14 @@
instance FromJSONKey GhcOptionKey where
fromJSONKey = FromJSONKeyTextParser $ \t ->
case t of
- "*" -> return GOKOldEverything
- "$everything" -> return GOKEverything
- "$locals" -> return GOKLocals
- "$targets" -> return GOKTargets
+ "*" -> pure GOKOldEverything
+ "$everything" -> pure GOKEverything
+ "$locals" -> pure GOKLocals
+ "$targets" -> pure GOKTargets
_ ->
case parsePackageName $ T.unpack t of
Nothing -> fail $ "Invalid package name: " ++ show t
- Just x -> return $ GOKPackage x
+ Just x -> pure $ GOKPackage x
fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList"
newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] }
@@ -1848,7 +1991,7 @@
parseJSON = withText "GhcOptions" $ \t ->
case parseArgs Escaping t of
Left e -> fail e
- Right opts -> return $ GhcOptions $ map T.pack opts
+ Right opts -> pure $ GhcOptions $ map T.pack opts
-----------------------------------
-- Lens classes
@@ -1999,6 +2142,9 @@
stackRootL :: HasConfig s => Lens' s (Path Abs Dir)
stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y })
+stackGlobalConfigL :: HasConfig s => Lens' s (Path Abs File)
+stackGlobalConfigL = configL.lens configUserConfigPath (\x y -> x { configUserConfigPath = y })
+
-- | The compiler specified by the @SnapshotDef@. This may be
-- different from the actual compiler used!
wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler
@@ -2044,12 +2190,12 @@
-- | Is this a Stack-sandboxed installation?
, cpSandboxed :: !Bool
, cpCabalVersion :: !Version
- -- ^ This is the version of Cabal that stack will use to compile Setup.hs files
+ -- ^ This is the version of Cabal that Stack will use to compile Setup.hs files
-- in the build process.
--
- -- Note that this is not necessarily the same version as the one that stack
+ -- Note that this is not necessarily the same version as the one that Stack
-- depends on as a library and which is displayed when running
- -- @stack ls dependencies | grep Cabal@ in the stack project.
+ -- @stack ls dependencies | grep Cabal@ in the Stack project.
, cpGlobalDB :: !(Path Abs Dir)
-- ^ Global package database
, cpGhcInfo :: !ByteString
@@ -2149,7 +2295,7 @@
canDoColor <- (>= mkVersion [8, 2, 1]) . getGhcVersion
<$> view actualCompilerVersionL
shouldDoColor <- view useColorL
- return $ canDoColor && shouldDoColor
+ pure $ canDoColor && shouldDoColor
appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env)
=> RIO env (Maybe String)
diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs
--- a/src/Stack/Types/Config/Build.hs
+++ b/src/Stack/Types/Config/Build.hs
@@ -8,23 +8,23 @@
module Stack.Types.Config.Build
(
- BuildOpts(..)
- , BuildCommand(..)
+ BuildOpts (..)
+ , BuildCommand (..)
, defaultBuildOpts
, defaultBuildOptsCLI
- , BuildOptsCLI(..)
- , BuildOptsMonoid(..)
- , TestOpts(..)
+ , BuildOptsCLI (..)
+ , BuildOptsMonoid (..)
+ , TestOpts (..)
, defaultTestOpts
- , TestOptsMonoid(..)
- , HaddockOpts(..)
+ , TestOptsMonoid (..)
+ , HaddockOpts (..)
, defaultHaddockOpts
- , HaddockOptsMonoid(..)
- , BenchmarkOpts(..)
+ , HaddockOptsMonoid (..)
+ , BenchmarkOpts (..)
, defaultBenchmarkOpts
- , BenchmarkOptsMonoid(..)
- , FileWatchOpts(..)
- , BuildSubset(..)
+ , BenchmarkOptsMonoid (..)
+ , FileWatchOpts (..)
+ , BuildSubset (..)
, ApplyCLIFlag (..)
, boptsCLIFlagsByName
, CabalVerbosity (..)
@@ -34,9 +34,9 @@
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
-import Distribution.Parsec (Parsec (..), simpleParsec)
-import Distribution.Verbosity (Verbosity, normal, verbose)
-import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+import Distribution.Parsec ( Parsec (..), simpleParsec )
+import Distribution.Verbosity ( Verbosity, normal, verbose )
+import Generics.Deriving.Monoid ( memptydefault, mappenddefault )
import Pantry.Internal.AesonExtended
import Stack.Prelude
@@ -254,7 +254,7 @@
buildMonoidSkipComponents <- o ..:? buildMonoidSkipComponentsName ..!= mempty
buildMonoidInterleavedOutput <- FirstTrue <$> o ..:? buildMonoidInterleavedOutputName
buildMonoidDdumpDir <- o ..:? buildMonoidDdumpDirName ..!= mempty
- return BuildOptsMonoid{..})
+ pure BuildOptsMonoid{..})
buildMonoidLibProfileArgName :: Text
buildMonoidLibProfileArgName = "library-profiling"
@@ -363,6 +363,7 @@
,toCoverage :: !Bool -- ^ Generate a code coverage report
,toDisableRun :: !Bool -- ^ Disable running of tests
,toMaximumTimeSeconds :: !(Maybe Int) -- ^ test suite timeout in seconds
+ ,toAllowStdin :: !Bool -- ^ Whether to allow standard input
} deriving (Eq,Show)
defaultTestOpts :: TestOpts
@@ -372,6 +373,7 @@
, toCoverage = defaultFirstFalse toMonoidCoverage
, toDisableRun = defaultFirstFalse toMonoidDisableRun
, toMaximumTimeSeconds = Nothing
+ , toAllowStdin = defaultFirstTrue toMonoidAllowStdin
}
data TestOptsMonoid =
@@ -381,6 +383,7 @@
, toMonoidCoverage :: !FirstFalse
, toMonoidDisableRun :: !FirstFalse
, toMonoidMaximumTimeSeconds :: !(First (Maybe Int))
+ , toMonoidAllowStdin :: !FirstTrue
} deriving (Show, Generic)
instance FromJSON (WithJSONWarnings TestOptsMonoid) where
@@ -390,7 +393,8 @@
toMonoidCoverage <- FirstFalse <$> o ..:? toMonoidCoverageArgName
toMonoidDisableRun <- FirstFalse <$> o ..:? toMonoidDisableRunArgName
toMonoidMaximumTimeSeconds <- First <$> o ..:? toMonoidMaximumTimeSecondsArgName
- return TestOptsMonoid{..})
+ toMonoidAllowStdin <- FirstTrue <$> o ..:? toMonoidTestsAllowStdinName
+ pure TestOptsMonoid{..})
toMonoidRerunTestsArgName :: Text
toMonoidRerunTestsArgName = "rerun-tests"
@@ -407,6 +411,9 @@
toMonoidMaximumTimeSecondsArgName :: Text
toMonoidMaximumTimeSecondsArgName = "test-suite-timeout"
+toMonoidTestsAllowStdinName :: Text
+toMonoidTestsAllowStdinName = "tests-allow-stdin"
+
instance Semigroup TestOptsMonoid where
(<>) = mappenddefault
@@ -431,7 +438,7 @@
instance FromJSON (WithJSONWarnings HaddockOptsMonoid) where
parseJSON = withObjectWarnings "HaddockOptsMonoid"
(\o -> do hoMonoidAdditionalArgs <- o ..:? hoMonoidAdditionalArgsName ..!= []
- return HaddockOptsMonoid{..})
+ pure HaddockOptsMonoid{..})
instance Semigroup HaddockOptsMonoid where
(<>) = mappenddefault
@@ -467,7 +474,7 @@
parseJSON = withObjectWarnings "BenchmarkOptsMonoid"
(\o -> do beoMonoidAdditionalArgs <- First <$> o ..:? beoMonoidAdditionalArgsArgName
beoMonoidDisableRun <- First <$> o ..:? beoMonoidDisableRunArgName
- return BenchmarkOptsMonoid{..})
+ pure BenchmarkOptsMonoid{..})
beoMonoidAdditionalArgsArgName :: Text
beoMonoidAdditionalArgsArgName = "benchmark-arguments"
diff --git a/src/Stack/Types/Dependency.hs b/src/Stack/Types/Dependency.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/Dependency.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Stack.Types.Dependency
+ ( DepValue (..)
+ , DepType (..)
+ ) where
+
+import Distribution.Types.VersionRange ( VersionRange )
+import Stack.Prelude
+import Stack.Types.Version ( intersectVersionRanges )
+
+
+-- | The value for a map from dependency name. This contains both the
+-- version range and the type of dependency, and provides a semigroup
+-- instance.
+data DepValue = DepValue
+ { dvVersionRange :: !VersionRange
+ , dvType :: !DepType
+ }
+ deriving (Show, Typeable)
+instance Semigroup DepValue where
+ DepValue a x <> DepValue b y = DepValue (intersectVersionRanges a b) (x <> y)
+
+-- | Is this package being used as a library, or just as a build tool?
+-- If the former, we need to ensure that a library actually
+-- exists. See
+--
+data DepType = AsLibrary | AsBuildTool
+ deriving (Show, Eq)
+instance Semigroup DepType where
+ AsLibrary <> _ = AsLibrary
+ AsBuildTool <> x = x
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
@@ -7,133 +7,348 @@
-- | Docker types.
-module Stack.Types.Docker where
+module Stack.Types.Docker
+ ( DockerException (..)
+ , DockerMonoidRepoOrImage (..)
+ , DockerOpts (..)
+ , DockerOptsMonoid (..)
+ , DockerStackExe (..)
+ , Mount (..)
+ , VersionRangeJSON (..)
+ , dockerAutoPullArgName
+ , dockerCmdName
+ , dockerContainerNameArgName
+ , dockerContainerPlatform
+ , dockerDetachArgName
+ , dockerEnableArgName
+ , dockerEntrypointArgName
+ , dockerEnvArgName
+ , dockerHelpOptName
+ , dockerImageArgName
+ , dockerMountArgName
+ , dockerMountModeArgName
+ , dockerNetworkArgName
+ , dockerPersistArgName
+ , dockerPullCmdName
+ , dockerRegistryLoginArgName
+ , dockerRegistryPasswordArgName
+ , dockerRegistryUsernameArgName
+ , dockerRepoArgName
+ , dockerRequireDockerVersionArgName
+ , dockerRunArgsArgName
+ , dockerSetUserArgName
+ , dockerStackExeArgName
+ , dockerStackExeDownloadVal
+ , dockerStackExeHostVal
+ , dockerStackExeImageVal
+ , parseDockerStackExe
+ , reExecArgName
+ ) where
-import Stack.Prelude hiding (Display (..))
-import Pantry.Internal.AesonExtended
-import Data.List (intercalate)
+import Data.List ( intercalate )
import qualified Data.Text as T
-import Distribution.System (Platform(..), OS(..), Arch(..))
-import Distribution.Text (simpleParse, display)
-import Distribution.Version (anyVersion)
-import Generics.Deriving.Monoid (mappenddefault, memptydefault)
-import Path
-import Stack.Types.Version
-import Text.Read (Read (..))
+import Distribution.System ( Platform (..), OS (..), Arch (..) )
+import Distribution.Text ( simpleParse, display )
+import Distribution.Version ( anyVersion )
+import Generics.Deriving.Monoid ( mappenddefault, memptydefault )
+import Pantry.Internal.AesonExtended
+import Path
+import Stack.Prelude hiding ( Display (..) )
+import Stack.Types.Version
+import Text.Read ( Read (..) )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Docker" module.
+data DockerException
+ = DockerMustBeEnabledException
+ -- ^ Docker must be enabled to use the command.
+ | OnlyOnHostException
+ -- ^ Command must be run on host OS (not in a container).
+ | InspectFailedException String
+ -- ^ @docker inspect@ failed.
+ | NotPulledException String
+ -- ^ Image does not exist.
+ | InvalidImagesOutputException String
+ -- ^ Invalid output from @docker images@.
+ | InvalidPSOutputException String
+ -- ^ Invalid output from @docker ps@.
+ | InvalidInspectOutputException String
+ -- ^ Invalid output from @docker inspect@.
+ | PullFailedException String
+ -- ^ Could not pull a Docker image.
+ | DockerTooOldException Version Version
+ -- ^ Installed version of @docker@ below minimum version.
+ | DockerVersionProhibitedException [Version] Version
+ -- ^ Installed version of @docker@ is prohibited.
+ | BadDockerVersionException VersionRange Version
+ -- ^ Installed version of @docker@ is out of range specified in config file.
+ | InvalidVersionOutputException
+ -- ^ Invalid output from @docker --version@.
+ | HostStackTooOldException Version (Maybe Version)
+ -- ^ Version of @stack@ on host is too old for version in image.
+ | ContainerStackTooOldException Version Version
+ -- ^ Version of @stack@ in container/image is too old for version on host.
+ | CannotDetermineProjectRootException
+ -- ^ Can't determine the project root (where to put docker sandbox).
+ | DockerNotInstalledException
+ -- ^ @docker --version@ failed.
+ | UnsupportedStackExeHostPlatformException
+ -- ^ Using host stack-exe on unsupported platform.
+ | DockerStackExeParseException String
+ -- ^ @stack-exe@ option fails to parse.
+ deriving (Show, Typeable)
+
+instance Exception DockerException where
+ displayException DockerMustBeEnabledException =
+ "Error: [S-3223]\n"
+ ++ "Docker must be enabled in your configuration file to use this \
+ \command."
+ displayException OnlyOnHostException =
+ "Error: [S-9779]\n"
+ ++ "This command must be run on host OS (not in a Docker container)."
+ displayException (InspectFailedException image) = concat
+ [ "Error: [S-9105]\n"
+ , "'docker inspect' failed for image after pull: "
+ , image
+ , "."
+ ]
+ displayException (NotPulledException image) = concat
+ [ "Error: [S-6626]\n"
+ , "The Docker image referenced by your configuration file"
+ , " has not\nbeen downloaded:\n "
+ , image
+ , "\n\nRun '"
+ , unwords [stackProgName, dockerCmdName, dockerPullCmdName]
+ , "' to download it, then try again."
+ ]
+ displayException (InvalidImagesOutputException l) = concat
+ [ "Error: [S-5841]\n"
+ , "Invalid 'docker images' output line: '"
+ , l
+ , "'."
+ ]
+ displayException (InvalidPSOutputException l) = concat
+ [ "Error: [S-9608]\n"
+ , "Invalid 'docker ps' output line: '"
+ , l
+ ,"'."
+ ]
+ displayException (InvalidInspectOutputException msg) = concat
+ [ "Error: [S-2240]\n"
+ , "Invalid 'docker inspect' output: "
+ , msg
+ , "."
+ ]
+ displayException (PullFailedException image) = concat
+ [ "Error: [S-6092]\n"
+ , "Could not pull Docker image:\n "
+ , image
+ , "\nThere may not be an image on the registry for your resolver's LTS \
+ \version in\n"
+ , "your configuration file."
+ ]
+ displayException (DockerTooOldException minVersion haveVersion) = concat
+ [ "Error: [S-6281]\n"
+ , "Minimum docker version '"
+ , versionString minVersion
+ , "' is required by "
+ , stackProgName
+ , " (you have '"
+ , versionString haveVersion
+ , "')."
+ ]
+ displayException (DockerVersionProhibitedException prohibitedVersions haveVersion) = concat
+ [ "Error: [S-8252]\n"
+ , "These Docker versions are incompatible with "
+ , stackProgName
+ , " (you have '"
+ , versionString haveVersion
+ , "'): "
+ , intercalate ", " (map versionString prohibitedVersions)
+ , "."
+ ]
+ displayException (BadDockerVersionException requiredRange haveVersion) = concat
+ [ "Error: [S-6170]\n"
+ , "The version of 'docker' you are using ("
+ , show haveVersion
+ , ") is outside the required\n"
+ , "version range specified in stack.yaml ("
+ , T.unpack (versionRangeText requiredRange)
+ , ")."
+ ]
+ displayException InvalidVersionOutputException =
+ "Error: [S-5827]\n"
+ ++ "Cannot get Docker version (invalid 'docker --version' output)."
+ displayException (HostStackTooOldException minVersion (Just hostVersion)) = concat
+ [ "Error: [S-7112]\n"
+ , "The host's version of '"
+ , stackProgName
+ , "' is too old for this Docker image.\nVersion "
+ , versionString minVersion
+ , " is required; you have "
+ , versionString hostVersion
+ , "."
+ ]
+ displayException (HostStackTooOldException minVersion Nothing) = concat
+ [ "Error: [S-7112]\n"
+ , "The host's version of '"
+ , stackProgName
+ , "' is too old.\nVersion "
+ , versionString minVersion
+ , " is required."
+ ]
+ displayException (ContainerStackTooOldException requiredVersion containerVersion) = concat
+ [ "Error: [S-5832]\n"
+ , "The Docker container's version of '"
+ , stackProgName
+ , "' is too old.\nVersion "
+ , versionString requiredVersion
+ , " is required; the container has "
+ , versionString containerVersion
+ , "."
+ ]
+ displayException CannotDetermineProjectRootException =
+ "Error: [S-4078]\n"
+ ++ "Cannot determine project root directory for Docker sandbox."
+ displayException DockerNotInstalledException =
+ "Error: [S-7058]\n"
+ ++ "Cannot find 'docker' in PATH. Is Docker installed?"
+ displayException UnsupportedStackExeHostPlatformException = concat
+ [ "Error: [S-6894]\n"
+ , "Using host's "
+ , stackProgName
+ , " executable in Docker container is only supported on "
+ , display dockerContainerPlatform
+ , " platform."
+ ]
+ displayException (DockerStackExeParseException s) = concat
+ [ "Error: [S-1512]\n"
+ , "Failed to parse "
+ , show s
+ , ". Expected "
+ , show dockerStackExeDownloadVal
+ , ", "
+ , show dockerStackExeHostVal
+ , ", "
+ , show dockerStackExeImageVal
+ , " or absolute path to executable."
+ ]
+
-- | Docker configuration.
data DockerOpts = DockerOpts
- {dockerEnable :: !Bool
- -- ^ Is using Docker enabled?
- ,dockerImage :: !(Either SomeException String)
- -- ^ Exact Docker image tag or ID. Overrides docker-repo-*/tag.
- ,dockerRegistryLogin :: !Bool
- -- ^ Does registry require login for pulls?
- ,dockerRegistryUsername :: !(Maybe String)
- -- ^ Optional username for Docker registry.
- ,dockerRegistryPassword :: !(Maybe String)
- -- ^ Optional password for Docker registry.
- ,dockerAutoPull :: !Bool
- -- ^ Automatically pull new images.
- ,dockerDetach :: !Bool
- -- ^ Whether to run a detached container
- ,dockerPersist :: !Bool
- -- ^ Create a persistent container (don't remove it when finished). Implied by
- -- `dockerDetach`.
- ,dockerContainerName :: !(Maybe String)
- -- ^ Container name to use, only makes sense from command-line with `dockerPersist`
- -- or `dockerDetach`.
- ,dockerNetwork :: !(Maybe String)
- -- ^ The network docker uses.
- ,dockerRunArgs :: ![String]
- -- ^ Arguments to pass directly to @docker run@.
- ,dockerMount :: ![Mount]
- -- ^ Volumes to mount in the container.
- ,dockerMountMode :: !(Maybe String)
- -- ^ Volume mount mode
- ,dockerEnv :: ![String]
- -- ^ Environment variables to set in the container.
- ,dockerStackExe :: !(Maybe DockerStackExe)
- -- ^ Location of container-compatible stack executable
- ,dockerSetUser :: !(Maybe Bool)
- -- ^ Set in-container user to match host's
- ,dockerRequireDockerVersion :: !VersionRange
- -- ^ Require a version of Docker within this range.
+ { dockerEnable :: !Bool
+ -- ^ Is using Docker enabled?
+ , dockerImage :: !(Either SomeException String)
+ -- ^ Exact Docker image tag or ID. Overrides docker-repo-*/tag.
+ , dockerRegistryLogin :: !Bool
+ -- ^ Does registry require login for pulls?
+ , dockerRegistryUsername :: !(Maybe String)
+ -- ^ Optional username for Docker registry.
+ , dockerRegistryPassword :: !(Maybe String)
+ -- ^ Optional password for Docker registry.
+ , dockerAutoPull :: !Bool
+ -- ^ Automatically pull new images.
+ , dockerDetach :: !Bool
+ -- ^ Whether to run a detached container
+ , dockerPersist :: !Bool
+ -- ^ Create a persistent container (don't remove it when finished). Implied by
+ -- `dockerDetach`.
+ , dockerContainerName :: !(Maybe String)
+ -- ^ Container name to use, only makes sense from command-line with `dockerPersist`
+ -- or `dockerDetach`.
+ , dockerNetwork :: !(Maybe String)
+ -- ^ The network docker uses.
+ , dockerRunArgs :: ![String]
+ -- ^ Arguments to pass directly to @docker run@.
+ , dockerMount :: ![Mount]
+ -- ^ Volumes to mount in the container.
+ , dockerMountMode :: !(Maybe String)
+ -- ^ Volume mount mode
+ , dockerEnv :: ![String]
+ -- ^ Environment variables to set in the container.
+ , dockerStackExe :: !(Maybe DockerStackExe)
+ -- ^ Location of container-compatible Stack executable
+ , dockerSetUser :: !(Maybe Bool)
+ -- ^ Set in-container user to match host's
+ , dockerRequireDockerVersion :: !VersionRange
+ -- ^ Require a version of Docker within this range.
}
deriving (Show)
-- | An uninterpreted representation of docker options.
-- Configurations may be "cascaded" using mappend (left-biased).
data DockerOptsMonoid = DockerOptsMonoid
- {dockerMonoidDefaultEnable :: !Any
- -- ^ Should Docker be defaulted to enabled (does @docker:@ section exist in the config)?
- ,dockerMonoidEnable :: !(First Bool)
- -- ^ Is using Docker enabled?
- ,dockerMonoidRepoOrImage :: !(First DockerMonoidRepoOrImage)
- -- ^ Docker repository name (e.g. @fpco/stack-build@ or @fpco/stack-full:lts-2.8@)
- ,dockerMonoidRegistryLogin :: !(First Bool)
- -- ^ Does registry require login for pulls?
- ,dockerMonoidRegistryUsername :: !(First String)
- -- ^ Optional username for Docker registry.
- ,dockerMonoidRegistryPassword :: !(First String)
- -- ^ Optional password for Docker registry.
- ,dockerMonoidAutoPull :: !FirstTrue
- -- ^ Automatically pull new images.
- ,dockerMonoidDetach :: !FirstFalse
- -- ^ Whether to run a detached container
- ,dockerMonoidPersist :: !FirstFalse
- -- ^ Create a persistent container (don't remove it when finished). Implied by
- -- `dockerDetach`.
- ,dockerMonoidContainerName :: !(First String)
- -- ^ Container name to use, only makes sense from command-line with `dockerPersist`
- -- or `dockerDetach`.
- ,dockerMonoidNetwork :: !(First String)
- -- ^ See: 'dockerNetwork'
- ,dockerMonoidRunArgs :: ![String]
- -- ^ Arguments to pass directly to @docker run@
- ,dockerMonoidMount :: ![Mount]
- -- ^ Volumes to mount in the container
- ,dockerMonoidMountMode :: !(First String)
- -- ^ Volume mount mode
- ,dockerMonoidEnv :: ![String]
- -- ^ Environment variables to set in the container
- ,dockerMonoidStackExe :: !(First DockerStackExe)
- -- ^ Location of container-compatible stack executable
- ,dockerMonoidSetUser :: !(First Bool)
- -- ^ Set in-container user to match host's
- ,dockerMonoidRequireDockerVersion :: !IntersectingVersionRange
- -- ^ See: 'dockerRequireDockerVersion'
+ { dockerMonoidDefaultEnable :: !Any
+ -- ^ Should Docker be defaulted to enabled (does @docker:@ section exist in the config)?
+ , dockerMonoidEnable :: !(First Bool)
+ -- ^ Is using Docker enabled?
+ , dockerMonoidRepoOrImage :: !(First DockerMonoidRepoOrImage)
+ -- ^ Docker repository name (e.g. @fpco/stack-build@ or @fpco/stack-full:lts-2.8@)
+ , dockerMonoidRegistryLogin :: !(First Bool)
+ -- ^ Does registry require login for pulls?
+ , dockerMonoidRegistryUsername :: !(First String)
+ -- ^ Optional username for Docker registry.
+ , dockerMonoidRegistryPassword :: !(First String)
+ -- ^ Optional password for Docker registry.
+ , dockerMonoidAutoPull :: !FirstTrue
+ -- ^ Automatically pull new images.
+ , dockerMonoidDetach :: !FirstFalse
+ -- ^ Whether to run a detached container
+ , dockerMonoidPersist :: !FirstFalse
+ -- ^ Create a persistent container (don't remove it when finished). Implied by
+ -- `dockerDetach`.
+ , dockerMonoidContainerName :: !(First String)
+ -- ^ Container name to use, only makes sense from command-line with `dockerPersist`
+ -- or `dockerDetach`.
+ , dockerMonoidNetwork :: !(First String)
+ -- ^ See: 'dockerNetwork'
+ , dockerMonoidRunArgs :: ![String]
+ -- ^ Arguments to pass directly to @docker run@
+ , dockerMonoidMount :: ![Mount]
+ -- ^ Volumes to mount in the container
+ , dockerMonoidMountMode :: !(First String)
+ -- ^ Volume mount mode
+ , dockerMonoidEnv :: ![String]
+ -- ^ Environment variables to set in the container
+ , dockerMonoidStackExe :: !(First DockerStackExe)
+ -- ^ Location of container-compatible Stack executable
+ , dockerMonoidSetUser :: !(First Bool)
+ -- ^ Set in-container user to match host's
+ , dockerMonoidRequireDockerVersion :: !IntersectingVersionRange
+ -- ^ See: 'dockerRequireDockerVersion'
}
deriving (Show, Generic)
-- | Decode uninterpreted docker options from JSON/YAML.
instance FromJSON (WithJSONWarnings DockerOptsMonoid) where
parseJSON = withObjectWarnings "DockerOptsMonoid"
- (\o -> do let dockerMonoidDefaultEnable = Any True
- dockerMonoidEnable <- First <$> o ..:? dockerEnableArgName
- dockerMonoidRepoOrImage <- First <$>
- ((Just . DockerMonoidImage <$> o ..: dockerImageArgName) <|>
- (Just . DockerMonoidRepo <$> o ..: dockerRepoArgName) <|>
- pure Nothing)
- dockerMonoidRegistryLogin <- First <$> o ..:? dockerRegistryLoginArgName
- dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName
- dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName
- dockerMonoidAutoPull <- FirstTrue <$> o ..:? dockerAutoPullArgName
- dockerMonoidDetach <- FirstFalse <$> o ..:? dockerDetachArgName
- dockerMonoidPersist <- FirstFalse <$> o ..:? dockerPersistArgName
- dockerMonoidContainerName <- First <$> o ..:? dockerContainerNameArgName
- dockerMonoidNetwork <- First <$> o ..:? dockerNetworkArgName
- dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []
- dockerMonoidMount <- o ..:? dockerMountArgName ..!= []
- dockerMonoidMountMode <- First <$> o ..:? dockerMountModeArgName
- dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []
- dockerMonoidStackExe <- First <$> o ..:? dockerStackExeArgName
- dockerMonoidSetUser <- First <$> o ..:? dockerSetUserArgName
- dockerMonoidRequireDockerVersion
- <- IntersectingVersionRange . unVersionRangeJSON <$> (
- o ..:? dockerRequireDockerVersionArgName
- ..!= VersionRangeJSON anyVersion)
- return DockerOptsMonoid{..})
+ (\o -> do
+ let dockerMonoidDefaultEnable = Any True
+ dockerMonoidEnable <- First <$> o ..:? dockerEnableArgName
+ dockerMonoidRepoOrImage <- First <$>
+ ( (Just . DockerMonoidImage <$> o ..: dockerImageArgName)
+ <|> (Just . DockerMonoidRepo <$> o ..: dockerRepoArgName)
+ <|> pure Nothing
+ )
+ dockerMonoidRegistryLogin <- First <$> o ..:? dockerRegistryLoginArgName
+ dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName
+ dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName
+ dockerMonoidAutoPull <- FirstTrue <$> o ..:? dockerAutoPullArgName
+ dockerMonoidDetach <- FirstFalse <$> o ..:? dockerDetachArgName
+ dockerMonoidPersist <- FirstFalse <$> o ..:? dockerPersistArgName
+ dockerMonoidContainerName <- First <$> o ..:? dockerContainerNameArgName
+ dockerMonoidNetwork <- First <$> o ..:? dockerNetworkArgName
+ dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []
+ dockerMonoidMount <- o ..:? dockerMountArgName ..!= []
+ dockerMonoidMountMode <- First <$> o ..:? dockerMountModeArgName
+ dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []
+ dockerMonoidStackExe <- First <$> o ..:? dockerStackExeArgName
+ dockerMonoidSetUser <- First <$> o ..:? dockerSetUserArgName
+ dockerMonoidRequireDockerVersion <- IntersectingVersionRange . unVersionRangeJSON <$>
+ ( o ..:? dockerRequireDockerVersionArgName
+ ..!= VersionRangeJSON anyVersion
+ )
+ pure DockerOptsMonoid{..})
-- | Left-biased combine Docker options
instance Semigroup DockerOptsMonoid where
@@ -146,28 +361,28 @@
-- | Where to get the `stack` executable to run in Docker containers
data DockerStackExe
- = DockerStackExeDownload -- ^ Download from official bindist
- | DockerStackExeHost -- ^ Host's `stack` (linux-x86_64 only)
- | DockerStackExeImage -- ^ Docker image's `stack` (versions must match)
- | DockerStackExePath (Path Abs File) -- ^ Executable at given path
- deriving (Show)
+ = DockerStackExeDownload -- ^ Download from official bindist
+ | DockerStackExeHost -- ^ Host's `stack` (linux-x86_64 only)
+ | DockerStackExeImage -- ^ Docker image's `stack` (versions must match)
+ | DockerStackExePath (Path Abs File) -- ^ Executable at given path
+ deriving (Show)
instance FromJSON DockerStackExe where
- parseJSON a = do
- s <- parseJSON a
- case parseDockerStackExe s of
- Right dse -> return dse
- Left e -> fail (show e)
+ parseJSON a = do
+ s <- parseJSON a
+ case parseDockerStackExe s of
+ Right dse -> pure dse
+ Left e -> fail (displayException e)
-- | Parse 'DockerStackExe'.
parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe
parseDockerStackExe t
- | t == dockerStackExeDownloadVal = return DockerStackExeDownload
- | t == dockerStackExeHostVal = return DockerStackExeHost
- | t == dockerStackExeImageVal = return DockerStackExeImage
- | otherwise = case parseAbsFile t of
- Just p -> return (DockerStackExePath p)
- Nothing -> throwM (DockerStackExeParseException t)
+ | t == dockerStackExeDownloadVal = pure DockerStackExeDownload
+ | t == dockerStackExeHostVal = pure DockerStackExeHost
+ | t == dockerStackExeImageVal = pure DockerStackExeImage
+ | otherwise = case parseAbsFile t of
+ Just p -> pure (DockerStackExePath p)
+ Nothing -> throwM (DockerStackExeParseException t)
-- | Docker volume mount.
data Mount = Mount String String
@@ -183,8 +398,8 @@
-- | Show instance.
instance Show Mount where
show (Mount a b) = if a == b
- then a
- else concat [a,":",b]
+ then a
+ else concat [a,":",b]
-- | For YAML.
instance FromJSON Mount where
@@ -192,7 +407,7 @@
s <- parseJSON v
case readMaybe s of
Nothing -> fail $ "Mount read failed: " ++ s
- Just x -> return x
+ Just x -> pure x
-- | Options for Docker repository or image.
data DockerMonoidRepoOrImage
@@ -201,149 +416,15 @@
deriving (Show)
-- | Newtype for non-orphan FromJSON instance.
-newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange }
+newtype VersionRangeJSON =
+ VersionRangeJSON { unVersionRangeJSON :: VersionRange }
-- | Parse VersionRange.
instance FromJSON VersionRangeJSON where
parseJSON = withText "VersionRange"
- (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s))
- (return . VersionRangeJSON)
- (Distribution.Text.simpleParse (T.unpack s)))
-
--- | Exceptions thrown by Stack.Docker.
-data StackDockerException
- = DockerMustBeEnabledException
- -- ^ Docker must be enabled to use the command.
- | OnlyOnHostException
- -- ^ Command must be run on host OS (not in a container).
- | InspectFailedException String
- -- ^ @docker inspect@ failed.
- | NotPulledException String
- -- ^ Image does not exist.
- | InvalidImagesOutputException String
- -- ^ Invalid output from @docker images@.
- | InvalidPSOutputException String
- -- ^ Invalid output from @docker ps@.
- | InvalidInspectOutputException String
- -- ^ Invalid output from @docker inspect@.
- | PullFailedException String
- -- ^ Could not pull a Docker image.
- | DockerTooOldException Version Version
- -- ^ Installed version of @docker@ below minimum version.
- | DockerVersionProhibitedException [Version] Version
- -- ^ Installed version of @docker@ is prohibited.
- | BadDockerVersionException VersionRange Version
- -- ^ Installed version of @docker@ is out of range specified in config file.
- | InvalidVersionOutputException
- -- ^ Invalid output from @docker --version@.
- | HostStackTooOldException Version (Maybe Version)
- -- ^ Version of @stack@ on host is too old for version in image.
- | ContainerStackTooOldException Version Version
- -- ^ Version of @stack@ in container/image is too old for version on host.
- | CannotDetermineProjectRootException
- -- ^ Can't determine the project root (where to put docker sandbox).
- | DockerNotInstalledException
- -- ^ @docker --version@ failed.
- | UnsupportedStackExeHostPlatformException
- -- ^ Using host stack-exe on unsupported platform.
- | DockerStackExeParseException String
- -- ^ @stack-exe@ option fails to parse.
- deriving (Typeable)
-instance Exception StackDockerException
-
-instance Show StackDockerException where
- show DockerMustBeEnabledException =
- "Docker must be enabled in your configuration file to use this command."
- show OnlyOnHostException =
- "This command must be run on host OS (not in a Docker container)."
- show (InspectFailedException image) =
- concat ["'docker inspect' failed for image after pull: ",image,"."]
- show (NotPulledException image) =
- concat ["The Docker image referenced by your configuration file"
- ," has not\nbeen downloaded:\n "
- ,image
- ,"\n\nRun '"
- ,unwords [stackProgName, dockerCmdName, dockerPullCmdName]
- ,"' to download it, then try again."]
- show (InvalidImagesOutputException line) =
- concat ["Invalid 'docker images' output line: '",line,"'."]
- show (InvalidPSOutputException line) =
- concat ["Invalid 'docker ps' output line: '",line,"'."]
- show (InvalidInspectOutputException msg) =
- concat ["Invalid 'docker inspect' output: ",msg,"."]
- show (PullFailedException image) =
- concat ["Could not pull Docker image:\n "
- ,image
- ,"\nThere may not be an image on the registry for your resolver's LTS version in\n"
- ,"your configuration file."]
- show (DockerTooOldException minVersion haveVersion) =
- concat ["Minimum docker version '"
- ,versionString minVersion
- ,"' is required by "
- ,stackProgName
- ," (you have '"
- ,versionString haveVersion
- ,"')."]
- show (DockerVersionProhibitedException prohibitedVersions haveVersion) =
- concat ["These Docker versions are incompatible with "
- ,stackProgName
- ," (you have '"
- ,versionString haveVersion
- ,"'): "
- ,intercalate ", " (map versionString prohibitedVersions)
- ,"."]
- show (BadDockerVersionException requiredRange haveVersion) =
- concat ["The version of 'docker' you are using ("
- ,show haveVersion
- ,") is outside the required\n"
- ,"version range specified in stack.yaml ("
- ,T.unpack (versionRangeText requiredRange)
- ,")."]
- show InvalidVersionOutputException =
- "Cannot get Docker version (invalid 'docker --version' output)."
- show (HostStackTooOldException minVersion (Just hostVersion)) =
- concat ["The host's version of '"
- ,stackProgName
- ,"' is too old for this Docker image.\nVersion "
- ,versionString minVersion
- ," is required; you have "
- ,versionString hostVersion
- ,"."]
- show (HostStackTooOldException minVersion Nothing) =
- concat ["The host's version of '"
- ,stackProgName
- ,"' is too old.\nVersion "
- ,versionString minVersion
- ," is required."]
- show (ContainerStackTooOldException requiredVersion containerVersion) =
- concat ["The Docker container's version of '"
- ,stackProgName
- ,"' is too old.\nVersion "
- ,versionString requiredVersion
- ," is required; the container has "
- ,versionString containerVersion
- ,"."]
- show CannotDetermineProjectRootException =
- "Cannot determine project root directory for Docker sandbox."
- show DockerNotInstalledException =
- "Cannot find 'docker' in PATH. Is Docker installed?"
- show UnsupportedStackExeHostPlatformException = concat
- [ "Using host's "
- , stackProgName
- , " executable in Docker container is only supported on "
- , display dockerContainerPlatform
- , " platform" ]
- show (DockerStackExeParseException s) = concat
- [ "Failed to parse "
- , show s
- , ". Expected "
- , show dockerStackExeDownloadVal
- , ", "
- , show dockerStackExeHostVal
- , ", "
- , show dockerStackExeImageVal
- , " or absolute path to executable."
- ]
+ (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s))
+ (pure . VersionRangeJSON)
+ (Distribution.Text.simpleParse (T.unpack s)))
-- | Docker enable argument name.
dockerEnableArgName :: Text
@@ -405,7 +486,7 @@
dockerPersistArgName :: Text
dockerPersistArgName = "persist"
--- | Docker stack executable argument name.
+-- | Docker Stack executable argument name.
dockerStackExeArgName :: Text
dockerStackExeArgName = "stack-exe"
diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs
--- a/src/Stack/Types/GhcPkgId.hs
+++ b/src/Stack/Types/GhcPkgId.hs
@@ -6,28 +6,32 @@
-- | A ghc-pkg id.
module Stack.Types.GhcPkgId
- (GhcPkgId
- ,unGhcPkgId
- ,ghcPkgIdParser
- ,parseGhcPkgId
- ,ghcPkgIdString)
- where
+ ( GhcPkgId
+ , unGhcPkgId
+ , ghcPkgIdParser
+ , parseGhcPkgId
+ , ghcPkgIdString
+ ) where
import Stack.Prelude
import Pantry.Internal.AesonExtended
import Data.Attoparsec.Text
import qualified Data.Text as T
-import Database.Persist.Sql (PersistField, PersistFieldSql)
-import Prelude (Read (..))
+import Database.Persist.Sql ( PersistField, PersistFieldSql )
+import Prelude ( Read (..) )
-- | A parse fail.
newtype GhcPkgIdParseFail
= GhcPkgIdParseFail Text
- deriving Typeable
-instance Show GhcPkgIdParseFail where
- show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs
-instance Exception GhcPkgIdParseFail
+ deriving (Show, Typeable)
+instance Exception GhcPkgIdParseFail where
+ displayException (GhcPkgIdParseFail bs) = concat
+ [ "Error: [S-5359]\n"
+ , "Invalid package ID: "
+ , show bs
+ ]
+
-- | A ghc-pkg package identifier.
newtype GhcPkgId = GhcPkgId Text
deriving (Eq,Ord,Data,Typeable,Generic,PersistField,PersistFieldSql)
@@ -44,7 +48,7 @@
parseJSON = withText "GhcPkgId" $ \t ->
case parseGhcPkgId t of
Left e -> fail $ show (e, t)
- Right x -> return x
+ Right x -> pure x
instance ToJSON GhcPkgId where
toJSON g =
@@ -54,7 +58,7 @@
parseGhcPkgId :: MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId x = go x
where go =
- either (const (throwM (GhcPkgIdParseFail x))) return .
+ either (const (throwM (GhcPkgIdParseFail x))) pure .
parseOnly (ghcPkgIdParser <* endOfInput)
-- | A parser for a package-version-hash pair.
diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs
--- a/src/Stack/Types/NamedComponent.hs
+++ b/src/Stack/Types/NamedComponent.hs
@@ -17,10 +17,10 @@
, isCBench
) where
-import Pantry
-import Stack.Prelude
import qualified Data.Set as Set
import qualified Data.Text as T
+import Pantry
+import Stack.Prelude
-- | A single, fully resolved component of a package
data NamedComponent
diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs
--- a/src/Stack/Types/Nix.hs
+++ b/src/Stack/Types/Nix.hs
@@ -6,59 +6,71 @@
-- | Nix types.
-module Stack.Types.Nix where
+module Stack.Types.Nix
+ ( NixOpts (..)
+ , NixOptsMonoid (..)
+ , nixAddGCRootsArgName
+ , nixEnableArgName
+ , nixInitFileArgName
+ , nixPackagesArgName
+ , nixPathArgName
+ , nixPureShellArgName
+ , nixShellOptsArgName
+ ) where
-import Pantry.Internal.AesonExtended
-import Stack.Prelude
-import Generics.Deriving.Monoid (mappenddefault, memptydefault)
+import Generics.Deriving.Monoid ( mappenddefault, memptydefault )
+import Pantry.Internal.AesonExtended
+import Stack.Prelude
-- | Nix configuration. Parameterize by resolver type to avoid cyclic
-- dependency.
data NixOpts = NixOpts
- {nixEnable :: !Bool
- ,nixPureShell :: !Bool
- ,nixPackages :: ![Text]
- -- ^ The system packages to be installed in the environment before it runs
- ,nixInitFile :: !(Maybe FilePath)
- -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)
- ,nixShellOptions :: ![Text]
- -- ^ Options to be given to the nix-shell command line
- ,nixAddGCRoots :: !Bool
- -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies
+ { nixEnable :: !Bool
+ , nixPureShell :: !Bool
+ , nixPackages :: ![Text]
+ -- ^ The system packages to be installed in the environment before it runs
+ , nixInitFile :: !(Maybe FilePath)
+ -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)
+ , nixShellOptions :: ![Text]
+ -- ^ Options to be given to the nix-shell command line
+ , nixAddGCRoots :: !Bool
+ -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies
}
deriving (Show)
-- | An uninterpreted representation of nix options.
-- Configurations may be "cascaded" using mappend (left-biased).
data NixOptsMonoid = NixOptsMonoid
- {nixMonoidEnable :: !(First Bool)
- -- ^ Is using nix-shell enabled?
- ,nixMonoidPureShell :: !(First Bool)
- -- ^ Should the nix-shell be pure
- ,nixMonoidPackages :: !(First [Text])
- -- ^ System packages to use (given to nix-shell)
- ,nixMonoidInitFile :: !(First FilePath)
- -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)
- ,nixMonoidShellOptions :: !(First [Text])
- -- ^ Options to be given to the nix-shell command line
- ,nixMonoidPath :: !(First [Text])
- -- ^ Override parts of NIX_PATH (notably 'nixpkgs')
- ,nixMonoidAddGCRoots :: !FirstFalse
- -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies
+ { nixMonoidEnable :: !(First Bool)
+ -- ^ Is using nix-shell enabled?
+ , nixMonoidPureShell :: !(First Bool)
+ -- ^ Should the nix-shell be pure
+ , nixMonoidPackages :: !(First [Text])
+ -- ^ System packages to use (given to nix-shell)
+ , nixMonoidInitFile :: !(First FilePath)
+ -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)
+ , nixMonoidShellOptions :: !(First [Text])
+ -- ^ Options to be given to the nix-shell command line
+ , nixMonoidPath :: !(First [Text])
+ -- ^ Override parts of NIX_PATH (notably 'nixpkgs')
+ , nixMonoidAddGCRoots :: !FirstFalse
+ -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies
}
- deriving (Eq, Show, Generic)
+ deriving (Eq, Generic, Show)
-- | Decode uninterpreted nix options from JSON/YAML.
instance FromJSON (WithJSONWarnings NixOptsMonoid) where
parseJSON = withObjectWarnings "NixOptsMonoid"
- (\o -> do nixMonoidEnable <- First <$> o ..:? nixEnableArgName
- nixMonoidPureShell <- First <$> o ..:? nixPureShellArgName
- nixMonoidPackages <- First <$> o ..:? nixPackagesArgName
- nixMonoidInitFile <- First <$> o ..:? nixInitFileArgName
- nixMonoidShellOptions <- First <$> o ..:? nixShellOptsArgName
- nixMonoidPath <- First <$> o ..:? nixPathArgName
- nixMonoidAddGCRoots <- FirstFalse <$> o ..:? nixAddGCRootsArgName
- return NixOptsMonoid{..})
+ ( \o -> do
+ nixMonoidEnable <- First <$> o ..:? nixEnableArgName
+ nixMonoidPureShell <- First <$> o ..:? nixPureShellArgName
+ nixMonoidPackages <- First <$> o ..:? nixPackagesArgName
+ nixMonoidInitFile <- First <$> o ..:? nixInitFileArgName
+ nixMonoidShellOptions <- First <$> o ..:? nixShellOptsArgName
+ nixMonoidPath <- First <$> o ..:? nixPathArgName
+ nixMonoidAddGCRoots <- FirstFalse <$> o ..:? nixAddGCRootsArgName
+ pure NixOptsMonoid{..}
+ )
-- | Left-biased combine Nix options
instance Semigroup NixOptsMonoid where
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
@@ -9,28 +9,70 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-module Stack.Types.Package where
+module Stack.Types.Package
+ ( BuildInfoOpts (..)
+ , ExeName (..)
+ , FileCacheInfo (..)
+ , GetPackageOpts (..)
+ , InstallLocation (..)
+ , InstallMap
+ , Installed (..)
+ , InstalledPackageLocation (..)
+ , InstalledMap
+ , LocalPackage (..)
+ , MemoizedWith (..)
+ , Package (..)
+ , PackageConfig (..)
+ , PackageException (..)
+ , PackageLibraries (..)
+ , PackageSource (..)
+ , dotCabalCFilePath
+ , dotCabalGetPath
+ , dotCabalMain
+ , dotCabalMainPath
+ , dotCabalModule
+ , dotCabalModulePath
+ , installedPackageIdentifier
+ , installedVersion
+ , lpFiles
+ , lpFilesForComponents
+ , memoizeRefWith
+ , packageDefinedFlags
+ , packageIdent
+ , packageIdentifier
+ , psVersion
+ , runMemoizedWith
+ ) where
import Stack.Prelude
import qualified RIO.Text as T
-import Data.Aeson (ToJSON (..), FromJSON (..), (.=), (.:), object, withObject)
+import Data.Aeson
+ ( ToJSON (..), FromJSON (..), (.=), (.:), object, withObject
+ )
import qualified Data.Map as M
import qualified Data.Set as Set
import Distribution.CabalSpecVersion
-import Distribution.Parsec (PError (..), PWarning (..), showPos)
+import Distribution.Parsec ( PError (..), PWarning (..), showPos )
import qualified Distribution.SPDX.License as SPDX
-import Distribution.License (License)
-import Distribution.ModuleName (ModuleName)
-import Distribution.PackageDescription (TestSuiteInterface, BuildType)
-import Distribution.System (Platform (..))
+import Distribution.License ( License )
+import Distribution.ModuleName ( ModuleName )
+import Distribution.PackageDescription
+ ( TestSuiteInterface, BuildType )
+import Distribution.System ( Platform (..) )
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.SourceMap
import Stack.Types.Version
+import Stack.Types.Dependency ( DepValue )
+import Stack.Types.PackageFile
+ ( GetPackageFiles (..), DotCabalDescriptor (..)
+ , DotCabalPath (..)
+ )
--- | All exceptions thrown by the library.
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Package" module.
data PackageException
= PackageInvalidCabalFile
!(Either PackageIdentifierRevision (Path Abs File))
@@ -38,11 +80,15 @@
![PError]
![PWarning]
| MismatchedCabalIdentifier !PackageIdentifierRevision !PackageIdentifier
- deriving Typeable
-instance Exception PackageException
-instance Show PackageException where
- show (PackageInvalidCabalFile loc _mversion errs warnings) = concat
- [ "Unable to parse cabal file "
+ | CabalFileNameParseFail FilePath
+ | CabalFileNameInvalidPackageName FilePath
+ | ComponentNotParsedBug
+ deriving (Show, Typeable)
+
+instance Exception PackageException where
+ displayException (PackageInvalidCabalFile loc _mversion errs warnings) = concat
+ [ "Error: [S-8072]\n"
+ , "Unable to parse Cabal file "
, case loc of
Left pir -> "for " ++ T.unpack (utf8BuilderToText (display pir))
Right fp -> toFilePath fp
@@ -74,13 +120,27 @@
])
warnings
]
- show (MismatchedCabalIdentifier pir ident) = concat
- [ "Mismatched package identifier."
+ displayException (MismatchedCabalIdentifier pir ident) = concat
+ [ "Error: [S-5394]\n"
+ , "Mismatched package identifier."
, "\nFound: "
, packageIdentifierString ident
, "\nExpected: "
, T.unpack $ utf8BuilderToText $ display pir
]
+ displayException (CabalFileNameParseFail fp) = concat
+ [ "Error: [S-2203]\n"
+ , "Invalid file path for Cabal file, must have a .cabal extension: "
+ , fp
+ ]
+ displayException (CabalFileNameInvalidPackageName fp) = concat
+ [ "Error: [S-8854]\n"
+ , "Cabal file names must use valid package names followed by a .cabal \
+ \extension, the following is invalid: "
+ , fp
+ ]
+ displayException ComponentNotParsedBug = bugReport "[S-4623]"
+ "Component names should always parse as directory names."
-- | Libraries in a package. Since Cabal 2.0, internal libraries are a
-- thing.
@@ -123,27 +183,6 @@
packageIdent :: Package -> PackageIdentifier
packageIdent p = PackageIdentifier (packageName p) (packageVersion p)
--- | The value for a map from dependency name. This contains both the
--- version range and the type of dependency, and provides a semigroup
--- instance.
-data DepValue = DepValue
- { dvVersionRange :: !VersionRange
- , dvType :: !DepType
- }
- deriving (Show,Typeable)
-instance Semigroup DepValue where
- DepValue a x <> DepValue b y = DepValue (intersectVersionRanges a b) (x <> y)
-
--- | Is this package being used as a library, or just as a build tool?
--- If the former, we need to ensure that a library actually
--- exists. See
---
-data DepType = AsLibrary | AsBuildTool
- deriving (Show, Eq)
-instance Semigroup DepType where
- AsLibrary <> _ = AsLibrary
- AsBuildTool <> x = x
-
packageIdentifier :: Package -> PackageIdentifier
packageIdentifier pkg =
PackageIdentifier (packageName pkg) (packageVersion pkg)
@@ -154,7 +193,7 @@
type InstallMap = Map PackageName (InstallLocation, Version)
-- | Files that the package depends on, relative to package directory.
--- Argument is the location of the .cabal file
+-- Argument is the location of the Cabal file
newtype GetPackageOpts = GetPackageOpts
{ getPackageOpts :: forall env. HasEnvConfig env
=> InstallMap
@@ -181,37 +220,6 @@
, bioCabalMacros :: Path Abs File
} deriving 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 env. HasEnvConfig env
- => Path Abs File
- -> RIO env
- (Map NamedComponent (Map ModuleName (Path Abs File))
- ,Map NamedComponent [DotCabalPath]
- ,Set (Path Abs File)
- ,[PackageWarning])
- }
-instance Show GetPackageFiles where
- show _ = ""
-
--- | Warning generated when reading a package
-data PackageWarning
- = UnlistedModulesWarning NamedComponent [ModuleName]
- -- ^ Modules found that are not listed in cabal file
-
- -- TODO: bring this back - see
- -- https://github.com/commercialhaskell/stack/issues/2649
- {-
- | MissingModulesWarning (Path Abs File) (Maybe String) [ModuleName]
- -- ^ Modules not found in file system, which are listed in cabal file
- -}
-
-- | Package build configuration
data PackageConfig =
PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?
@@ -267,16 +275,11 @@
-- "buildable: false".
, lpWanted :: !Bool -- FIXME Should completely drop this "wanted" terminology, it's unclear
-- ^ Whether this package is wanted as a target.
- , 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.
, lpTestBench :: !(Maybe Package)
-- ^ This stores the 'Package' with tests and benchmarks enabled, if
-- either is asked for by the user.
, lpCabalFile :: !(Path Abs File)
- -- ^ The .cabal file
+ -- ^ The Cabal file
, lpBuildHaddocks :: !Bool
, lpForceDirty :: !Bool
, lpDirtyFiles :: !(MemoizedWith EnvConfig (Maybe (Set FilePath)))
@@ -307,8 +310,8 @@
pure res
either throwIO pure res
-runMemoizedWith
- :: (HasEnvConfig env, MonadReader env m, MonadIO m)
+runMemoizedWith ::
+ (HasEnvConfig env, MonadReader env m, MonadIO m)
=> MemoizedWith EnvConfig a
-> m a
runMemoizedWith (MemoizedWith action) = do
@@ -359,20 +362,6 @@
parseJSON = withObject "FileCacheInfo" $ \o -> FileCacheInfo
<$> o .: "hash"
--- | A descriptor from a .cabal file indicating one of the following:
---
--- exposed-modules: Foo
--- other-modules: Foo
--- or
--- main-is: Foo.hs
---
-data DotCabalDescriptor
- = DotCabalModule !ModuleName
- | DotCabalMain !FilePath
- | DotCabalFile !FilePath
- | DotCabalCFile !FilePath
- deriving (Eq,Ord,Show)
-
-- | Maybe get the module name from the .cabal descriptor.
dotCabalModule :: DotCabalDescriptor -> Maybe ModuleName
dotCabalModule (DotCabalModule m) = Just m
@@ -382,15 +371,6 @@
dotCabalMain :: DotCabalDescriptor -> Maybe FilePath
dotCabalMain (DotCabalMain m) = Just m
dotCabalMain _ = Nothing
-
--- | A path resolved from the .cabal file, which is either main-is or
--- an exposed/internal/referenced module.
-data DotCabalPath
- = DotCabalModulePath !(Path Abs File)
- | DotCabalMainPath !(Path Abs File)
- | DotCabalFilePath !(Path Abs File)
- | DotCabalCFilePath !(Path Abs File)
- deriving (Eq,Ord,Show)
-- | Get the module path.
dotCabalModulePath :: DotCabalPath -> Maybe (Path Abs File)
diff --git a/src/Stack/Types/PackageFile.hs b/src/Stack/Types/PackageFile.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/PackageFile.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | The facility for retrieving all files from the main Stack
+-- 'Stack.Types.Package' type. This was moved into its own module to allow
+-- component-level file-gathering without circular dependency at the Package
+-- level.
+module Stack.Types.PackageFile
+ ( GetPackageFileContext (..)
+ , DotCabalPath (..)
+ , DotCabalDescriptor (..)
+ , GetPackageFiles (..)
+ , PackageWarning (..)
+ ) where
+
+import Distribution.ModuleName ( ModuleName )
+import RIO.Process ( HasProcessContext (processContextL) )
+import Stack.Prelude
+import Stack.Types.Config
+ ( BuildConfig, HasBuildConfig (..), HasConfig (..)
+ , HasEnvConfig, HasGHCVariant, HasPlatform, HasRunner (..)
+ )
+import Stack.Types.NamedComponent ( NamedComponent )
+
+data GetPackageFileContext = GetPackageFileContext
+ { ctxFile :: !(Path Abs File)
+ , ctxDistDir :: !(Path Abs Dir)
+ , ctxBuildConfig :: !BuildConfig
+ , ctxCabalVer :: !Version
+ }
+
+instance HasPlatform GetPackageFileContext
+instance HasGHCVariant GetPackageFileContext
+instance HasLogFunc GetPackageFileContext where
+ logFuncL = configL.logFuncL
+instance HasRunner GetPackageFileContext where
+ runnerL = configL.runnerL
+instance HasStylesUpdate GetPackageFileContext where
+ stylesUpdateL = runnerL.stylesUpdateL
+instance HasTerm GetPackageFileContext where
+ useColorL = runnerL.useColorL
+ termWidthL = runnerL.termWidthL
+instance HasConfig GetPackageFileContext
+instance HasPantryConfig GetPackageFileContext where
+ pantryConfigL = configL.pantryConfigL
+instance HasProcessContext GetPackageFileContext where
+ processContextL = configL.processContextL
+instance HasBuildConfig GetPackageFileContext where
+ buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = y })
+
+-- | A path resolved from the Cabal file, which is either main-is or
+-- an exposed/internal/referenced module.
+data DotCabalPath
+ = DotCabalModulePath !(Path Abs File)
+ | DotCabalMainPath !(Path Abs File)
+ | DotCabalFilePath !(Path Abs File)
+ | DotCabalCFilePath !(Path Abs File)
+ deriving (Eq, Ord, Show)
+
+-- | A descriptor from a Cabal file indicating one of the following:
+--
+-- exposed-modules: Foo
+-- other-modules: Foo
+-- or
+-- main-is: Foo.hs
+--
+data DotCabalDescriptor
+ = DotCabalModule !ModuleName
+ | DotCabalMain !FilePath
+ | DotCabalFile !FilePath
+ | DotCabalCFile !FilePath
+ deriving (Eq, Ord, Show)
+
+-- | Files that the package depends on, relative to package directory.
+-- Argument is the location of the Cabal file
+newtype GetPackageFiles = GetPackageFiles
+ { getPackageFiles :: forall env. HasEnvConfig env
+ => Path Abs File
+ -> RIO env
+ ( Map NamedComponent (Map ModuleName (Path Abs File))
+ , Map NamedComponent [DotCabalPath]
+ , Set (Path Abs File)
+ , [PackageWarning]
+ )
+ }
+instance Show GetPackageFiles where
+ show _ = ""
+
+-- | Warning generated when reading a package
+data PackageWarning
+ = UnlistedModulesWarning NamedComponent [ModuleName]
+ -- ^ Modules found that are not listed in Cabal file
+ -- TODO: bring this back - see
+ -- https://github.com/commercialhaskell/stack/issues/2649
+ {-
+ | MissingModulesWarning (Path Abs File) (Maybe String) [ModuleName]
+ -- ^ Modules not found in file system, which are listed in Cabal file
+ -}
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
@@ -4,8 +4,8 @@
-- | Names for packages.
module Stack.Types.PackageName
- ( packageNameArgument
- ) where
+ ( packageNameArgument
+ ) where
import Stack.Prelude
import qualified Options.Applicative as O
@@ -18,7 +18,7 @@
packageNameArgument =
O.argument
(do s <- O.str
- either O.readerError return (p s))
+ either O.readerError pure (p s))
where
p s =
case parsePackageName s of
diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs
--- a/src/Stack/Types/Resolver.hs
+++ b/src/Stack/Types/Resolver.hs
@@ -11,24 +11,46 @@
{-# LANGUAGE UndecidableInstances #-}
module Stack.Types.Resolver
- (AbstractResolver(..)
- ,readAbstractResolver
- ,Snapshots (..)
+ ( AbstractResolver (..)
+ , readAbstractResolver
+ , Snapshots (..)
) where
-import Pantry.Internal.AesonExtended
- (FromJSON, parseJSON,
- withObject, (.:), withText)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Text as T
-import Data.Text.Read (decimal)
-import Data.Time (Day)
-import Options.Applicative (ReadM)
+import Data.Text.Read ( decimal )
+import Data.Time ( Day )
+import Options.Applicative ( ReadM )
import qualified Options.Applicative.Types as OA
+import Pantry.Internal.AesonExtended
+ ( FromJSON, parseJSON, withObject, (.:), withText )
import Stack.Prelude
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Types.Resolver" module.
+data TypesResolverException
+ = ParseResolverException !Text
+ | FilepathInDownloadedSnapshot !Text
+ deriving (Show, Typeable)
+
+instance Exception TypesResolverException where
+ displayException (ParseResolverException t) = concat
+ [ "Error: [S-8787]\n"
+ , "Invalid resolver value: "
+ , T.unpack t
+ , ". 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."
+ ]
+ displayException (FilepathInDownloadedSnapshot url) = unlines
+ [ "Error: [S-4865]"
+ , "Downloaded snapshot specified a 'resolver: { location: filepath }' "
+ , "field, but filepaths are not allowed in downloaded snapshots.\n"
+ , "Filepath specified: " ++ T.unpack url
+ ]
+
-- | Either an actual resolver value, or an abstract description of one (e.g.,
-- latest nightly).
data AbstractResolver
@@ -59,24 +81,6 @@
pure $ pure $ ARLatestLTSMajor x'
_ -> pure $ ARResolver <$> parseRawSnapshotLocation (T.pack s)
-data BuildPlanTypesException
- = ParseResolverException !Text
- | FilepathInDownloadedSnapshot !Text
- deriving Typeable
-instance Exception BuildPlanTypesException
-instance Show BuildPlanTypesException where
- show (ParseResolverException t) = concat
- [ "Invalid resolver value: "
- , T.unpack t
- , ". 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 (FilepathInDownloadedSnapshot url) = unlines
- [ "Downloaded snapshot specified a 'resolver: { location: filepath }' "
- , "field, but filepaths are not allowed in downloaded snapshots.\n"
- , "Filepath specified: " ++ T.unpack url
- ]
-
-- | Most recent Nightly and newest LTS version per major release.
data Snapshots = Snapshots
{ snapshotsNightly :: !Day
@@ -92,14 +96,14 @@
where
parseNightly t =
case parseSnapName t of
- Left e -> fail $ show e
+ Left e -> fail $ displayException e
Right (LTS _ _) -> fail "Unexpected LTS value"
- Right (Nightly d) -> return d
+ Right (Nightly d) -> pure d
isLTS = ("lts-" `T.isPrefixOf`)
parseLTS = withText "LTS" $ \t ->
case parseSnapName t of
- Left e -> fail $ show e
- Right (LTS x y) -> return $ IntMap.singleton x y
+ Left e -> fail $ displayException e
+ Right (LTS x y) -> pure $ IntMap.singleton x y
Right (Nightly _) -> fail "Unexpected nightly value"
diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs
--- a/src/Stack/Types/SourceMap.hs
+++ b/src/Stack/Types/SourceMap.hs
@@ -25,12 +25,12 @@
) where
import qualified Data.Text as T
+import Distribution.PackageDescription ( GenericPackageDescription )
import qualified Pantry.SHA256 as SHA256
-import Path
-import Stack.Prelude
-import Stack.Types.Compiler
-import Stack.Types.NamedComponent
-import Distribution.PackageDescription (GenericPackageDescription)
+import Path
+import Stack.Prelude
+import Stack.Types.Compiler
+import Stack.Types.NamedComponent
-- | Common settings for both dependency and project package.
data CommonPackage = CommonPackage
diff --git a/src/Stack/Types/Storage.hs b/src/Stack/Types/Storage.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/Storage.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Types used by @Stack.Storage@ modules.
+module Stack.Types.Storage
+ ( StoragePrettyException (..)
+ ) where
+
+import Data.Text
+import Stack.Prelude
+
+-- | Type representing \'pretty\' exceptions thrown by functions exported by
+-- modules beginning @Stack.Storage@.
+data StoragePrettyException
+ = StorageMigrationFailure !Text !(Path Abs File) !SomeException
+ deriving (Show, Typeable)
+
+instance Pretty StoragePrettyException where
+ pretty (StorageMigrationFailure desc fp ex) =
+ "[S-8835]"
+ <> line
+ <> flow "Stack could not migrate the the database"
+ <+> style File (fromString $ show desc)
+ <+> flow "located at"
+ <+> style Dir (pretty fp)
+ <> "."
+ <> blankLine
+ <> flow "While migrating the database, Stack encountered the error:"
+ <> blankLine
+ <> string exMsg
+ <> blankLine
+ <> flow "Please report this as an issue at"
+ <+> style Url "https://github.com/commercialhaskell/stack/issues"
+ <> "."
+ <> blankLine
+ -- See https://github.com/commercialhaskell/stack/issues/5851
+ <> if exMsg == winIOGHCRTSMsg
+ then
+ flow "This error can be caused by a bug that arises if GHC's \
+ \'--io-manager=native' RTS option is set using the GHCRTS \
+ \environment variable. As a workaround try setting the option \
+ \in the project's Cabal file, Stack's YAML configuration file \
+ \or at the command line."
+ else
+ flow "As a workaround you may delete the database. This \
+ \will cause the database to be recreated."
+ where
+ exMsg = displayException ex
+ winIOGHCRTSMsg =
+ "\\\\.\\NUL: hDuplicateTo: illegal operation (handles are incompatible)"
+
+instance Exception StoragePrettyException
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
@@ -17,13 +17,24 @@
, defaultTemplateName
) where
-import Data.Aeson (FromJSON (..), withText)
+import Data.Aeson ( FromJSON (..), withText )
import qualified Data.Text as T
-import Network.HTTP.StackClient (parseRequest)
+import Network.HTTP.StackClient ( parseRequest )
import qualified Options.Applicative as O
import Path
import Stack.Prelude
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Types.TemplateName" module.
+newtype TypeTemplateNameException
+ = DefaultTemplateNameNotParsedBug String
+ deriving (Show, Typeable)
+
+instance Exception TypeTemplateNameException where
+ displayException (DefaultTemplateNameNotParsedBug s) = bugReport "[S-7410]" $
+ "The impossible happened! Cannot parse default template name: "
+ ++ s
+
-- | A template name.
data TemplateName = TemplateName !Text !TemplatePath
deriving (Ord,Eq,Show)
@@ -54,7 +65,7 @@
instance FromJSON TemplateName where
parseJSON = withText "TemplateName" $
- either fail return . parseTemplateNameFromString . T.unpack
+ either fail pure . parseTemplateNameFromString . T.unpack
-- | An argument which accepts a template name of the format
-- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@.
@@ -62,16 +73,16 @@
-> O.Parser TemplateName
templateNameArgument =
O.argument
- (do string <- O.str
- either O.readerError return (parseTemplateNameFromString string))
+ (do s <- O.str
+ either O.readerError pure (parseTemplateNameFromString s))
-- | 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))
+ (do s <- O.str
+ either O.readerError pure (parsePair s))
where
parsePair :: String -> Either String (Text, Text)
parsePair s =
@@ -102,7 +113,7 @@
defaultTemplateName :: TemplateName
defaultTemplateName =
case parseTemplateNameFromString "new-template" of
- Left s -> error $ "Bug in Stack codebase, cannot parse default template name: " ++ s
+ Left s -> impureThrow $ DefaultTemplateNameNotParsedBug s
Right x -> x
-- | Get a text representation of the template name.
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
@@ -6,43 +6,46 @@
-- | Versions for packages.
module Stack.Types.Version
- (Version
- ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper
- ,IntersectingVersionRange(..)
- ,VersionCheck(..)
- ,versionRangeText
- ,Cabal.withinRange
- ,Stack.Types.Version.intersectVersionRanges
- ,toMajorVersion
- ,latestApplicableVersion
- ,checkVersion
- ,nextMajorVersion
- ,minorVersion
- ,stackVersion
- ,stackMinorVersion)
- where
+ ( Cabal.VersionRange -- TODO in the future should have a newtype wrapper
+ , IntersectingVersionRange (..)
+ , VersionCheck (..)
+ , versionRangeText
+ , Cabal.withinRange
+ , Stack.Types.Version.intersectVersionRanges
+ , toMajorVersion
+ , latestApplicableVersion
+ , checkVersion
+ , nextMajorVersion
+ , minorVersion
+ , stackVersion
+ , showStackVersion
+ , stackMajorVersion
+ , stackMinorVersion
+ ) where
-import Stack.Prelude hiding (Vector)
-import Pantry.Internal.AesonExtended
-import Data.List (find)
+import Data.List ( find )
import qualified Data.Set as Set
import qualified Data.Text as T
-import Distribution.Pretty (pretty)
+import Data.Version ( showVersion )
+import Distribution.Pretty ( pretty )
import qualified Distribution.Version as Cabal
+import Pantry.Internal.AesonExtended
+ ( FromJSON (..), ToJSON (..), Value (..), withText )
import qualified Paths_stack as Meta
-import Text.PrettyPrint (render)
+import Stack.Prelude hiding ( Vector, pretty )
+import Text.PrettyPrint ( render )
-newtype IntersectingVersionRange =
- IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange }
- deriving Show
+newtype IntersectingVersionRange = IntersectingVersionRange
+ { getIntersectingVersionRange :: Cabal.VersionRange }
+ deriving Show
instance Semigroup IntersectingVersionRange where
- IntersectingVersionRange l <> IntersectingVersionRange r =
- IntersectingVersionRange (l `Cabal.intersectVersionRanges` r)
+ IntersectingVersionRange l <> IntersectingVersionRange r =
+ IntersectingVersionRange (l `Cabal.intersectVersionRanges` r)
instance Monoid IntersectingVersionRange where
- mempty = IntersectingVersionRange Cabal.anyVersion
- mappend = (<>)
+ mempty = IntersectingVersionRange Cabal.anyVersion
+ mappend = (<>)
-- | Display a version range
versionRangeText :: Cabal.VersionRange -> Text
@@ -74,41 +77,43 @@
a:b:_ -> Cabal.mkVersion [a, b + 1]
data VersionCheck
- = MatchMinor
- | MatchExact
- | NewerMinor
- deriving (Show, Eq, Ord)
+ = MatchMinor
+ | MatchExact
+ | NewerMinor
+ deriving (Eq, Ord, Show)
+
instance ToJSON VersionCheck where
- toJSON MatchMinor = String "match-minor"
- toJSON MatchExact = String "match-exact"
- toJSON NewerMinor = String "newer-minor"
+ 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)"
+ parseJSON = withText expected $ \t ->
+ case t of
+ "match-minor" -> pure MatchMinor
+ "match-exact" -> pure MatchExact
+ "newer-minor" -> pure 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 (Cabal.versionNumbers -> wanted) (Cabal.versionNumbers -> actual) =
- case check of
- MatchMinor -> and (take 3 matching)
- MatchExact -> length wanted == length actual && and matching
- NewerMinor -> and (take 2 matching) && newerMinor
- where
- matching = zipWith (==) wanted actual
+ case check of
+ MatchMinor -> and (take 3 matching)
+ MatchExact -> length wanted == length actual && and matching
+ NewerMinor -> and (take 2 matching) && newerMinor
+ where
+ matching = zipWith (==) wanted actual
- getMinor (_a:_b:c:_) = Just c
- getMinor _ = Nothing
+ getMinor (_a:_b:c:_) = Just c
+ getMinor _ = Nothing
- newerMinor =
- case (getMinor wanted, getMinor actual) of
- (Nothing, _) -> True
- (Just _, Nothing) -> False
- (Just w, Just a) -> a >= w
+ newerMinor =
+ case (getMinor wanted, getMinor actual) of
+ (Nothing, _) -> True
+ (Just _, Nothing) -> False
+ (Just w, Just a) -> a >= w
-- | Get minor version (excludes any patchlevel)
minorVersion :: Version -> Version
@@ -118,6 +123,16 @@
stackVersion :: Version
stackVersion = Cabal.mkVersion' Meta.version
+-- | Current Stack version in the same format as yielded by
+-- 'Data.Version.showVersion'.
+showStackVersion :: String
+showStackVersion = showVersion Meta.version
+
-- | Current Stack minor version (excludes patchlevel)
stackMinorVersion :: Version
stackMinorVersion = minorVersion stackVersion
+
+-- | Current Stack major version. Returns the first two components, defaulting
+-- to 0 if not present
+stackMajorVersion :: Version
+stackMajorVersion = toMajorVersion stackVersion
diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs
--- a/src/Stack/Unpack.hs
+++ b/src/Stack/Unpack.hs
@@ -6,27 +6,32 @@
( unpackPackages
) where
-import Stack.Prelude
-import qualified RIO.Text as T
+import Path ( (), parseRelDir )
+import Path.IO ( doesDirExist )
+import RIO.List ( intercalate )
import qualified RIO.Map as Map
+import RIO.Process ( HasProcessContext )
import qualified RIO.Set as Set
-import RIO.List (intercalate)
-import RIO.Process (HasProcessContext)
-import Path ((), parseRelDir)
-import Path.IO (doesDirExist)
+import qualified RIO.Text as T
+import Stack.Prelude
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Unpack" module.
data UnpackException
= UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
| CouldNotParsePackageSelectors [String]
- deriving Typeable
-instance Exception UnpackException
-instance Show UnpackException where
- show (UnpackDirectoryAlreadyExists dirs) = unlines
- $ "Unable to unpack due to already present directories:"
+ deriving (Show, Typeable)
+
+instance Exception UnpackException where
+ displayException (UnpackDirectoryAlreadyExists dirs) = unlines
+ $ "Error: [S-3515]"
+ : "Unable to unpack due to already present directories:"
: map ((" " ++) . toFilePath) (Set.toList dirs)
- show (CouldNotParsePackageSelectors strs) = unlines
- $ "The following package selectors are not valid package names or identifiers:"
- : map ("- " ++) strs
+ displayException (CouldNotParsePackageSelectors strs) = unlines
+ $ "Error: [S-2628]"
+ : "The following package selectors are not valid package names or \
+ \identifiers:"
+ : map ("- " ++) strs
-- | Intended to work for the command line command.
unpackPackages
diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs
--- a/src/Stack/Upgrade.hs
+++ b/src/Stack/Upgrade.hs
@@ -5,28 +5,56 @@
{-# LANGUAGE OverloadedStrings #-}
module Stack.Upgrade
- ( upgrade
- , UpgradeOpts
- , upgradeOpts
- ) where
+ ( upgrade
+ , UpgradeOpts
+ , upgradeOpts
+ ) where
-import Stack.Prelude hiding (force, Display (..))
import qualified Data.Text as T
-import Distribution.Version (mkVersion')
import Options.Applicative
import Path
-import qualified Paths_stack as Paths
+import RIO.Process
import Stack.Build
-import Stack.Build.Target (NeedTargets(..))
+import Stack.Build.Target ( NeedTargets (..) )
import Stack.Constants
+import Stack.Prelude hiding ( force, Display (..) )
import Stack.Runners
import Stack.Setup
import Stack.Types.Config
-import System.Console.ANSI (hSupportsANSIWithoutEmulation)
-import System.Process (rawSystem, readProcess)
-import RIO.PrettyPrint
-import RIO.Process
+import System.Console.ANSI ( hSupportsANSIWithoutEmulation )
+import System.Process ( rawSystem, readProcess )
+-- | Type representing exceptions thrown by functions exported by the
+-- "Stack.Upgrade" module.
+data UpgradeException
+ = NeitherBinaryOrSourceSpecified
+ | ExecutableFailure
+ | CommitsNotFound String String
+ | StackInPackageIndexNotFound
+ | VersionWithNoRevision
+ deriving (Show, Typeable)
+
+instance Exception UpgradeException where
+ displayException NeitherBinaryOrSourceSpecified =
+ "Error: [S-3642]\n"
+ ++ "You must allow either binary or source upgrade paths."
+ displayException ExecutableFailure =
+ "Error: [S-8716]\n"
+ ++ "Non-success exit code from running newly downloaded executable."
+ displayException (CommitsNotFound branch repo) = concat
+ [ "Error: [S-7114]\n"
+ , "No commits found for branch "
+ , branch
+ , " on repo "
+ , repo
+ ]
+ displayException StackInPackageIndexNotFound =
+ "Error: [S-9668]\n"
+ ++ "No Stack version found in package indices."
+ displayException VersionWithNoRevision =
+ "Error: [S-6648]\n"
+ ++ "Latest version with no revision."
+
upgradeOpts :: Parser UpgradeOpts
upgradeOpts = UpgradeOpts
<$> (sourceOnly <|> optional binaryOpts)
@@ -42,10 +70,10 @@
<> showDefault))
<*> switch
(long "force-download" <>
- help "Download the latest available stack executable")
+ help "Download the latest available Stack executable")
<*> optional (strOption
(long "binary-version" <>
- help "Download a specific stack version"))
+ help "Download a specific Stack version"))
<*> optional (strOption
(long "github-org" <>
help "GitHub organization name"))
@@ -97,7 +125,7 @@
-- FIXME It would be far nicer to capture this case in the
-- options parser itself so we get better error messages, but
-- I can't think of a way to make it happen.
- (Nothing, Nothing) -> throwString "You must allow either binary or source upgrade paths"
+ (Nothing, Nothing) -> throwIO NeitherBinaryOrSourceSpecified
(Just bo, Nothing) -> binary bo
(Nothing, Just so) -> source so
-- See #2977 - if --git or --git-repo is specified, do source upgrade.
@@ -119,7 +147,7 @@
platforms0 <-
case mplatform of
Nothing -> preferredPlatforms
- Just p -> return [("windows" `T.isInfixOf` T.pack p, p)]
+ Just p -> pure [("windows" `T.isInfixOf` T.pack p, p)]
archiveInfo <- downloadStackReleaseInfo morg mrepo mver
let mdownloadVersion = getDownloadVersion archiveInfo
@@ -135,7 +163,7 @@
:
[ line <> flow "Rerun with --force-download to force an upgrade"
| not force]
- return False
+ pure False
Just downloadVersion -> do
prettyInfoL
[ flow "Current Stack version:"
@@ -143,26 +171,24 @@
, flow "available download version:"
, fromString (versionString downloadVersion)
]
- return $ downloadVersion > stackVersion
+ pure $ downloadVersion > stackVersion
toUpgrade <- case (force, isNewer) of
(False, False) -> do
prettyInfoS "Skipping binary upgrade, you are already running the most recent version"
- return False
+ pure False
(True, False) -> do
prettyInfoS "Forcing binary upgrade"
- return True
+ pure True
(_, True) -> do
prettyInfoS "Newer version detected, downloading"
- return True
+ pure True
when toUpgrade $ do
config <- view configL
downloadStackExe platforms0 archiveInfo (configLocalBin config) True $ \tmpFile -> do
-- Sanity check!
ec <- rawSystem (toFilePath tmpFile) ["--version"]
-
- unless (ec == ExitSuccess)
- $ throwString "Non-success exit code from running newly downloaded executable"
+ unless (ec == ExitSuccess) (throwIO ExecutableFailure)
sourceUpgrade
:: Maybe String
@@ -175,23 +201,23 @@
remote <- liftIO $ System.Process.readProcess "git" ["ls-remote", repo, branch] []
latestCommit <-
case words remote of
- [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo
- x:_ -> return x
+ [] -> throwIO $ CommitsNotFound branch repo
+ x:_ -> pure x
when (isNothing builtHash) $
prettyWarnS $
- "Information about the commit this version of stack was "
+ "Information about the commit this version of Stack was "
<> "built from is not available due to how it was built. "
<> "Will continue by assuming an upgrade is needed "
<> "because we have no information to the contrary."
if builtHash == Just latestCommit
then do
prettyInfoS "Already up-to-date, no upgrade required"
- return Nothing
+ pure Nothing
else do
prettyInfoS "Cloning stack"
-- NOTE: "--recursive" was added after v1.0.0 (and before the
-- next release). This means that we can't use submodules in
- -- the stack repo until we're comfortable with "stack upgrade
+ -- the Stack repo until we're comfortable with "stack upgrade
-- --git" not working for earlier versions.
let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch]
withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_
@@ -201,7 +227,7 @@
-- The following hack re-enables the lost ANSI-capability.
when osIsWindows $
void $ liftIO $ hSupportsANSIWithoutEmulation stdout
- return $ Just $ tmp relDirStackProgName
+ pure $ Just $ tmp relDirStackProgName
-- We need to access the Pantry database to find out about the
-- latest Stack available on Hackage. We first use a standard
-- Config to do this, and once we have the source load up the
@@ -212,19 +238,19 @@
mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions
(PackageIdentifierRevision _ version _) <-
case mversion of
- Nothing -> throwString "No stack found in package indices"
+ Nothing -> throwIO StackInPackageIndexNotFound
Just version -> pure version
- if version <= mkVersion' Paths.version
+ if version <= stackVersion
then do
prettyInfoS "Already at latest version, no upgrade required"
- return Nothing
+ pure Nothing
else do
suffix <- parseRelDir $ "stack-" ++ versionString version
let dir = tmp suffix
mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version
case mrev of
- Nothing -> throwString "Latest version with no revision"
+ Nothing -> throwIO VersionWithNoRevision
Just (_rev, cfKey, treeKey) -> do
let ident = PackageIdentifier "stack" version
unpackPackageLocation dir $ PLIHackage ident cfKey treeKey
diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs
--- a/src/Stack/Upload.hs
+++ b/src/Stack/Upload.hs
@@ -7,54 +7,71 @@
-- | Provide ability to upload tarballs to Hackage.
module Stack.Upload
- ( -- * Upload
- upload
- , uploadBytes
- , uploadRevision
- -- * Credentials
- , HackageCreds
- , HackageAuth(..)
- , HackageKey(..)
- , loadAuth
- , writeFilePrivate
- -- * Internal
- , maybeGetHackageKey
- ) where
+ ( -- * Upload
+ upload
+ , uploadBytes
+ , uploadRevision
+ -- * Credentials
+ , HackageCreds
+ , HackageAuth (..)
+ , HackageKey (..)
+ , loadAuth
+ , writeFilePrivate
+ -- * Internal
+ , maybeGetHackageKey
+ ) where
-import Stack.Prelude
-import Data.Aeson (FromJSON (..),
- ToJSON (..),
- decode', toEncoding, fromEncoding,
- object, withObject,
- (.:), (.=))
-import Data.ByteString.Builder (lazyByteString)
-import qualified Data.ByteString.Char8 as S
-import qualified Data.ByteString.Lazy as L
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Text as T
-import Network.HTTP.StackClient (Request,
- RequestBody(RequestBodyLBS),
- Response,
- withResponse,
- httpNoBody,
- getGlobalManager,
- getResponseStatusCode,
- getResponseBody,
- setRequestHeader,
- parseRequest,
- formDataBody, partFileRequestBody,
- partBS, partLBS,
- applyDigestAuth,
- displayDigestAuthException)
+import Conduit ( mapOutput, sinkList )
+import Data.Aeson
+ ( FromJSON (..), ToJSON (..), decode', toEncoding
+ , fromEncoding, object, withObject, (.:), (.=)
+ )
+import Data.ByteString.Builder ( lazyByteString )
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Text as T
+import Network.HTTP.StackClient
+ ( Request, RequestBody (RequestBodyLBS), Response
+ , withResponse, httpNoBody, getGlobalManager
+ , getResponseStatusCode, getResponseBody, setRequestHeader
+ , parseRequest, formDataBody, partFileRequestBody, partBS
+ , partLBS, applyDigestAuth, displayDigestAuthException
+ )
import Stack.Options.UploadParser
+import Stack.Prelude
import Stack.Types.Config
-import System.Directory (createDirectoryIfMissing,
- removeFile, renameFile)
-import System.Environment (lookupEnv)
-import System.FilePath ((), takeFileName, takeDirectory)
-import System.PosixCompat.Files (setFileMode)
+import System.Directory
+ ( createDirectoryIfMissing, removeFile, renameFile )
+import System.Environment ( lookupEnv )
+import System.FilePath ( (), takeFileName, takeDirectory )
+import System.PosixCompat.Files ( setFileMode )
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
+-- "Stack.Upload" module.
+data UploadPrettyException
+ = AuthenticationFailure
+ | ArchiveUploadFailure Int [String] String
+ deriving (Show, Typeable)
+instance Pretty UploadPrettyException where
+ pretty AuthenticationFailure =
+ "[S-2256]"
+ <> line
+ <> flow "authentification failure"
+ <> line
+ <> flow "Authentication failure uploading to server"
+ pretty (ArchiveUploadFailure code res tarName) =
+ "[S-6108]"
+ <> line
+ <> flow "unhandled status code:" <+> fromString (show code)
+ <> line
+ <> flow "Upload failed on" <+> style File (fromString tarName)
+ <> line
+ <> vsep (map string res)
+
+instance Exception UploadPrettyException
+
newtype HackageKey = HackageKey Text
deriving (Eq, Show)
@@ -94,7 +111,7 @@
case maybeHackageKey of
Just key -> do
logInfo "HACKAGE_KEY found in env, using that for credentials."
- return $ HAKey key
+ pure $ HAKey key
Nothing -> HACreds <$> loadUserAndPassword config
-- | Load Hackage credentials, either from a save file or the command
@@ -116,7 +133,7 @@
logWarn "WARNING: You've set save-hackage-creds to false"
logWarn "However, credentials were found at:"
logWarn $ " " <> fromString fp
- return $ mkCreds fp
+ pure $ mkCreds fp
where
fromPrompt :: HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt fp = do
@@ -137,7 +154,7 @@
logInfo "Saved!"
hFlush stdout
- return hc
+ pure hc
-- | Write contents to a file which is always private.
--
@@ -165,7 +182,7 @@
credsFile config = do
let dir = toFilePath (view stackRootL config) "upload"
createDirectoryIfMissing True dir
- return $ dir "credentials.json"
+ pure $ dir "credentials.json"
addAPIKey :: HackageKey -> Request -> Request
addAPIKey (HackageKey key) req =
@@ -174,7 +191,7 @@
applyAuth :: HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth haAuth req0 = do
case haAuth of
- HAKey key -> return (addAPIKey key req0)
+ HAKey key -> pure (addAPIKey key req0)
HACreds creds -> applyCreds creds req0
applyCreds :: HasLogFunc m => HackageCreds -> Request -> RIO m Request
@@ -191,8 +208,8 @@
case fromException e of
Just e' -> logWarn $ fromString $ displayDigestAuthException e'
Nothing -> logWarn $ fromString $ displayException e
- return req0
- Right req -> return req
+ pure req0
+ Right req -> pure req
-- | Upload a single tarball with the given @Uploader@. Instead of
-- sending a file like 'upload', this sends a lazy bytestring.
@@ -225,25 +242,26 @@
case getResponseStatusCode res of
200 -> logInfo "done!"
401 -> do
- logError "authentication failure"
case auth of
- HACreds creds -> handleIO (const $ return ()) (liftIO $ removeFile (hcCredsFile creds))
+ HACreds creds -> handleIO (const $ pure ()) (liftIO $ removeFile (hcCredsFile creds))
_ -> pure ()
- throwString "Authentication failure uploading to server"
+ throwIO $ PrettyException AuthenticationFailure
403 -> do
+ logError "Error: [S-2804]"
logError "forbidden upload"
logError "Usually means: you've already uploaded this package/version combination"
logError "Ignoring error and continuing, full message from Hackage below:\n"
liftIO $ printBody res
503 -> do
+ logError "Error: [S-4444]"
logError "service unavailable"
logError "This error some times gets sent even though the upload succeeded"
logError "Check on Hackage to see if your package is present"
liftIO $ printBody res
code -> do
- logError $ "unhandled status code: " <> fromString (show code)
- liftIO $ printBody res
- throwString $ "Upload failed on " <> fromString tarName
+ let resBody = mapOutput show (getResponseBody res)
+ resBody' <- liftIO $ runConduit $ resBody .| sinkList
+ throwIO $ PrettyException (ArchiveUploadFailure code resBody' tarName)
printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout
diff --git a/src/System/Process/Pager.hs b/src/System/Process/Pager.hs
--- a/src/System/Process/Pager.hs
+++ b/src/System/Process/Pager.hs
@@ -10,17 +10,36 @@
, PagerException (..)
) where
-import Stack.Prelude
-import System.Directory (findExecutable)
-import System.Environment (lookupEnv)
-import System.Process ( createProcess, cmdspec, shell, proc, waitForProcess
- , CmdSpec (ShellCommand, RawCommand)
- , StdStream (CreatePipe)
- , CreateProcess (std_in, close_fds, delegate_ctlc)
- )
-import Control.Monad.Trans.Maybe (MaybeT (runMaybeT, MaybeT))
+import Control.Monad.Trans.Maybe ( MaybeT (runMaybeT, MaybeT) )
import qualified Data.Text.IO as T
+import Stack.Prelude
+import System.Directory ( findExecutable )
+import System.Environment ( lookupEnv )
+import System.Process
+ ( createProcess, cmdspec, shell, proc, waitForProcess
+ , CmdSpec (ShellCommand, RawCommand)
+ , StdStream (CreatePipe)
+ , CreateProcess (std_in, close_fds, delegate_ctlc)
+ )
+-- | Type representing exceptions thrown by functions exported by the
+-- "System.Process.Pager" module.
+data PagerException
+ = PagerExitFailure CmdSpec Int
+ deriving (Show, Typeable)
+
+instance Exception PagerException where
+ displayException (PagerExitFailure cmd n) =
+ let getStr (ShellCommand c) = c
+ getStr (RawCommand exePath _) = exePath
+ in concat
+ [ "Error: [S-9392]\n"
+ , "Pager (`"
+ , getStr cmd
+ , "') exited with non-zero status: "
+ , show n
+ ]
+
-- | Run pager, providing a function that writes to the pager's input.
pageWriter :: (Handle -> IO ()) -> IO ()
pageWriter writer =
@@ -38,9 +57,9 @@
hClose h)
exit <- waitForProcess procHandle
case exit of
- ExitSuccess -> return ()
+ ExitSuccess -> pure ()
ExitFailure n -> throwIO (PagerExitFailure (cmdspec pager) n)
- return ()
+ pure ()
Nothing -> writer stdout
where
cmdspecFromEnvVar = shell <$> MaybeT (lookupEnv "PAGER")
@@ -50,16 +69,3 @@
-- | Run pager to display a 'Text'
pageText :: Text -> IO ()
pageText = pageWriter . flip T.hPutStr
-
--- | Exception running pager.
-data PagerException = PagerExitFailure CmdSpec Int
- deriving Typeable
-instance Show PagerException where
- show (PagerExitFailure cmd n) =
- let
- getStr (ShellCommand c) = c
- getStr (RawCommand exePath _) = exePath
- in
- "Pager (`" ++ getStr cmd ++ "') exited with non-zero status: " ++ show n
-
-instance Exception PagerException
diff --git a/src/main/BuildInfo.hs b/src/main/BuildInfo.hs
--- a/src/main/BuildInfo.hs
+++ b/src/main/BuildInfo.hs
@@ -14,28 +14,24 @@
, hpackVersion
) where
-import Stack.Prelude
-import qualified Paths_stack as Meta
-import qualified Distribution.Text as Cabal (display)
-import Distribution.System (buildArch)
-
#ifndef HIDE_DEP_VERSIONS
import qualified Build_stack
#endif
-
#ifdef USE_GIT_INFO
-import GitHash (giCommitCount, giHash, tGitInfoCwdTry)
+import Data.Version ( versionBranch )
+#else
+import Data.Version ( showVersion, versionBranch )
#endif
-
+import Distribution.System ( buildArch )
+import qualified Distribution.Text as Cabal ( display )
#ifdef USE_GIT_INFO
-import Options.Applicative.Simple (simpleVersion)
+import GitHash ( giCommitCount, giHash, tGitInfoCwdTry )
#endif
-
#ifdef USE_GIT_INFO
-import Data.Version (versionBranch)
-#else
-import Data.Version (showVersion, versionBranch)
+import Options.Applicative.Simple ( simpleVersion )
#endif
+import Stack.Prelude
+import qualified Paths_stack as Meta
versionString' :: String
#ifdef USE_GIT_INFO
@@ -50,7 +46,7 @@
, [afterVersion]
]
#else
-versionString' = showVersion Meta.version ++ afterVersion
+versionString' = showStackVersion ++ afterVersion
#endif
where
afterVersion = concat
diff --git a/src/main/Main.hs b/src/main/Main.hs
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -6,901 +6,1101 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
--- | Main stack tool entry point.
-
-module Main (main) where
-
-import BuildInfo
-import Stack.Prelude hiding (Display (..))
-import Conduit (runConduitRes, sourceLazy, sinkFileCautious)
-import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))
-import Data.Attoparsec.Interpreter (getInterpreterArgs)
-import Data.List
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import Data.Version (showVersion)
-import RIO.Process
-import Distribution.Version (mkVersion')
-import GHC.IO.Encoding (mkTextEncoding, textEncodingName)
-import Options.Applicative
-import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks)
-import Options.Applicative.Builder.Extra
-import Options.Applicative.Complicated
-import Pantry (loadSnapshot)
-import Path
-import Path.IO
-import qualified Paths_stack as Meta
-import RIO.PrettyPrint
-import qualified RIO.PrettyPrint as PP (style)
-import Stack.Build
-import Stack.Build.Target (NeedTargets(..))
-import Stack.Clean (CleanCommand(..), CleanOpts(..), clean)
-import Stack.Config
-import Stack.ConfigCmd as ConfigCmd
-import Stack.Constants
-import Stack.Constants.Config
-import Stack.Coverage
-import qualified Stack.Docker as Docker
-import Stack.Dot
-import Stack.GhcPkg (findGhcPkgField)
-import qualified Stack.Nix as Nix
-import Stack.FileWatch
-import Stack.Ghci
-import Stack.Hoogle
-import Stack.List
-import Stack.Ls
-import qualified Stack.IDE as IDE
-import Stack.Init
-import Stack.New
-import Stack.Options.BuildParser
-import Stack.Options.CleanParser
-import Stack.Options.DockerParser
-import Stack.Options.DotParser
-import Stack.Options.ExecParser
-import Stack.Options.GhciParser
-import Stack.Options.GlobalParser
-
-import Stack.Options.HpcReportParser
-import Stack.Options.NewParser
-import Stack.Options.NixParser
-import Stack.Options.ScriptParser
-import Stack.Options.SDistParser
-import Stack.Options.UploadParser
-import Stack.Options.Utils
-import qualified Stack.Path
-import Stack.Runners
-import Stack.Script
-import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..))
-import Stack.Setup (withNewLocalBuildTargets)
-import Stack.SetupCmd
-import Stack.Types.Version
-import Stack.Types.Config
-import Stack.Types.NamedComponent
-import Stack.Types.SourceMap
-import Stack.Unpack
-import Stack.Upgrade
-import qualified Stack.Upload as Upload
-import qualified System.Directory as D
-import System.Environment (getProgName, getArgs, withArgs)
-import System.FilePath (isValid, pathSeparator, takeDirectory)
-import qualified System.FilePath as FP
-import System.IO (hPutStrLn, hGetEncoding, hSetEncoding)
-import System.Terminal (hIsTerminalDeviceOrMinTTY)
-
--- | 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 ()
-
-main :: IO ()
-main = 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 LineBuffering
- hSetTranslit stdout
- hSetTranslit stderr
- args <- getArgs
- progName <- getProgName
- isTerminal <- hIsTerminalDeviceOrMinTTY stdout
- -- On Windows, where applicable, defaultColorWhen has the side effect of
- -- enabling ANSI for ANSI-capable native (ConHost) terminals, if not already
- -- ANSI-enabled.
- execExtraHelp args
- Docker.dockerHelpOptName
- (dockerOptsParser False)
- ("Only showing --" ++ Docker.dockerCmdName ++ "* options.")
- execExtraHelp args
- Nix.nixHelpOptName
- (nixOptsParser False)
- ("Only showing --" ++ Nix.nixCmdName ++ "* options.")
-
- currentDir <- D.getCurrentDirectory
- eGlobalRun <- try $ commandLineHandler currentDir progName False
- case eGlobalRun of
- Left (exitCode :: ExitCode) ->
- throwIO exitCode
- Right (globalMonoid,run) -> do
- global <- globalOptsFromMonoid isTerminal globalMonoid
- when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'
- case globalReExecVersion global of
- Just expectVersion -> do
- expectVersion' <- parseVersionThrowing expectVersion
- unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))
- $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)
- _ -> return ()
- withRunnerGlobal global $ run `catch` \e ->
- -- This special handler stops "stack: " from being printed before the
- -- exception
- case fromException e of
- Just ec -> exitWith ec
- Nothing -> do
- logError $ fromString $ displayException e
- exitFailure
-
--- Vertically combine only the error component of the first argument with the
--- error component of the second.
-vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp
-vcatErrorHelp h1 h2 = h2 { helpError = vcatChunks [helpError h2, helpError h1] }
-
-commandLineHandler
- :: FilePath
- -> String
- -> Bool
- -> IO (GlobalOptsMonoid, RIO Runner ())
-commandLineHandler currentDir progName isInterpreter = complicatedOptions
- (mkVersion' Meta.version)
- (Just versionString')
- hpackVersion
- "stack - The Haskell Tool Stack"
- ""
- "stack's documentation is available at https://docs.haskellstack.org/"
- (globalOpts OuterGlobalOpts)
- (Just failureCallback)
- addCommands
- where
- failureCallback f args =
- case stripPrefix "Invalid argument" (fst (renderFailure f "")) of
- Just _ -> if isInterpreter
- then parseResultHandler args f
- else secondaryCommandHandler args f
- >>= interpreterHandler currentDir args
- Nothing -> parseResultHandler args f
-
- parseResultHandler args f =
- if isInterpreter
- then do
- let hlp = errorHelp $ stringChunk
- (unwords ["Error executing interpreter command:"
- , progName
- , unwords args])
- handleParseResult (overFailure (vcatErrorHelp hlp) (Failure f))
- else handleParseResult (Failure f)
-
- addCommands = do
- unless isInterpreter (do
- addBuildCommand' "build"
- "Build the package(s) in this directory/configuration"
- buildCmd
- (buildOptsParser Build)
- addBuildCommand' "install"
- "Shortcut for 'build --copy-bins'"
- buildCmd
- (buildOptsParser Install)
- addCommand' "uninstall"
- (unwords [ "Show how to uninstall Stack. This command does not"
- , "itself uninstall Stack."
- ] )
- uninstallCmd
- (pure())
- addBuildCommand' "test"
- "Shortcut for 'build --test'"
- buildCmd
- (buildOptsParser Test)
- addBuildCommand' "bench"
- "Shortcut for 'build --bench'"
- buildCmd
- (buildOptsParser Bench)
- addBuildCommand' "haddock"
- "Shortcut for 'build --haddock'"
- buildCmd
- (buildOptsParser Haddock)
- addCommand' "new"
- (unwords [ "Create a new project from a template."
- , "Run `stack templates' to see available templates. Will"
- , "also initialise if there is no stack.yaml file."
- , "Note: you can also specify a local file or a"
- , "remote URL as a template; or force an initialisation."
- ] )
- newCmd
- newOptsParser
- addCommand' "templates"
- (unwords [ "Show how to find templates available for `stack new'."
- , "`stack new' can accept a template from a remote repository"
- , "(default: github), local file or remote URL."
- , "Note: this downloads the help file."
- ] )
- templatesCmd
- (pure ())
- addCommand' "init"
- "Create stack project config from cabal or hpack package specifications"
- initCmd
- initOptsParser
- addCommand' "setup"
- "Get the appropriate GHC for your project"
- setupCmd
- setupParser
- addCommand' "path"
- "Print out handy path information"
- Stack.Path.path
- Stack.Path.pathParser
- addCommand' "ls"
- "List command. (Supports snapshots, dependencies, stack's styles and installed tools)"
- lsCmd
- lsParser
- addCommand' "unpack"
- "Unpack one or more packages locally"
- unpackCmd
- ((,) <$> some (strArgument $ metavar "PACKAGE")
- <*> optional (textOption $ long "to" <>
- help "Optional path to unpack the package into (will unpack into subdirectory)"))
- addCommand' "update"
- "Update the package index"
- updateCmd
- (pure ())
- addCommand' "upgrade"
- "Upgrade to the latest stack"
- upgradeCmd
- upgradeOpts
- addCommand'
- "upload"
- "Upload a package to Hackage"
- uploadCmd
- uploadOptsParser
- addCommand'
- "sdist"
- "Create source distribution tarballs"
- sdistCmd
- sdistOptsParser
- addCommand' "dot"
- "Visualize your project's dependency graph using Graphviz dot"
- dot
- (dotOptsParser False) -- Default for --external is False.
- addCommand' "ghc"
- "Run ghc"
- execCmd
- (execOptsParser $ Just ExecGhc)
- addCommand' "hoogle"
- ("Run hoogle, the Haskell API search engine. Use the '-- ARGUMENT(S)' syntax " ++
- "to pass Hoogle arguments, e.g. stack hoogle -- --count=20, or " ++
- "stack hoogle -- server --local.")
- hoogleCmd
- ((,,,) <$> many (strArgument
- (metavar "-- ARGUMENT(S) (e.g. stack hoogle -- server --local)"))
- <*> boolFlags
- True
- "setup"
- "If needed: install hoogle, build haddocks and generate a hoogle database"
- idm
- <*> switch
- (long "rebuild" <>
- help "Rebuild the hoogle database")
- <*> switch
- (long "server" <>
- help "Start local Hoogle server"))
- )
-
- -- These are the only commands allowed in interpreter mode as well
- addCommand' "exec"
- "Execute a command. If the command is absent, the first of any arguments is taken as the command."
- execCmd
- (execOptsParser Nothing)
- addCommand' "run"
- "Build and run an executable. Defaults to the first available executable if none is provided as the first argument."
- execCmd
- (execOptsParser $ Just ExecRun)
- addGhciCommand' "ghci"
- "Run ghci in the context of package(s) (experimental)"
- ghciCmd
- ghciOptsParser
- addGhciCommand' "repl"
- "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"
- ghciCmd
- ghciOptsParser
- addCommand' "runghc"
- "Run runghc"
- execCmd
- (execOptsParser $ Just ExecRunGhc)
- addCommand' "runhaskell"
- "Run runghc (alias for 'runghc')"
- execCmd
- (execOptsParser $ Just ExecRunGhc)
- addCommand "script"
- "Run a Stack Script"
- globalFooter
- scriptCmd
- (\so gom ->
- gom
- { globalMonoidResolverRoot = First $ Just $ takeDirectory $ soFile so
- })
- (globalOpts OtherCmdGlobalOpts)
- scriptOptsParser
-
- unless isInterpreter (do
- addCommand' "eval"
- "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"
- evalCmd
- (evalOptsParser "CODE")
- addCommand' "clean"
- "Delete build artefacts for the project packages."
- cleanCmd
- (cleanOptsParser Clean)
- addCommand' "purge"
- "Delete the project stack working directories (.stack-work by default). Shortcut for 'stack clean --full'"
- cleanCmd
- (cleanOptsParser Purge)
- addCommand' "query"
- "Query general build information (experimental)"
- queryCmd
- (many $ strArgument $ metavar "SELECTOR...")
- addCommand' "list"
- "List package id's in snapshot (experimental)"
- listCmd
- (many $ strArgument $ metavar "PACKAGE")
- addSubCommands'
- "ide"
- "IDE-specific commands"
- (let outputFlag = flag
- IDE.OutputLogInfo
- IDE.OutputStdout
- (long "stdout" <>
- help "Send output to stdout instead of the default, stderr")
- cabalFileFlag = flag
- IDE.ListPackageNames
- IDE.ListPackageCabalFiles
- (long "cabal-files" <>
- help "Print paths to package cabal-files instead of package names")
- in
- do addCommand'
- "packages"
- "List all available local loadable packages"
- idePackagesCmd
- ((,) <$> outputFlag <*> cabalFileFlag)
- addCommand'
- "targets"
- "List all available stack targets"
- ideTargetsCmd
- outputFlag)
- addSubCommands'
- Docker.dockerCmdName
- "Subcommands specific to Docker use"
- (do addCommand' Docker.dockerPullCmdName
- "Pull latest version of Docker image from registry"
- dockerPullCmd
- (pure ())
- addCommand' "reset"
- "Reset the Docker sandbox"
- dockerResetCmd
- (switch (long "keep-home" <>
- help "Do not delete sandbox's home directory")))
- addSubCommands'
- ConfigCmd.cfgCmdName
- "Subcommands for accessing and modifying configuration values"
- (do
- addCommand' ConfigCmd.cfgCmdSetName
- "Sets a key in YAML configuration file to value"
- (withConfig NoReexec . cfgCmdSet)
- configCmdSetParser
- addCommand' ConfigCmd.cfgCmdEnvName
- "Print environment variables for use in a shell"
- (withConfig YesReexec . withDefaultEnvConfig . cfgCmdEnv)
- configCmdEnvParser)
- addSubCommands'
- "hpc"
- "Subcommands specific to Haskell Program Coverage"
- (addCommand' "report"
- "Generate unified HPC coverage report from tix files and project targets"
- hpcReportCmd
- hpcReportOptsParser)
- )
- where
- -- addCommand hiding global options
- addCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a
- -> AddCommand
- addCommand' cmd title constr =
- addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts OtherCmdGlobalOpts)
-
- addSubCommands' :: String -> String -> AddCommand
- -> AddCommand
- addSubCommands' cmd title =
- addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts)
-
- -- Additional helper that hides global options and shows build options
- addBuildCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a
- -> AddCommand
- addBuildCommand' cmd title constr =
- addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts BuildCmdGlobalOpts)
-
- -- Additional helper that hides global options and shows some ghci options
- addGhciCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a
- -> AddCommand
- addGhciCommand' cmd title constr =
- addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts GhciCmdGlobalOpts)
-
- globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid
- globalOpts kind =
- extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>
- extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>
- globalOptsParser currentDir kind
- (if isInterpreter
- -- Silent except when errors occur - see #2879
- then Just LevelError
- else Nothing)
- where hide = kind /= OuterGlobalOpts
-
- globalFooter = "Run 'stack --help' for global options that apply to all subcommands."
-
--- | fall-through to external executables in `git` style if they exist
--- (i.e. `stack something` looks for `stack-something` before
--- failing with "Invalid argument `something'")
-secondaryCommandHandler
- :: [String]
- -> ParserFailure ParserHelp
- -> IO (ParserFailure ParserHelp)
-secondaryCommandHandler args f =
- -- don't even try when the argument looks like a path or flag
- if elem pathSeparator cmd || "-" `isPrefixOf` head args
- then return f
- else do
- mExternalExec <- D.findExecutable cmd
- case mExternalExec of
- Just ex -> withProcessContextNoLogging $ do
- -- TODO show the command in verbose mode
- -- hPutStrLn stderr $ unwords $
- -- ["Running", "[" ++ ex, unwords (tail args) ++ "]"]
- _ <- exec ex (tail args)
- return f
- Nothing -> return $ fmap (vcatErrorHelp (noSuchCmd cmd)) f
- where
- -- FIXME this is broken when any options are specified before the command
- -- e.g. stack --verbosity silent cmd
- cmd = stackProgName ++ "-" ++ head args
- noSuchCmd name = errorHelp $ stringChunk
- ("Auxiliary command not found in path `" ++ name ++ "'")
-
-interpreterHandler
- :: Monoid t
- => FilePath
- -> [String]
- -> ParserFailure ParserHelp
- -> IO (GlobalOptsMonoid, (RIO Runner (), t))
-interpreterHandler currentDir args f = do
- -- args can include top-level config such as --extra-lib-dirs=... (set by
- -- nix-shell) - we need to find the first argument which is a file, everything
- -- afterwards is an argument to the script, everything before is an argument
- -- to Stack
- (stackArgs, fileArgs) <- spanM (fmap not . D.doesFileExist) args
- case fileArgs of
- (file:fileArgs') -> runInterpreterCommand file stackArgs fileArgs'
- [] -> parseResultHandler (errorCombine (noSuchFile firstArg))
- where
- firstArg = head args
-
- spanM _ [] = return ([], [])
- spanM p xs@(x:xs') = do
- r <- p x
- if r
- then do
- (ys, zs) <- spanM p xs'
- return (x:ys, zs)
- else
- return ([], xs)
-
- -- if the first argument contains a path separator then it might be a file,
- -- or a Stack option referencing a file. In that case we only show the
- -- interpreter error message and exclude the command related error messages.
- errorCombine =
- if pathSeparator `elem` firstArg
- then overrideErrorHelp
- else vcatErrorHelp
-
- overrideErrorHelp h1 h2 = h2 { helpError = helpError h1 }
-
- parseResultHandler fn = handleParseResult (overFailure fn (Failure f))
- noSuchFile name = errorHelp $ stringChunk
- ("File does not exist or is not a regular file `" ++ name ++ "'")
-
- runInterpreterCommand path stackArgs fileArgs = do
- progName <- getProgName
- iargs <- getInterpreterArgs path
- let parseCmdLine = commandLineHandler currentDir progName True
- -- Implicit file arguments are put before other arguments that
- -- occur after "--". See #3658
- cmdArgs = stackArgs ++ case break (== "--") iargs of
- (beforeSep, []) -> beforeSep ++ ["--"] ++ [path] ++ fileArgs
- (beforeSep, optSep : afterSep) ->
- beforeSep ++ [optSep] ++ [path] ++ fileArgs ++ afterSep
- -- TODO show the command in verbose mode
- -- hPutStrLn stderr $ unwords $
- -- ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]
- (a,b) <- withArgs cmdArgs parseCmdLine
- return (a,(b,mempty))
-
-setupCmd :: SetupCmdOpts -> RIO Runner ()
-setupCmd sco@SetupCmdOpts{..} = withConfig YesReexec $ withBuildConfig $ do
- (wantedCompiler, compilerCheck, mstack) <-
- case scoCompilerVersion of
- Just v -> return (v, MatchMinor, Nothing)
- Nothing -> (,,)
- <$> view wantedCompilerVersionL
- <*> view (configL.to configCompilerCheck)
- <*> (Just <$> view stackYamlL)
- setup sco wantedCompiler compilerCheck mstack
-
-cleanCmd :: CleanOpts -> RIO Runner ()
-cleanCmd = withConfig NoReexec . clean
-
--- | Helper for build and install commands
-buildCmd :: BuildOptsCLI -> RIO Runner ()
-buildCmd opts = do
- when (any (("-prof" `elem`) . fromRight [] . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do
- logError "Error: When building with stack, you should not use the -prof GHC option"
- logError "Instead, please use --library-profiling and --executable-profiling"
- logError "See: https://github.com/commercialhaskell/stack/issues/1015"
- exitFailure
- local (over globalOptsL modifyGO) $
- case boptsCLIFileWatch opts of
- FileWatchPoll -> fileWatchPoll (inner . Just)
- FileWatch -> fileWatch (inner . Just)
- NoFileWatch -> inner Nothing
- where
- inner
- :: Maybe (Set (Path Abs File) -> IO ())
- -> RIO Runner ()
- inner setLocalFiles = withConfig YesReexec $ withEnvConfig NeedTargets opts $
- Stack.Build.build setLocalFiles
- -- Read the build command from the CLI and enable it to run
- modifyGO =
- case boptsCLICommand opts of
- Test -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True)
- Haddock -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just True)
- Bench -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True)
- Install -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidInstallExesL) (Just True)
- Build -> id -- Default case is just Build
-
--- | Display help for the uninstall command.
-uninstallCmd :: () -> RIO Runner ()
-uninstallCmd () = withConfig NoReexec $ do
- stackRoot <- view stackRootL
- programsDir <- view $ configL.to configLocalProgramsBase
- localBinDir <- view $ configL.to configLocalBin
- let toStyleDoc = PP.style Dir . fromString . toFilePath
- stackRoot' = toStyleDoc stackRoot
- programsDir' = toStyleDoc programsDir
- localBinDir' = toStyleDoc localBinDir
- prettyInfo $ vsep
- [ flow "To uninstall Stack, it should be sufficient to delete:"
- , hang 4 $ fillSep [flow "(1) the directory containing Stack's tools",
- "(" <> softbreak <> programsDir' <> softbreak <> ");"]
- , hang 4 $ fillSep [flow "(2) the Stack root directory",
- "(" <> softbreak <> stackRoot' <> softbreak <> ");", "and"]
- , hang 4 $ fillSep [flow "(3) the 'stack' executable file (see the output",
- flow "of command", howToFindStack <> ",", flow "if Stack is on the PATH;",
- flow "Stack is often installed in", localBinDir' <> softbreak <> ")."]
- , fillSep [flow "You may also want to delete", PP.style File ".stack-work",
- flow "directories in any Haskell projects that you have built."]
- ]
- where
- styleShell = PP.style Shell
- howToFindStack
- | osIsWindows = styleShell "where.exe stack"
- | otherwise = styleShell "which stack"
-
--- | Unpack packages to the filesystem
-unpackCmd :: ([String], Maybe Text) -> RIO Runner ()
-unpackCmd (names, Nothing) = unpackCmd (names, Just ".")
-unpackCmd (names, Just dstPath) = withConfig NoReexec $ do
- mresolver <- view $ globalOptsL.to globalResolver
- mSnapshot <- forM mresolver $ \resolver -> do
- concrete <- makeConcreteResolver resolver
- loc <- completeSnapshotLocation concrete
- loadSnapshot loc
- dstPath' <- resolveDir' $ T.unpack dstPath
- unpackPackages mSnapshot dstPath' names
-
--- | Update the package index
-updateCmd :: () -> RIO Runner ()
-updateCmd () = withConfig NoReexec (void (updateHackageIndex Nothing))
-
-upgradeCmd :: UpgradeOpts -> RIO Runner ()
-upgradeCmd upgradeOpts' = do
- go <- view globalOptsL
- case globalResolver go of
- Just _ -> do
- logError "You cannot use the --resolver option with the upgrade command"
- liftIO exitFailure
- Nothing ->
- withGlobalProject $
- upgrade
- maybeGitHash
- upgradeOpts'
-
--- | Upload to Hackage
-uploadCmd :: UploadOpts -> RIO Runner ()
-uploadCmd (UploadOpts (SDistOpts [] _ _ _ _) _) = do
- prettyErrorL
- [ flow "To upload the current package, please run"
- , PP.style Shell "stack upload ."
- , flow "(with the period at the end)"
- ]
- liftIO exitFailure
-uploadCmd uploadOpts = do
- let partitionM _ [] = return ([], [])
- partitionM f (x:xs) = do
- r <- f x
- (as, bs) <- partitionM f xs
- return $ if r then (x:as, bs) else (as, x:bs)
- sdistOpts = uoptsSDistOpts uploadOpts
- (files, nonFiles) <- liftIO $ partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)
- (dirs, invalid) <- liftIO $ partitionM D.doesDirectoryExist nonFiles
- withConfig YesReexec $ withDefaultEnvConfig $ do
- unless (null invalid) $ do
- let invalidList = bulletedList $ map (PP.style File . fromString) invalid
- prettyErrorL
- [ PP.style Shell "stack upload"
- , flow "expects a list of sdist tarballs or package directories."
- , flow "Can't find:"
- , line <> invalidList
- ]
- exitFailure
- when (null files && null dirs) $ do
- prettyErrorL
- [ PP.style Shell "stack upload"
- , flow "expects a list of sdist tarballs or package directories, but none were specified."
- ]
- exitFailure
- config <- view configL
- let hackageUrl = T.unpack $ configHackageBaseUrl config
- uploadVariant = uoptsUploadVariant uploadOpts
- getCreds <- memoizeRef $ Upload.loadAuth config
- mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files
- forM_ files $ \file -> do
- tarFile <- resolveFile' file
- creds <- runMemoized getCreds
- Upload.upload hackageUrl creds (toFilePath tarFile) uploadVariant
- forM_ dirs $ \dir -> do
- pkgDir <- resolveDir' dir
- (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir
- checkSDistTarball' sdistOpts tarName tarBytes
- creds <- runMemoized getCreds
- Upload.uploadBytes hackageUrl creds tarName uploadVariant tarBytes
- forM_ mcabalRevision $ uncurry $ Upload.uploadRevision hackageUrl creds
-
-sdistCmd :: SDistOpts -> RIO Runner ()
-sdistCmd sdistOpts =
- withConfig YesReexec $ withDefaultEnvConfig $ do
- -- If no directories are specified, build all sdist tarballs.
- dirs' <- if null (sdoptsDirsToWorkWith sdistOpts)
- then do
- dirs <- view $ buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)
- when (null dirs) $ do
- stackYaml <- view stackYamlL
- prettyErrorL
- [ PP.style Shell "stack sdist"
- , flow "expects a list of targets, and otherwise defaults to all of the project's packages."
- , flow "However, the configuration at"
- , pretty stackYaml
- , flow "contains no packages, so no sdist tarballs will be generated."
- ]
- exitFailure
- return dirs
- else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts)
- forM_ dirs' $ \dir -> do
- (tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir
- distDir <- distDirFromDir dir
- tarPath <- (distDir ) <$> parseRelFile tarName
- ensureDir (parent tarPath)
- runConduitRes $
- sourceLazy tarBytes .|
- sinkFileCautious (toFilePath tarPath)
- prettyInfoL [flow "Wrote sdist tarball to", pretty tarPath]
- checkSDistTarball sdistOpts tarPath
- forM_ (sdoptsTarPath sdistOpts) $ copyTarToTarPath tarPath tarName
- where
- copyTarToTarPath tarPath tarName targetDir = liftIO $ do
- let targetTarPath = targetDir FP. tarName
- D.createDirectoryIfMissing True $ FP.takeDirectory targetTarPath
- D.copyFile (toFilePath tarPath) targetTarPath
-
--- | Execute a command.
-execCmd :: ExecOpts -> RIO Runner ()
-execCmd ExecOpts {..} =
- withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
- unless (null targets) $ Stack.Build.build Nothing
-
- config <- view configL
- menv <- liftIO $ configProcessContextSettings config eoEnvSettings
- withProcessContext menv $ do
- -- Add RTS options to arguments
- let argsWithRts args = if null eoRtsOptions
- then args :: [String]
- else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"]
- (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of
- (ExecCmd cmd, args) -> return (cmd, args)
- (ExecRun, args) -> getRunCmd args
- (ExecGhc, args) -> getGhcCmd eoPackages args
- (ExecRunGhc, args) -> getRunGhcCmd eoPackages args
-
- runWithPath eoCwd $ exec cmd args
- where
- ExecOptsExtra {..} = eoExtra
-
- targets = concatMap words eoPackages
- boptsCLI = defaultBuildOptsCLI
- { boptsCLITargets = map T.pack targets
- }
-
- -- return the package-id of the first package in GHC_PACKAGE_PATH
- getPkgId name = do
- pkg <- getGhcPkgExe
- mId <- findGhcPkgField pkg [] name "id"
- case mId of
- Just i -> return (head $ words (T.unpack i))
- -- should never happen as we have already installed the packages
- _ -> do
- logError ("Could not find package id of package " <> fromString name)
- exitFailure
-
- getPkgOpts pkgs =
- map ("-package-id=" ++) <$> mapM getPkgId pkgs
-
- getRunCmd args = do
- packages <- view $ buildConfigL.to (smwProject . bcSMWanted)
- pkgComponents <- for (Map.elems packages) ppComponents
- let executables = filter isCExe $ concatMap Set.toList pkgComponents
- let (exe, args') = case args of
- [] -> (firstExe, args)
- x:xs -> case find (\y -> y == CExe (T.pack x)) executables of
- Nothing -> (firstExe, args)
- argExe -> (argExe, xs)
- where
- firstExe = listToMaybe executables
- case exe of
- Just (CExe exe') -> do
- withNewLocalBuildTargets [T.cons ':' exe'] $ Stack.Build.build Nothing
- return (T.unpack exe', args')
- _ -> do
- logError "No executables found."
- exitFailure
-
- getGhcCmd pkgs args = do
- pkgopts <- getPkgOpts pkgs
- compiler <- view $ compilerPathsL.to cpCompiler
- return (toFilePath compiler, pkgopts ++ args)
-
- getRunGhcCmd pkgs args = do
- pkgopts <- getPkgOpts pkgs
- interpret <- view $ compilerPathsL.to cpInterpreter
- return (toFilePath interpret, pkgopts ++ args)
-
- runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()
- runWithPath path callback = case path of
- Nothing -> callback
- Just p | not (isValid p) -> throwIO $ InvalidPathForExec p
- Just p -> withUnliftIO $ \ul -> D.withCurrentDirectory p $ unliftIO ul callback
-
--- | Evaluate some haskell code inline.
-evalCmd :: EvalOpts -> RIO Runner ()
-evalCmd EvalOpts {..} = execCmd execOpts
- where
- execOpts =
- ExecOpts { eoCmd = ExecGhc
- , eoArgs = ["-e", evalArg]
- , eoExtra = evalExtra
- }
-
--- | Run GHCi in the context of a project.
-ghciCmd :: GhciOpts -> RIO Runner ()
-ghciCmd ghciOpts =
- let boptsCLI = defaultBuildOptsCLI
- -- using only additional packages, targets then get overridden in `ghci`
- { boptsCLITargets = map T.pack (ghciAdditionalPackages ghciOpts)
- , boptsCLIInitialBuildSteps = True
- , boptsCLIFlags = ghciFlags ghciOpts
- , boptsCLIGhcOptions = map T.pack (ghciGhcOptions ghciOpts)
- }
- in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
- bopts <- view buildOptsL
- -- override env so running of tests and benchmarks is disabled
- let boptsLocal = bopts
- { boptsTestOpts = (boptsTestOpts bopts) { toDisableRun = True }
- , boptsBenchmarkOpts = (boptsBenchmarkOpts bopts) { beoDisableRun = True }
- }
- local (set buildOptsL boptsLocal)
- (ghci ghciOpts)
-
--- | List packages in the project.
-idePackagesCmd :: (IDE.OutputStream, IDE.ListPackagesCmd) -> RIO Runner ()
-idePackagesCmd = withConfig NoReexec . withBuildConfig . uncurry IDE.listPackages
-
--- | List targets in the project.
-ideTargetsCmd :: IDE.OutputStream -> RIO Runner ()
-ideTargetsCmd = withConfig NoReexec . withBuildConfig . IDE.listTargets
-
--- | Pull the current Docker image.
-dockerPullCmd :: () -> RIO Runner ()
-dockerPullCmd () = withConfig NoReexec $ Docker.preventInContainer Docker.pull
-
--- | Reset the Docker sandbox.
-dockerResetCmd :: Bool -> RIO Runner ()
-dockerResetCmd = withConfig NoReexec . Docker.preventInContainer . Docker.reset
-
--- | Project initialization
-initCmd :: InitOpts -> RIO Runner ()
-initCmd initOpts = do
- pwd <- getCurrentDir
- go <- view globalOptsL
- withGlobalProject $ withConfig YesReexec (initProject pwd initOpts (globalResolver go))
-
--- | Create a project directory structure and initialize the stack config.
-newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
-newCmd (newOpts, initOpts) =
- withGlobalProject $ withConfig YesReexec $ do
- dir <- new newOpts (forceOverwrite initOpts)
- exists <- doesFileExist $ dir stackDotYaml
- when (forceOverwrite initOpts || not exists) $ do
- go <- view globalOptsL
- initProject dir initOpts (globalResolver go)
-
--- | Display instructions for how to use templates
-templatesCmd :: () -> RIO Runner ()
-templatesCmd () = withConfig NoReexec templatesHelp
-
--- | Query build information
-queryCmd :: [String] -> RIO Runner ()
-queryCmd selectors = withConfig YesReexec $ withDefaultEnvConfig $ queryBuildInfo $ map T.pack selectors
-
--- | List packages
-listCmd :: [String] -> RIO Runner ()
-listCmd names = withConfig NoReexec $ do
- mresolver <- view $ globalOptsL.to globalResolver
- mSnapshot <- forM mresolver $ \resolver -> do
- concrete <- makeConcreteResolver resolver
- loc <- completeSnapshotLocation concrete
- loadSnapshot loc
- listPackages mSnapshot names
-
--- | generate a combined HPC report
-hpcReportCmd :: HpcReportOpts -> RIO Runner ()
-hpcReportCmd hropts = do
- let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs hropts)
- boptsCLI = defaultBuildOptsCLI
- { boptsCLITargets = if hroptsAll hropts then [] else targetNames }
- withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $
- generateHpcReportForTargets hropts tixFiles targetNames
-
-data MainException = InvalidReExecVersion String String
- | InvalidPathForExec FilePath
- deriving (Typeable)
-instance Exception MainException
-instance Show MainException where
- show (InvalidReExecVersion expected actual) = concat
- [ "When re-executing '"
- , stackProgName
- , "' in a container, the incorrect version was found\nExpected: "
- , expected
- , "; found: "
- , actual]
- show (InvalidPathForExec path) = concat
- [ "Got an invalid --cwd argument for stack exec ("
- , path
- , ")"]
+-- | Main Stack tool entry point.
+
+module Main (main) where
+
+import BuildInfo
+import Conduit ( runConduitRes, sourceLazy, sinkFileCautious )
+import Data.Attoparsec.Args ( EscapingMode (Escaping), parseArgs )
+import Data.Attoparsec.Interpreter ( getInterpreterArgs )
+import qualified Data.List as L
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import RIO.Process
+import GHC.IO.Encoding ( mkTextEncoding, textEncodingName )
+import Options.Applicative
+ ( Parser, ParserFailure, ParserHelp, ParserResult (..), flag
+ , handleParseResult, help, helpError, idm, long, metavar
+ , overFailure, renderFailure, strArgument, switch )
+import Options.Applicative.Help ( errorHelp, stringChunk, vcatChunks )
+import Options.Applicative.Builder.Extra
+ ( boolFlags, execExtraHelp, extraHelpOption, textOption )
+import Options.Applicative.Complicated
+ ( addCommand, addSubCommands, complicatedOptions )
+import Pantry ( loadSnapshot )
+import Path
+import Path.IO
+import Stack.Build
+import Stack.Build.Target ( NeedTargets (..) )
+import Stack.Clean ( CleanCommand (..), CleanOpts (..), clean )
+import Stack.Config
+import Stack.ConfigCmd as ConfigCmd
+import Stack.Constants
+import Stack.Constants.Config
+import Stack.Coverage
+import qualified Stack.Docker as Docker
+import Stack.Dot
+import Stack.GhcPkg ( findGhcPkgField )
+import qualified Stack.Nix as Nix
+import Stack.FileWatch
+import Stack.Ghci
+import Stack.Hoogle
+import Stack.List
+import Stack.Ls
+import qualified Stack.IDE as IDE
+import Stack.Init
+import Stack.New
+import Stack.Options.BuildParser
+import Stack.Options.CleanParser
+import Stack.Options.DockerParser
+import Stack.Options.DotParser
+import Stack.Options.ExecParser
+import Stack.Options.GhciParser
+import Stack.Options.GlobalParser
+import Stack.Options.HpcReportParser
+import Stack.Options.NewParser
+import Stack.Options.NixParser
+import Stack.Options.ScriptParser
+import Stack.Options.SDistParser
+import Stack.Options.UploadParser
+import Stack.Options.Utils
+import qualified Stack.Path
+import Stack.Prelude hiding (Display (..))
+import Stack.Runners
+import Stack.Script
+import Stack.SDist
+ ( SDistOpts (..), checkSDistTarball, checkSDistTarball'
+ , getSDistTarball
+ )
+import Stack.Setup ( withNewLocalBuildTargets )
+import Stack.SetupCmd
+import Stack.Types.Version
+ ( VersionCheck (..), checkVersion, showStackVersion
+ , stackVersion
+ )
+import Stack.Types.Config
+import Stack.Types.NamedComponent
+import Stack.Types.SourceMap
+import Stack.Unpack
+import Stack.Upgrade
+import qualified Stack.Upload as Upload
+import qualified System.Directory as D
+import System.Environment ( getArgs, getProgName, withArgs )
+import System.FilePath ( isValid, pathSeparator, takeDirectory )
+import qualified System.FilePath as FP
+import System.IO ( hGetEncoding, hPutStrLn, hSetEncoding )
+import System.Terminal ( hIsTerminalDeviceOrMinTTY )
+
+-- | Type representing exceptions thrown by functions in the "Main" module.
+data MainException
+ = InvalidReExecVersion String String
+ | InvalidPathForExec FilePath
+ deriving (Show, Typeable)
+
+instance Exception MainException where
+ displayException (InvalidReExecVersion expected actual) = concat
+ [ "Error: [S-2186]\n"
+ , "When re-executing '"
+ , stackProgName
+ , "' in a container, the incorrect version was found\nExpected: "
+ , expected
+ , "; found: "
+ , actual
+ ]
+ displayException (InvalidPathForExec path) = concat
+ [ "Error: [S-1541]\n"
+ , "Got an invalid '--cwd' argument for 'stack exec' ("
+ , path
+ , ")."
+ ]
+
+-- | Type representing \'pretty\' exceptions thrown by functions in the "Main"
+-- module.
+data MainPrettyException
+ = GHCProfOptionInvalid
+ | ResolverOptionInvalid
+ | PackageIdNotFoundBug !String
+ | ExecutableToRunNotFound
+ deriving (Show, Typeable)
+
+instance Pretty MainPrettyException where
+ pretty GHCProfOptionInvalid =
+ "[S-8100]"
+ <> line
+ <> flow "When building with Stack, you should not use GHC's '-prof' \
+ \option. Instead, please use Stack's '--library-profiling' and \
+ \'--executable-profiling' flags. See:" <+>
+ style Url "https://github.com/commercialhaskell/stack/issues/1015"
+ <> "."
+ pretty ResolverOptionInvalid =
+ "[S-8761]"
+ <> line
+ <> flow "The '--resolver' option cannot be used with Stack's 'upgrade' \
+ \command."
+ pretty (PackageIdNotFoundBug name) = bugPrettyReport "[S-8251]" $
+ "Could not find the package id of the package" <+>
+ style Target (fromString name)
+ <> "."
+ pretty ExecutableToRunNotFound =
+ "[S-2483]"
+ <> line
+ <> flow "No executables found."
+
+instance Exception MainPrettyException
+
+main :: IO ()
+main = 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 LineBuffering
+ hSetTranslit stdout
+ hSetTranslit stderr
+ args <- getArgs
+ progName <- getProgName
+ isTerminal <- hIsTerminalDeviceOrMinTTY stdout
+ -- On Windows, where applicable, defaultColorWhen has the side effect of
+ -- enabling ANSI for ANSI-capable native (ConHost) terminals, if not already
+ -- ANSI-enabled.
+ execExtraHelp args
+ Docker.dockerHelpOptName
+ (dockerOptsParser False)
+ ("Only showing --" ++ Docker.dockerCmdName ++ "* options.")
+ execExtraHelp args
+ Nix.nixHelpOptName
+ (nixOptsParser False)
+ ("Only showing --" ++ Nix.nixCmdName ++ "* options.")
+
+ currentDir <- D.getCurrentDirectory
+ eGlobalRun <- try $ commandLineHandler currentDir progName False
+ case eGlobalRun of
+ Left (exitCode :: ExitCode) ->
+ throwIO exitCode
+ Right (globalMonoid, run) -> do
+ global <- globalOptsFromMonoid isTerminal globalMonoid
+ when (globalLogLevel global == LevelDebug) $
+ hPutStrLn stderr versionString'
+ case globalReExecVersion global of
+ Just expectVersion -> do
+ expectVersion' <- parseVersionThrowing expectVersion
+ unless (checkVersion MatchMinor expectVersion' stackVersion) $
+ throwIO $
+ InvalidReExecVersion expectVersion showStackVersion
+ _ -> pure ()
+ withRunnerGlobal global $ run `catches`
+ [ Handler handleExitCode
+ , Handler handlePrettyException
+ , Handler handleSomeException
+ ]
+
+-- | 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'
+ _ -> pure ()
+
+-- | Handle ExitCode exceptions.
+handleExitCode :: ExitCode -> RIO Runner a
+handleExitCode = exitWith
+
+-- | Handle PrettyException exceptions.
+handlePrettyException :: PrettyException -> RIO Runner a
+handlePrettyException e = do
+ -- The code below loads the entire Stack configuration, when all that is
+ -- needed are the Stack colours. A tailored approach may be better.
+ result <- tryAny $ withConfig NoReexec $ prettyError $ pretty e
+ case result of
+ -- Falls back to the command line's Stack colours if there is any error in
+ -- loading the entire Stack configuration.
+ Left _ -> prettyError $ pretty e
+ Right _ -> pure ()
+ exitFailure
+
+-- | Handle SomeException exceptions. This special handler stops "stack: " from
+-- being printed before the exception.
+handleSomeException :: SomeException -> RIO Runner a
+handleSomeException (SomeException e) = do
+ logError $ fromString $ displayException e
+ exitFailure
+
+-- Vertically combine only the error component of the first argument with the
+-- error component of the second.
+vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp
+vcatErrorHelp h1 h2 = h2 { helpError = vcatChunks [helpError h2, helpError h1] }
+
+commandLineHandler ::
+ FilePath
+ -> String
+ -> Bool
+ -> IO (GlobalOptsMonoid, RIO Runner ())
+commandLineHandler currentDir progName isInterpreter =
+ complicatedOptions
+ stackVersion
+ (Just versionString')
+ hpackVersion
+ "stack - The Haskell Tool Stack"
+ ""
+ "Stack's documentation is available at https://docs.haskellstack.org/. \
+ \Command 'stack COMMAND --help' for help about a Stack command. Stack also \
+ \supports the Haskell Error Index at https://errors.haskell.org/."
+ (globalOpts OuterGlobalOpts)
+ (Just failureCallback)
+ addCommands
+ where
+ failureCallback f args =
+ case L.stripPrefix "Invalid argument" (fst (renderFailure f "")) of
+ Just _ -> if isInterpreter
+ then parseResultHandler args f
+ else secondaryCommandHandler args f
+ >>= interpreterHandler currentDir args
+ Nothing -> parseResultHandler args f
+
+ parseResultHandler args f =
+ if isInterpreter
+ then do
+ let hlp = errorHelp $ stringChunk
+ (unwords ["Error executing interpreter command:"
+ , progName
+ , unwords args])
+ handleParseResult (overFailure (vcatErrorHelp hlp) (Failure f))
+ else handleParseResult (Failure f)
+
+ addCommands = do
+ unless isInterpreter $ do
+ addBuildCommand'
+ "build"
+ "Build the package(s) in this directory/configuration"
+ buildCmd
+ (buildOptsParser Build)
+ addBuildCommand'
+ "install"
+ "Shortcut for 'build --copy-bins'"
+ buildCmd
+ (buildOptsParser Install)
+ addCommand'
+ "uninstall"
+ "Show how to uninstall Stack. This command does not itself uninstall \
+ \Stack."
+ uninstallCmd
+ (pure ())
+ addBuildCommand'
+ "test"
+ "Shortcut for 'build --test'"
+ buildCmd
+ (buildOptsParser Test)
+ addBuildCommand'
+ "bench"
+ "Shortcut for 'build --bench'"
+ buildCmd
+ (buildOptsParser Bench)
+ addBuildCommand'
+ "haddock"
+ "Shortcut for 'build --haddock'"
+ buildCmd
+ (buildOptsParser Haddock)
+ addCommand'
+ "new"
+ "Create a new project from a template. Run 'stack templates' to see \
+ \available templates. Will also initialise if there is no stack.yaml \
+ \file. Note: you can also specify a local file or a remote URL as a \
+ \template; or force an initialisation."
+ newCmd
+ newOptsParser
+ addCommand'
+ "templates"
+ "Show how to find templates available for 'stack new'. 'stack new' \
+ \can accept a template from a remote repository (default: github), \
+ \local file or remote URL. Note: this downloads the help file."
+ templatesCmd
+ (pure ())
+ addCommand'
+ "init"
+ "Create Stack project configuration from Cabal or Hpack package \
+ \specifications"
+ initCmd
+ initOptsParser
+ addCommand'
+ "setup"
+ "Get the appropriate GHC for your project"
+ setupCmd
+ setupParser
+ addCommand'
+ "path"
+ "Print out handy path information"
+ Stack.Path.path
+ Stack.Path.pathParser
+ addCommand'
+ "ls"
+ "List command. (Supports snapshots, dependencies, Stack's styles and \
+ \installed tools)"
+ lsCmd
+ lsParser
+ addCommand'
+ "unpack"
+ "Unpack one or more packages locally"
+ unpackCmd
+ ( (,)
+ <$> some (strArgument $ metavar "PACKAGE")
+ <*> optional (textOption
+ ( long "to"
+ <> help "Optional path to unpack the package into (will \
+ \unpack into subdirectory)"
+ ))
+ )
+ addCommand'
+ "update"
+ "Update the package index"
+ updateCmd
+ (pure ())
+ addCommand''
+ "upgrade"
+ "Upgrade Stack, installing to Stack's local-bin directory and, if \
+ \different and permitted, the directory of the current Stack \
+ \executable"
+ upgradeCmd
+ "Warning: if you use GHCup to install Stack, use only GHCup to \
+ \upgrade Stack."
+ upgradeOpts
+ addCommand'
+ "upload"
+ "Upload a package to Hackage"
+ uploadCmd
+ uploadOptsParser
+ addCommand'
+ "sdist"
+ "Create source distribution tarballs"
+ sdistCmd
+ sdistOptsParser
+ addCommand'
+ "dot"
+ "Visualize your project's dependency graph using Graphviz dot"
+ dot
+ (dotOptsParser False) -- Default for --external is False.
+ addCommand'
+ "ghc"
+ "Run ghc"
+ execCmd
+ (execOptsParser $ Just ExecGhc)
+ addCommand'
+ "hoogle"
+ "Run hoogle, the Haskell API search engine. Use the '-- ARGUMENT(S)' \
+ \syntax to pass Hoogle arguments, e.g. 'stack hoogle -- --count=20', \
+ \or 'stack hoogle -- server --local'."
+ hoogleCmd
+ ( (,,,)
+ <$> many (strArgument
+ ( metavar "-- ARGUMENT(S) (e.g. 'stack hoogle -- server --local')"
+ ))
+ <*> boolFlags
+ True
+ "setup"
+ "If needed: install hoogle, build haddocks and \
+ \generate a hoogle database"
+ idm
+ <*> switch
+ ( long "rebuild"
+ <> help "Rebuild the hoogle database"
+ )
+ <*> switch
+ ( long "server"
+ <> help "Start local Hoogle server"
+ )
+ )
+ -- These are the only commands allowed in interpreter mode as well
+ addCommand'
+ "exec"
+ "Execute a command. If the command is absent, the first of any \
+ \arguments is taken as the command."
+ execCmd
+ (execOptsParser Nothing)
+ addCommand'
+ "run"
+ "Build and run an executable. Defaults to the first available \
+ \executable if none is provided as the first argument."
+ execCmd
+ (execOptsParser $ Just ExecRun)
+ addGhciCommand'
+ "ghci"
+ "Run ghci in the context of package(s) (experimental)"
+ ghciCmd
+ ghciOptsParser
+ addGhciCommand'
+ "repl"
+ "Run ghci in the context of package(s) (experimental) (alias for \
+ \'ghci')"
+ ghciCmd
+ ghciOptsParser
+ addCommand'
+ "runghc"
+ "Run runghc"
+ execCmd
+ (execOptsParser $ Just ExecRunGhc)
+ addCommand'
+ "runhaskell"
+ "Run runghc (alias for 'runghc')"
+ execCmd
+ (execOptsParser $ Just ExecRunGhc)
+ addCommand
+ "script"
+ "Run a Stack Script"
+ globalFooter
+ scriptCmd
+ ( \so gom ->
+ gom
+ { globalMonoidResolverRoot =
+ First $ Just $ takeDirectory $ soFile so
+ }
+ )
+ (globalOpts OtherCmdGlobalOpts)
+ scriptOptsParser
+ unless isInterpreter $ do
+ addCommand'
+ "eval"
+ "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- \
+ \-e CODE'"
+ evalCmd
+ (evalOptsParser "CODE")
+ addCommand'
+ "clean"
+ "Delete build artefacts for the project packages."
+ cleanCmd
+ (cleanOptsParser Clean)
+ addCommand'
+ "purge"
+ "Delete the project Stack working directories (.stack-work by \
+ \default). Shortcut for 'stack clean --full'"
+ cleanCmd
+ (cleanOptsParser Purge)
+ addCommand'
+ "query"
+ "Query general build information (experimental)"
+ queryCmd
+ (many $ strArgument $ metavar "SELECTOR...")
+ addCommand'
+ "list"
+ "List package id's in snapshot (experimental)"
+ listCmd
+ (many $ strArgument $ metavar "PACKAGE")
+ addSubCommands'
+ "ide"
+ "IDE-specific commands"
+ ( let outputFlag = flag
+ IDE.OutputLogInfo
+ IDE.OutputStdout
+ ( long "stdout"
+ <> help "Send output to stdout instead of the default, stderr"
+ )
+ cabalFileFlag = flag
+ IDE.ListPackageNames
+ IDE.ListPackageCabalFiles
+ ( long "cabal-files"
+ <> help "Print paths to package cabal-files instead of \
+ \package names"
+ )
+ in do
+ addCommand'
+ "packages"
+ "List all available local loadable packages"
+ idePackagesCmd
+ ((,) <$> outputFlag <*> cabalFileFlag)
+ addCommand'
+ "targets"
+ "List all available Stack targets"
+ ideTargetsCmd
+ outputFlag
+ )
+ addSubCommands'
+ Docker.dockerCmdName
+ "Subcommands specific to Docker use"
+ ( do
+ addCommand'
+ Docker.dockerPullCmdName
+ "Pull latest version of Docker image from registry"
+ dockerPullCmd
+ (pure ())
+ addCommand'
+ "reset"
+ "Reset the Docker sandbox"
+ dockerResetCmd
+ ( switch
+ ( long "keep-home"
+ <> help "Do not delete sandbox's home directory"
+ )
+ )
+ )
+ addSubCommands'
+ ConfigCmd.cfgCmdName
+ "Subcommands for accessing and modifying configuration values"
+ ( do
+ addCommand'
+ ConfigCmd.cfgCmdSetName
+ "Sets a key in YAML configuration file to value"
+ (withConfig NoReexec . cfgCmdSet)
+ configCmdSetParser
+ addCommand'
+ ConfigCmd.cfgCmdEnvName
+ "Print environment variables for use in a shell"
+ (withConfig YesReexec . withDefaultEnvConfig . cfgCmdEnv)
+ configCmdEnvParser
+ )
+ addSubCommands'
+ "hpc"
+ "Subcommands specific to Haskell Program Coverage"
+ ( addCommand'
+ "report"
+ "Generate unified HPC coverage report from tix files and project \
+ \targets"
+ hpcReportCmd
+ hpcReportOptsParser
+ )
+ where
+ -- addCommand hiding global options
+ addCommand' ::
+ String
+ -> String
+ -> (a -> RIO Runner ())
+ -> Parser a
+ -> AddCommand
+ addCommand' cmd title constr =
+ addCommand
+ cmd
+ title
+ globalFooter
+ constr
+ (\_ gom -> gom)
+ (globalOpts OtherCmdGlobalOpts)
+ -- addCommand with custom footer hiding global options
+ addCommand'' ::
+ String
+ -> String
+ -> (a -> RIO Runner ())
+ -> String
+ -> Parser a
+ -> AddCommand
+ addCommand'' cmd title constr cmdFooter =
+ addCommand
+ cmd
+ title
+ (globalFooter <> " " <> cmdFooter)
+ constr
+ (\_ gom -> gom)
+ (globalOpts OtherCmdGlobalOpts)
+
+ addSubCommands' ::
+ String
+ -> String
+ -> AddCommand
+ -> AddCommand
+ addSubCommands' cmd title =
+ addSubCommands
+ cmd
+ title
+ globalFooter
+ (globalOpts OtherCmdGlobalOpts)
+
+ -- Additional helper that hides global options and shows build options
+ addBuildCommand' ::
+ String
+ -> String
+ -> (a -> RIO Runner ())
+ -> Parser a
+ -> AddCommand
+ addBuildCommand' cmd title constr =
+ addCommand
+ cmd
+ title
+ globalFooter
+ constr
+ (\_ gom -> gom)
+ (globalOpts BuildCmdGlobalOpts)
+
+ -- Additional helper that hides global options and shows some ghci options
+ addGhciCommand' ::
+ String
+ -> String
+ -> (a -> RIO Runner ())
+ -> Parser a
+ -> AddCommand
+ addGhciCommand' cmd title constr =
+ addCommand
+ cmd
+ title
+ globalFooter
+ constr
+ (\_ gom -> gom)
+ (globalOpts GhciCmdGlobalOpts)
+
+ globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid
+ globalOpts kind =
+ extraHelpOption
+ hide
+ progName
+ (Docker.dockerCmdName ++ "*")
+ Docker.dockerHelpOptName
+ <*> extraHelpOption
+ hide
+ progName
+ (Nix.nixCmdName ++ "*")
+ Nix.nixHelpOptName
+ <*> globalOptsParser
+ currentDir kind
+ ( if isInterpreter
+ -- Silent except when errors occur - see #2879
+ then Just LevelError
+ else Nothing
+ )
+ where
+ hide = kind /= OuterGlobalOpts
+
+-- | fall-through to external executables in `git` style if they exist
+-- (i.e. `stack something` looks for `stack-something` before
+-- failing with "Invalid argument `something'")
+secondaryCommandHandler ::
+ [String]
+ -> ParserFailure ParserHelp
+ -> IO (ParserFailure ParserHelp)
+secondaryCommandHandler args f =
+ -- don't even try when the argument looks like a path or flag
+ if elem pathSeparator cmd || "-" `L.isPrefixOf` L.head args
+ then pure f
+ else do
+ mExternalExec <- D.findExecutable cmd
+ case mExternalExec of
+ Just ex -> withProcessContextNoLogging $ do
+ -- TODO show the command in verbose mode
+ -- hPutStrLn stderr $ unwords $
+ -- ["Running", "[" ++ ex, unwords (tail args) ++ "]"]
+ _ <- exec ex (L.tail args)
+ pure f
+ Nothing -> pure $ fmap (vcatErrorHelp (noSuchCmd cmd)) f
+ where
+ -- FIXME this is broken when any options are specified before the command
+ -- e.g. stack --verbosity silent cmd
+ cmd = stackProgName ++ "-" ++ L.head args
+ noSuchCmd name = errorHelp $ stringChunk
+ ("Auxiliary command not found in path `" ++ name ++ "'")
+
+interpreterHandler ::
+ Monoid t
+ => FilePath
+ -> [String]
+ -> ParserFailure ParserHelp
+ -> IO (GlobalOptsMonoid, (RIO Runner (), t))
+interpreterHandler currentDir args f = do
+ -- args can include top-level config such as --extra-lib-dirs=... (set by
+ -- nix-shell) - we need to find the first argument which is a file, everything
+ -- afterwards is an argument to the script, everything before is an argument
+ -- to Stack
+ (stackArgs, fileArgs) <- spanM (fmap not . D.doesFileExist) args
+ case fileArgs of
+ (file:fileArgs') -> runInterpreterCommand file stackArgs fileArgs'
+ [] -> parseResultHandler (errorCombine (noSuchFile firstArg))
+ where
+ firstArg = L.head args
+
+ spanM _ [] = pure ([], [])
+ spanM p xs@(x:xs') = do
+ r <- p x
+ if r
+ then do
+ (ys, zs) <- spanM p xs'
+ pure (x:ys, zs)
+ else
+ pure ([], xs)
+
+ -- if the first argument contains a path separator then it might be a file,
+ -- or a Stack option referencing a file. In that case we only show the
+ -- interpreter error message and exclude the command related error messages.
+ errorCombine =
+ if pathSeparator `elem` firstArg
+ then overrideErrorHelp
+ else vcatErrorHelp
+
+ overrideErrorHelp h1 h2 = h2 { helpError = helpError h1 }
+
+ parseResultHandler fn = handleParseResult (overFailure fn (Failure f))
+ noSuchFile name = errorHelp $ stringChunk
+ ("File does not exist or is not a regular file `" ++ name ++ "'")
+
+ runInterpreterCommand path stackArgs fileArgs = do
+ progName <- getProgName
+ iargs <- getInterpreterArgs path
+ let parseCmdLine = commandLineHandler currentDir progName True
+ -- Implicit file arguments are put before other arguments that
+ -- occur after "--". See #3658
+ cmdArgs = stackArgs ++ case break (== "--") iargs of
+ (beforeSep, []) -> beforeSep ++ ["--"] ++ [path] ++ fileArgs
+ (beforeSep, optSep : afterSep) ->
+ beforeSep ++ [optSep] ++ [path] ++ fileArgs ++ afterSep
+ -- TODO show the command in verbose mode
+ -- hPutStrLn stderr $ unwords $
+ -- ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]
+ (a,b) <- withArgs cmdArgs parseCmdLine
+ pure (a,(b,mempty))
+
+setupCmd :: SetupCmdOpts -> RIO Runner ()
+setupCmd sco@SetupCmdOpts{..} = withConfig YesReexec $ do
+ installGHC <- view $ configL.to configInstallGHC
+ if installGHC
+ then
+ withBuildConfig $ do
+ (wantedCompiler, compilerCheck, mstack) <-
+ case scoCompilerVersion of
+ Just v -> pure (v, MatchMinor, Nothing)
+ Nothing -> (,,)
+ <$> view wantedCompilerVersionL
+ <*> view (configL.to configCompilerCheck)
+ <*> (Just <$> view stackYamlL)
+ setup sco wantedCompiler compilerCheck mstack
+ else
+ logWarn "The --no-install-ghc flag is inconsistent with 'stack setup'. \
+ \No action taken."
+
+cleanCmd :: CleanOpts -> RIO Runner ()
+cleanCmd = withConfig NoReexec . clean
+
+-- | Helper for build and install commands
+buildCmd :: BuildOptsCLI -> RIO Runner ()
+buildCmd opts = do
+ when (any (("-prof" `elem`) . fromRight [] . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do
+ throwIO $ PrettyException GHCProfOptionInvalid
+ local (over globalOptsL modifyGO) $
+ case boptsCLIFileWatch opts of
+ FileWatchPoll -> fileWatchPoll (inner . Just)
+ FileWatch -> fileWatch (inner . Just)
+ NoFileWatch -> inner Nothing
+ where
+ inner
+ :: Maybe (Set (Path Abs File) -> IO ())
+ -> RIO Runner ()
+ inner setLocalFiles = withConfig YesReexec $ withEnvConfig NeedTargets opts $
+ Stack.Build.build setLocalFiles
+ -- Read the build command from the CLI and enable it to run
+ modifyGO =
+ case boptsCLICommand opts of
+ Test -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True)
+ Haddock -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just True)
+ Bench -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True)
+ Install -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidInstallExesL) (Just True)
+ Build -> id -- Default case is just Build
+
+-- | Display help for the uninstall command.
+uninstallCmd :: () -> RIO Runner ()
+uninstallCmd () = withConfig NoReexec $ do
+ stackRoot <- view stackRootL
+ globalConfig <- view stackGlobalConfigL
+ programsDir <- view $ configL.to configLocalProgramsBase
+ localBinDir <- view $ configL.to configLocalBin
+ let toStyleDoc = style Dir . fromString . toFilePath
+ stackRoot' = toStyleDoc stackRoot
+ globalConfig' = toStyleDoc globalConfig
+ programsDir' = toStyleDoc programsDir
+ localBinDir' = toStyleDoc localBinDir
+ prettyInfo $ vsep
+ [ flow "To uninstall Stack, it should be sufficient to delete:"
+ , hang 4 $ fillSep [flow "(1) the directory containing Stack's tools",
+ "(" <> softbreak <> programsDir' <> softbreak <> ");"]
+ , hang 4 $ fillSep [flow "(2) the Stack root directory",
+ "(" <> softbreak <> stackRoot' <> softbreak <> ");"]
+ , hang 4 $ fillSep [flow "(3) if different, the directory containing ",
+ flow "Stack's global YAML configuration file",
+ "(" <> softbreak <> globalConfig' <> softbreak <> ");", "and"]
+ , hang 4 $ fillSep [flow "(4) the 'stack' executable file (see the output",
+ flow "of command", howToFindStack <> ",", flow "if Stack is on the PATH;",
+ flow "Stack is often installed in", localBinDir' <> softbreak <> ")."]
+ , fillSep [flow "You may also want to delete", style File ".stack-work",
+ flow "directories in any Haskell projects that you have built."]
+ ]
+ where
+ styleShell = style Shell
+ howToFindStack
+ | osIsWindows = styleShell "where.exe stack"
+ | otherwise = styleShell "which stack"
+
+-- | Unpack packages to the filesystem
+unpackCmd :: ([String], Maybe Text) -> RIO Runner ()
+unpackCmd (names, Nothing) = unpackCmd (names, Just ".")
+unpackCmd (names, Just dstPath) = withConfig NoReexec $ do
+ mresolver <- view $ globalOptsL.to globalResolver
+ mSnapshot <- forM mresolver $ \resolver -> do
+ concrete <- makeConcreteResolver resolver
+ loc <- completeSnapshotLocation concrete
+ loadSnapshot loc
+ dstPath' <- resolveDir' $ T.unpack dstPath
+ unpackPackages mSnapshot dstPath' names
+
+-- | Update the package index
+updateCmd :: () -> RIO Runner ()
+updateCmd () = withConfig NoReexec (void (updateHackageIndex Nothing))
+
+upgradeCmd :: UpgradeOpts -> RIO Runner ()
+upgradeCmd upgradeOpts' = do
+ go <- view globalOptsL
+ case globalResolver go of
+ Just _ -> throwIO $ PrettyException ResolverOptionInvalid
+ Nothing ->
+ withGlobalProject $
+ upgrade
+ maybeGitHash
+ upgradeOpts'
+
+-- | Upload to Hackage
+uploadCmd :: UploadOpts -> RIO Runner ()
+uploadCmd (UploadOpts (SDistOpts [] _ _ _ _) _) = do
+ prettyErrorL
+ [ flow "To upload the current package, please run"
+ , style Shell "stack upload ."
+ , flow "(with the period at the end)"
+ ]
+ liftIO exitFailure
+uploadCmd uploadOpts = do
+ let partitionM _ [] = pure ([], [])
+ partitionM f (x:xs) = do
+ r <- f x
+ (as, bs) <- partitionM f xs
+ pure $ if r then (x:as, bs) else (as, x:bs)
+ sdistOpts = uoptsSDistOpts uploadOpts
+ (files, nonFiles) <- liftIO $ partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)
+ (dirs, invalid) <- liftIO $ partitionM D.doesDirectoryExist nonFiles
+ withConfig YesReexec $ withDefaultEnvConfig $ do
+ unless (null invalid) $ do
+ let invalidList = bulletedList $ map (style File . fromString) invalid
+ prettyErrorL
+ [ style Shell "stack upload"
+ , flow "expects a list of sdist tarballs or package directories."
+ , flow "Can't find:"
+ , line <> invalidList
+ ]
+ exitFailure
+ when (null files && null dirs) $ do
+ prettyErrorL
+ [ style Shell "stack upload"
+ , flow "expects a list of sdist tarballs or package directories, but none were specified."
+ ]
+ exitFailure
+ config <- view configL
+ let hackageUrl = T.unpack $ configHackageBaseUrl config
+ uploadVariant = uoptsUploadVariant uploadOpts
+ getCreds <- memoizeRef $ Upload.loadAuth config
+ mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files
+ forM_ files $ \file -> do
+ tarFile <- resolveFile' file
+ creds <- runMemoized getCreds
+ Upload.upload hackageUrl creds (toFilePath tarFile) uploadVariant
+ forM_ dirs $ \dir -> do
+ pkgDir <- resolveDir' dir
+ (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir
+ checkSDistTarball' sdistOpts tarName tarBytes
+ creds <- runMemoized getCreds
+ Upload.uploadBytes hackageUrl creds tarName uploadVariant tarBytes
+ forM_ mcabalRevision $ uncurry $ Upload.uploadRevision hackageUrl creds
+
+sdistCmd :: SDistOpts -> RIO Runner ()
+sdistCmd sdistOpts =
+ withConfig YesReexec $ withDefaultEnvConfig $ do
+ -- If no directories are specified, build all sdist tarballs.
+ dirs' <- if null (sdoptsDirsToWorkWith sdistOpts)
+ then do
+ dirs <- view $ buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)
+ when (null dirs) $ do
+ stackYaml <- view stackYamlL
+ prettyErrorL
+ [ style Shell "stack sdist"
+ , flow "expects a list of targets, and otherwise defaults to all of the project's packages."
+ , flow "However, the configuration at"
+ , pretty stackYaml
+ , flow "contains no packages, so no sdist tarballs will be generated."
+ ]
+ exitFailure
+ pure dirs
+ else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts)
+ forM_ dirs' $ \dir -> do
+ (tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir
+ distDir <- distDirFromDir dir
+ tarPath <- (distDir ) <$> parseRelFile tarName
+ ensureDir (parent tarPath)
+ runConduitRes $
+ sourceLazy tarBytes .|
+ sinkFileCautious (toFilePath tarPath)
+ prettyInfoL [flow "Wrote sdist tarball to", pretty tarPath]
+ checkSDistTarball sdistOpts tarPath
+ forM_ (sdoptsTarPath sdistOpts) $ copyTarToTarPath tarPath tarName
+ where
+ copyTarToTarPath tarPath tarName targetDir = liftIO $ do
+ let targetTarPath = targetDir FP. tarName
+ D.createDirectoryIfMissing True $ FP.takeDirectory targetTarPath
+ D.copyFile (toFilePath tarPath) targetTarPath
+
+-- | Execute a command.
+execCmd :: ExecOpts -> RIO Runner ()
+execCmd ExecOpts {..} =
+ withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
+ unless (null targets) $ Stack.Build.build Nothing
+
+ config <- view configL
+ menv <- liftIO $ configProcessContextSettings config eoEnvSettings
+ withProcessContext menv $ do
+ -- Add RTS options to arguments
+ let argsWithRts args = if null eoRtsOptions
+ then args :: [String]
+ else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"]
+ (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of
+ (ExecCmd cmd, args) -> pure (cmd, args)
+ (ExecRun, args) -> getRunCmd args
+ (ExecGhc, args) -> getGhcCmd eoPackages args
+ (ExecRunGhc, args) -> getRunGhcCmd eoPackages args
+
+ runWithPath eoCwd $ exec cmd args
+ where
+ ExecOptsExtra {..} = eoExtra
+
+ targets = concatMap words eoPackages
+ boptsCLI = defaultBuildOptsCLI
+ { boptsCLITargets = map T.pack targets
+ }
+
+ -- return the package-id of the first package in GHC_PACKAGE_PATH
+ getPkgId name = do
+ pkg <- getGhcPkgExe
+ mId <- findGhcPkgField pkg [] name "id"
+ case mId of
+ Just i -> pure (L.head $ words (T.unpack i))
+ -- should never happen as we have already installed the packages
+ _ -> throwIO $ PrettyException (PackageIdNotFoundBug name)
+
+ getPkgOpts pkgs =
+ map ("-package-id=" ++) <$> mapM getPkgId pkgs
+
+ getRunCmd args = do
+ packages <- view $ buildConfigL.to (smwProject . bcSMWanted)
+ pkgComponents <- for (Map.elems packages) ppComponents
+ let executables = filter isCExe $ concatMap Set.toList pkgComponents
+ let (exe, args') = case args of
+ [] -> (firstExe, args)
+ x:xs -> case L.find (\y -> y == CExe (T.pack x)) executables of
+ Nothing -> (firstExe, args)
+ argExe -> (argExe, xs)
+ where
+ firstExe = listToMaybe executables
+ case exe of
+ Just (CExe exe') -> do
+ withNewLocalBuildTargets [T.cons ':' exe'] $ Stack.Build.build Nothing
+ pure (T.unpack exe', args')
+ _ -> throwIO $ PrettyException ExecutableToRunNotFound
+
+ getGhcCmd pkgs args = do
+ pkgopts <- getPkgOpts pkgs
+ compiler <- view $ compilerPathsL.to cpCompiler
+ pure (toFilePath compiler, pkgopts ++ args)
+
+ getRunGhcCmd pkgs args = do
+ pkgopts <- getPkgOpts pkgs
+ interpret <- view $ compilerPathsL.to cpInterpreter
+ pure (toFilePath interpret, pkgopts ++ args)
+
+ runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()
+ runWithPath path callback = case path of
+ Nothing -> callback
+ Just p | not (isValid p) -> throwIO $ InvalidPathForExec p
+ Just p -> withUnliftIO $ \ul -> D.withCurrentDirectory p $ unliftIO ul callback
+
+-- | Evaluate some haskell code inline.
+evalCmd :: EvalOpts -> RIO Runner ()
+evalCmd EvalOpts {..} = execCmd execOpts
+ where
+ execOpts =
+ ExecOpts { eoCmd = ExecGhc
+ , eoArgs = ["-e", evalArg]
+ , eoExtra = evalExtra
+ }
+
+-- | Run GHCi in the context of a project.
+ghciCmd :: GhciOpts -> RIO Runner ()
+ghciCmd ghciOpts =
+ let boptsCLI = defaultBuildOptsCLI
+ -- using only additional packages, targets then get overridden in `ghci`
+ { boptsCLITargets = map T.pack (ghciAdditionalPackages ghciOpts)
+ , boptsCLIInitialBuildSteps = True
+ , boptsCLIFlags = ghciFlags ghciOpts
+ , boptsCLIGhcOptions = map T.pack (ghciGhcOptions ghciOpts)
+ }
+ in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
+ bopts <- view buildOptsL
+ -- override env so running of tests and benchmarks is disabled
+ let boptsLocal = bopts
+ { boptsTestOpts = (boptsTestOpts bopts) { toDisableRun = True }
+ , boptsBenchmarkOpts = (boptsBenchmarkOpts bopts) { beoDisableRun = True }
+ }
+ local (set buildOptsL boptsLocal)
+ (ghci ghciOpts)
+
+-- | List packages in the project.
+idePackagesCmd :: (IDE.OutputStream, IDE.ListPackagesCmd) -> RIO Runner ()
+idePackagesCmd = withConfig NoReexec . withBuildConfig . uncurry IDE.listPackages
+
+-- | List targets in the project.
+ideTargetsCmd :: IDE.OutputStream -> RIO Runner ()
+ideTargetsCmd = withConfig NoReexec . withBuildConfig . IDE.listTargets
+
+-- | Pull the current Docker image.
+dockerPullCmd :: () -> RIO Runner ()
+dockerPullCmd () = withConfig NoReexec $ Docker.preventInContainer Docker.pull
+
+-- | Reset the Docker sandbox.
+dockerResetCmd :: Bool -> RIO Runner ()
+dockerResetCmd = withConfig NoReexec . Docker.preventInContainer . Docker.reset
+
+-- | Project initialization
+initCmd :: InitOpts -> RIO Runner ()
+initCmd initOpts = do
+ pwd <- getCurrentDir
+ go <- view globalOptsL
+ withGlobalProject $
+ withConfig YesReexec (initProject pwd initOpts (globalResolver go))
+
+-- | Create a project directory structure and initialize the Stack config.
+newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
+newCmd (newOpts, initOpts) =
+ withGlobalProject $ withConfig YesReexec $ do
+ dir <- new newOpts (forceOverwrite initOpts)
+ exists <- doesFileExist $ dir stackDotYaml
+ when (forceOverwrite initOpts || not exists) $ do
+ go <- view globalOptsL
+ initProject dir initOpts (globalResolver go)
+
+-- | Display instructions for how to use templates
+templatesCmd :: () -> RIO Runner ()
+templatesCmd () = withConfig NoReexec templatesHelp
+
+-- | Query build information
+queryCmd :: [String] -> RIO Runner ()
+queryCmd selectors = withConfig YesReexec $
+ withDefaultEnvConfig $ queryBuildInfo $ map T.pack selectors
+
+-- | List packages
+listCmd :: [String] -> RIO Runner ()
+listCmd names = withConfig NoReexec $ do
+ mresolver <- view $ globalOptsL.to globalResolver
+ mSnapshot <- forM mresolver $ \resolver -> do
+ concrete <- makeConcreteResolver resolver
+ loc <- completeSnapshotLocation concrete
+ loadSnapshot loc
+ listPackages mSnapshot names
+
+-- | generate a combined HPC report
+hpcReportCmd :: HpcReportOpts -> RIO Runner ()
+hpcReportCmd hropts = do
+ let (tixFiles, targetNames) = L.partition (".tix" `T.isSuffixOf`) (hroptsInputs hropts)
+ boptsCLI = defaultBuildOptsCLI
+ { boptsCLITargets = if hroptsAll hropts then [] else targetNames }
+ withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $
+ generateHpcReportForTargets hropts tixFiles targetNames
diff --git a/src/setup-shim/StackSetupShim.hs b/src/setup-shim/StackSetupShim.hs
--- a/src/setup-shim/StackSetupShim.hs
+++ b/src/setup-shim/StackSetupShim.hs
@@ -1,6 +1,12 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
module StackSetupShim where
import Main
+#if MIN_VERSION_Cabal(3,8,1)
import Distribution.PackageDescription (PackageDescription, emptyHookedBuildInfo)
+#else
+import "Cabal" Distribution.PackageDescription (PackageDescription, emptyHookedBuildInfo)
+#endif
import Distribution.Simple
import Distribution.Simple.Build
import Distribution.Simple.Setup (ReplFlags, fromFlag, replDistPref, replVerbosity)
@@ -13,9 +19,9 @@
if "repl" `elem` args && "stack-initial-build-steps" `elem` args
then do
defaultMainWithHooks simpleUserHooks
- { preRepl = \_ _ -> return emptyHookedBuildInfo
+ { preRepl = \_ _ -> pure emptyHookedBuildInfo
, replHook = stackReplHook
- , postRepl = \_ _ _ _ -> return ()
+ , postRepl = \_ _ _ _ -> pure ()
}
else main
diff --git a/src/test/Stack/ArgsSpec.hs b/src/test/Stack/ArgsSpec.hs
--- a/src/test/Stack/ArgsSpec.hs
+++ b/src/test/Stack/ArgsSpec.hs
@@ -4,14 +4,14 @@
module Stack.ArgsSpec where
-import Control.Monad
-import Data.Attoparsec.Args (EscapingMode(..), parseArgsFromString)
-import Data.Attoparsec.Interpreter (interpreterArgsParser)
+import Control.Monad
+import Data.Attoparsec.Args ( EscapingMode (..), parseArgsFromString )
+import Data.Attoparsec.Interpreter ( interpreterArgsParser )
import qualified Data.Attoparsec.Text as P
-import Data.Text (pack)
-import Stack.Prelude
-import Test.Hspec
-import Prelude (head)
+import Data.Text ( pack )
+import Stack.Prelude
+import Test.Hspec
+import Prelude ( head )
-- | Test spec.
spec :: Spec
@@ -120,7 +120,7 @@
<|> shebang <++> ["\n"]
-- invalid shebang
<|> blockSpace <++> [head (interpreterGenValid lineComment args)]
- -- something between shebang and stack comment
+ -- something between shebang and Stack comment
<|> shebang
<++> newLine
<++> blockSpace
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
@@ -9,4 +9,4 @@
main = hspec spec
spec :: Spec
-spec = return ()
+spec = pure ()
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
@@ -114,7 +114,7 @@
toAbsPath path = do
parentDir <- getCurrentDirectory >>= parseAbsDir
- return (parentDir path)
+ pure (parentDir path)
loadProject config inner = do
yamlAbs <- toAbsPath stackDotYaml
@@ -130,7 +130,7 @@
projectResolver `shouldBe` RSLSynonym (LTS 19 22)
it "throws if both 'resolver' and 'snapshot' are present" $ inTempDir $ do
- loadProject resolverSnapshotConfig (const (return ()))
+ loadProject resolverSnapshotConfig (const (pure ()))
`shouldThrow` anyException
describe "loadConfig" $ do
@@ -140,12 +140,12 @@
loadConfig inner
-- TODO(danburton): make sure parent dirs also don't have config file
it "works even if no config file exists" $ example $
- loadConfig' $ const $ return ()
+ loadConfig' $ const $ pure ()
it "works with a blank config file" $ inTempDir $ do
writeFile (toFilePath stackDotYaml) ""
-- TODO(danburton): more specific test for exception
- loadConfig' (const (return ())) `shouldThrow` anyException
+ loadConfig' (const (pure ())) `shouldThrow` anyException
let configOverrideHpack = pcHpackExecutable . view pantryConfigL
@@ -155,7 +155,7 @@
liftIO $ configOverrideHpack config `shouldBe`
HpackCommand "/usr/local/bin/hpack"
- it "parses config bundled hpack" $ inTempDir $ do
+ it "parses config bundled Hpack" $ inTempDir $ do
writeFile (toFilePath stackDotYaml) sampleConfig
loadConfig' $ \config ->
liftIO $ configOverrideHpack config `shouldBe` HpackBundled
@@ -174,14 +174,17 @@
boptsKeepTmpFiles `shouldBe` True
boptsForceDirty `shouldBe` True
boptsTests `shouldBe` True
- boptsTestOpts `shouldBe` TestOpts {toRerunTests = True
- ,toAdditionalArgs = ["-fprof"]
- ,toCoverage = True
- ,toDisableRun = True
- ,toMaximumTimeSeconds = Nothing}
+ boptsTestOpts `shouldBe` TestOpts { toRerunTests = True
+ , toAdditionalArgs = ["-fprof"]
+ , toCoverage = True
+ , toDisableRun = True
+ , toMaximumTimeSeconds = Nothing
+ , toAllowStdin = True
+ }
boptsBenchmarks `shouldBe` True
- boptsBenchmarkOpts `shouldBe` BenchmarkOpts {beoAdditionalArgs = Just "-O2"
- ,beoDisableRun = True}
+ boptsBenchmarkOpts `shouldBe` BenchmarkOpts { beoAdditionalArgs = Just "-O2"
+ , beoDisableRun = True
+ }
boptsReconfigure `shouldBe` True
boptsCabalVerbose `shouldBe` CabalVerbosity verbose
@@ -225,5 +228,5 @@
let parsed :: Either String (Either String (WithJSONWarnings ConfigMonoid))
parsed = parseEither (parseConfigMonoid curDir) <$> left show (decodeEither' defaultConfigYaml)
case parsed of
- Right (Right _) -> return () :: IO ()
+ Right (Right _) -> pure () :: IO ()
_ -> fail "Failed to parse default config yaml"
diff --git a/src/test/Stack/DotSpec.hs b/src/test/Stack/DotSpec.hs
--- a/src/test/Stack/DotSpec.hs
+++ b/src/test/Stack/DotSpec.hs
@@ -31,7 +31,7 @@
]
describe "Stack.Dot" $ do
it "does nothing if depth is 0" $
- resolveDependencies (Just 0) graph stubLoader `shouldBe` return graph
+ resolveDependencies (Just 0) graph stubLoader `shouldBe` pure graph
it "with depth 1, more dependencies are resolved" $ do
let graph' = Map.insert (pkgName "cycle")
@@ -79,7 +79,7 @@
-- Stub, simulates the function to load package dependencies
stubLoader :: PackageName -> Identity (Set PackageName, DotPayload)
-stubLoader name = return . (, dummyPayload) . Set.fromList . map pkgName $ case show name of
+stubLoader name = pure . (, dummyPayload) . Set.fromList . map pkgName $ case show name of
"StateVar" -> ["stm","transformers"]
"array" -> []
"bifunctors" -> ["semigroupoids","semigroups","tagged"]
diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs
--- a/src/test/Stack/GhciSpec.hs
+++ b/src/test/Stack/GhciSpec.hs
@@ -8,7 +8,7 @@
import Test.Hspec
spec :: Spec
-spec = return ()
+spec = pure ()
{- Commented out as part of the fix for https://github.com/commercialhaskell/stack/issues/3309
Not sure if maintaining this test is worth the effort.
diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs
--- a/src/test/Stack/LockSpec.hs
+++ b/src/test/Stack/LockSpec.hs
@@ -4,16 +4,16 @@
module Stack.LockSpec where
-import Pantry.Internal.AesonExtended (WithJSONWarnings(..))
+import Pantry.Internal.AesonExtended ( WithJSONWarnings (..) )
import qualified Data.Yaml as Yaml
-import Distribution.Types.PackageName (mkPackageName)
-import Distribution.Types.Version (mkVersion)
-import Pantry
+import Distribution.Types.PackageName ( mkPackageName )
+import Distribution.Types.Version ( mkVersion )
+import Pantry
import qualified Pantry.SHA256 as SHA256
-import RIO
-import Stack.Lock
-import Test.Hspec
-import Text.RawString.QQ
+import RIO
+import Stack.Lock
+import Test.Hspec
+import Text.RawString.QQ
toBlobKey :: ByteString -> Word -> BlobKey
toBlobKey string size = BlobKey (decodeSHA string) (FileSize size)
@@ -22,7 +22,7 @@
decodeSHA string =
case SHA256.fromHexBytes string of
Right csha -> csha
- Left err -> error $ "Failed decoding. Error: " <> show err
+ Left err -> error $ "Failed decoding. Error: " <> displayException err
decodeLocked :: ByteString -> IO Locked
decodeLocked bs = do
diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs
--- a/src/test/Stack/NixSpec.hs
+++ b/src/test/Stack/NixSpec.hs
@@ -102,5 +102,5 @@
it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ loadConfig' mempty $ \config -> do
nixPackages (configNix config) `shouldBe` ["glpk"]
v <- parseVersionThrowing "9.0.2"
- ghc <- either throwIO return $ nixCompiler (WCGhc v)
+ ghc <- either throwIO pure $ nixCompiler (WCGhc v)
ghc `shouldBe` "haskell.compiler.ghc902"
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
@@ -5,14 +5,14 @@
module Stack.PackageDumpSpec where
import Conduit
-import qualified Data.Conduit.List as CL
-import Data.Conduit.Text (decodeUtf8)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Distribution.License (License(..))
-import Distribution.Types.PackageName (mkPackageName)
-import Distribution.Version (mkVersion)
-import Path (parseAbsFile)
+import qualified Data.Conduit.List as CL
+import Data.Conduit.Text ( decodeUtf8 )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Distribution.License ( License (..) )
+import Distribution.Types.PackageName ( mkPackageName )
+import Distribution.Version ( mkVersion )
+import Path ( parseAbsFile )
import Stack.PackageDump
import Stack.Prelude
import Stack.Types.Config
@@ -72,7 +72,7 @@
.| conduitDumpPackage
.| CL.consume
ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"
- packageIdent <- maybe (fail "Not parsable package id") return $
+ packageIdent <- maybe (fail "Not parsable package id") pure $
parsePackageIdentifier "haskell2010-1.1.2.0"
depends <- mapM parseGhcPkgId
[ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"
@@ -103,7 +103,7 @@
.| conduitDumpPackage
.| CL.consume
ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"
- pkgIdent <- maybe (fail "Not parsable package id") return $
+ pkgIdent <- maybe (fail "Not parsable package id") pure $
parsePackageIdentifier "ghc-7.10.1"
depends <- mapM parseGhcPkgId
[ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9"
@@ -144,7 +144,7 @@
.| conduitDumpPackage
.| CL.consume
ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe"
- pkgId <- maybe (fail "Not parsable package id") return $
+ pkgId <- maybe (fail "Not parsable package id") pure $
parsePackageIdentifier "hmatrix-0.16.1.5"
depends <- mapM parseGhcPkgId
[ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"
@@ -183,7 +183,7 @@
.| conduitDumpPackage
.| CL.consume
ghcPkgId <- parseGhcPkgId "ghc-boot-0.0.0.0"
- pkgId <- maybe (fail "Not parsable package id") return $
+ pkgId <- maybe (fail "Not parsable package id") pure $
parsePackageIdentifier "ghc-boot-0.0.0.0"
depends <- mapM parseGhcPkgId
[ "base-4.9.0.0"
@@ -215,7 +215,7 @@
.| sinkMatching (Map.singleton (mkPackageName "transformers") (mkVersion [0, 0, 0, 0, 0, 0, 1]))
case Map.lookup (mkPackageName "base") m of
Nothing -> error "base not present"
- Just _ -> return ()
+ Just _ -> pure ()
liftIO $ do
Map.lookup (mkPackageName "transformers") m `shouldBe` Nothing
Map.lookup (mkPackageName "ghc") m `shouldBe` Nothing
diff --git a/src/test/Stack/Types/TemplateNameSpec.hs b/src/test/Stack/Types/TemplateNameSpec.hs
--- a/src/test/Stack/Types/TemplateNameSpec.hs
+++ b/src/test/Stack/Types/TemplateNameSpec.hs
@@ -37,7 +37,7 @@
let colonAction =
do
- return $! pathOf "with:colon"
+ pure $! pathOf "with:colon"
colonAction `shouldThrow` anyErrorCall
else do
@@ -48,4 +48,3 @@
pathOf "c:\\home\\file" `shouldBe` RelPath "c:\\home\\file.hsfiles" (Path "c:\\home\\file.hsfiles")
pathOf "with/slash" `shouldBe` RelPath "with/slash.hsfiles" (Path "with/slash.hsfiles")
pathOf "with:colon" `shouldBe` RelPath "with:colon.hsfiles" (Path "with:colon.hsfiles")
-
diff --git a/src/windows/System/Permissions.hs b/src/windows/System/Permissions.hs
--- a/src/windows/System/Permissions.hs
+++ b/src/windows/System/Permissions.hs
@@ -9,7 +9,7 @@
osIsWindows = True
setScriptPerms :: Monad m => FilePath -> m ()
-setScriptPerms _ = return ()
+setScriptPerms _ = pure ()
setFileExecutable :: Monad m => FilePath -> m ()
-setFileExecutable _ = return ()
+setFileExecutable _ = pure ()
diff --git a/src/windows/System/Terminal.hs b/src/windows/System/Terminal.hs
--- a/src/windows/System/Terminal.hs
+++ b/src/windows/System/Terminal.hs
@@ -54,21 +54,21 @@
(_, mbStdout, _, rStty) <- createProcess stty
exStty <- waitForProcess rStty
case exStty of
- ExitFailure _ -> return Nothing
+ ExitFailure _ -> pure Nothing
ExitSuccess ->
- maybe (return Nothing)
+ maybe (pure Nothing)
(\hSize -> do
sizeStr <- hGetContents hSize
case map read $ words sizeStr :: [Int] of
- [_r, c] -> return $ Just c
- _ -> return Nothing
+ [_r, c] -> pure $ Just c
+ _ -> pure Nothing
)
mbStdout
else do
[left,_top,right,_bottom] <- forM [0..3] $ \i -> do
v <- peekByteOff p ((i*2) + posCONSOLE_SCREEN_BUFFER_INFO_srWindow)
- return $ fromIntegral (v :: Word16)
- return $ Just (1+right-left)
+ pure $ fromIntegral (v :: Word16)
+ pure $ Just (1+right-left)
-- | Set the code page for this process as necessary. Only applies to Windows.
-- See: https://github.com/commercialhaskell/stack/issues/738
@@ -104,7 +104,7 @@
| otherwise = id
case (setInput, setOutput) of
- (False, False) -> return ()
+ (False, False) -> pure ()
(True, True) -> warn ""
(True, False) -> warn " input"
(False, True) -> warn " output"
@@ -122,5 +122,5 @@
hIsTerminalDeviceOrMinTTY h = do
isTD <- hIsTerminalDevice h
if isTD
- then return True
+ then pure True
else liftIO $ withHandleToHANDLE h isMinTTYHandle
diff --git a/stack-macos.yaml b/stack-macos.yaml
deleted file mode 100644
--- a/stack-macos.yaml
+++ /dev/null
@@ -1,43 +0,0 @@
-# This project-level configuration file is intended to be used with, and only
-# with, macOS. It specifies process-1.6.15.0 as a dependency, which includes
-# important bug fixes for macOS. When building test suite stack-test, Stack will
-# warn:
-#
-# This package indirectly depends on multiple versions of the same package.
-# This is very likely to cause a compile failure.
-#
-# but macOS, unlike other operating systems, appears able to avoid that failure.
-
-# GHC 9.2.4
-resolver: nightly-2022-09-05
-
-packages:
-- .
-
-extra-deps:
-# GHC 9.2.4 comes with process-1.6.13.2, which lacks important bug fixes
-- process-1.6.15.0@sha256:04df32d9497add5f0b90a27a3eceffa4bad5c2f41d038bd12ed6efc454db3faf,2845
-# Although Cabal-3.6.3.0 is a global package, it depends on process and so has
-# to be expressly added as an extra-dep
-- Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459
-
-drop-packages:
-# See https://github.com/commercialhaskell/stack/pull/4712
-- cabal-install
-
-docker:
- enable: false
- repo: psibi/alpine-haskell-stack:9.2.4
-
-nix:
- # --nix on the command-line to enable.
- packages:
- - zlib
- - unzip
-
-flags:
- stack:
- developer-mode: true
-
-ghc-options:
- "$locals": -fhide-source-paths
diff --git a/stack.cabal b/stack.cabal
--- a/stack.cabal
+++ b/stack.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.0
name: stack
-version: 2.9.1
+version: 2.9.3
license: BSD3
license-file: LICENSE
maintainer: manny@fpcomplete.com
@@ -29,33 +29,67 @@
ChangeLog.md
README.md
stack.yaml
- stack-macos.yaml
doc/azure_ci.md
doc/build_command.md
doc/build_overview.md
doc/ChangeLog.md
+ doc/CI.md
+ doc/clean_command.md
+ doc/config_command.md
doc/CONTRIBUTING.md
doc/coverage.md
doc/custom_snapshot.md
+ doc/debugging.md
doc/dependency_visualization.md
doc/developing_on_windows.md
+ doc/docker_command.md
doc/docker_integration.md
+ doc/dot_command.md
+ doc/editor_integration.md
+ doc/environment_variables.md
+ doc/eval_command.md
+ doc/exec_command.md
doc/faq.md
+ doc/ghc_command.md
doc/ghci.md
+ doc/global_flags.md
doc/glossary.md
doc/GUIDE.md
doc/GUIDE_advanced.md
+ doc/hoogle_command.md
+ doc/hpc_command.md
+ doc/ide_command.md
+ doc/init_command.md
doc/install_and_upgrade.md
+ doc/list_command.md
doc/lock_files.md
+ doc/ls_command.md
+ doc/new_command.md
doc/nix_integration.md
doc/nonstandard_project_init.md
+ doc/other_resources.md
doc/pantry.md
+ doc/path_command.md
+ doc/purge_command.md
+ doc/query_command.md
doc/README.md
+ doc/run_command.md
+ doc/runghc_command.md
+ doc/script_command.md
+ doc/scripts.md
+ doc/sdist_command.md
+ doc/setup_command.md
doc/shell_autocompletion.md
doc/SIGNING_KEY.md
doc/Stack_and_VS_Code.md
doc/stack_yaml_vs_cabal_package_file.md
+ doc/templates_command.md
doc/travis_ci.md
+ doc/uninstall_command.md
+ doc/unpack_command.md
+ doc/update_command.md
+ doc/upgrade_command.md
+ doc/upload_command.md
doc/yaml_configuration.md
src/setup-shim/StackSetupShim.hs
test/package-dump/ghc-7.10.txt
@@ -72,7 +106,7 @@
custom-setup
setup-depends:
Cabal,
- base >=4.16.3.0 && <5,
+ base >=4.14.3.0 && <5,
filepath
flag developer-mode
@@ -222,7 +256,12 @@
hs-source-dirs: src/
other-modules:
Path.Extended
+ Stack.ComponentFile
+ Stack.PackageFile
Stack.Types.Cache
+ Stack.Types.Dependency
+ Stack.Types.PackageFile
+ Stack.Types.Storage
autogen-modules: Paths_stack
default-language: Haskell2010
@@ -239,7 +278,7 @@
array,
async,
attoparsec,
- base >=4.16.3.0 && <5,
+ base >=4.14.3.0 && <5,
base64-bytestring,
bytestring,
casa-client,
@@ -258,7 +297,7 @@
file-embed,
filelock,
filepath,
- fsnotify,
+ fsnotify >=0.4.1,
generic-deriving,
hackage-security,
hashable,
@@ -280,7 +319,7 @@
network-uri,
open-browser,
optparse-applicative >=0.17.0.0,
- pantry >=0.5.6,
+ pantry >=0.8.1,
path,
path-io,
persistent >=2.13.3.5 && <2.14,
@@ -293,7 +332,7 @@
random,
retry,
rio >=0.1.22.0,
- rio-prettyprint >=0.1.1.0,
+ rio-prettyprint >=0.1.4.0,
semigroups,
split,
stm,
@@ -366,7 +405,7 @@
array,
async,
attoparsec,
- base >=4.16.3.0 && <5,
+ base >=4.14.3.0 && <5,
base64-bytestring,
bytestring,
casa-client,
@@ -385,7 +424,7 @@
file-embed,
filelock,
filepath,
- fsnotify,
+ fsnotify >=0.4.1,
generic-deriving,
hackage-security,
hashable,
@@ -407,7 +446,7 @@
network-uri,
open-browser,
optparse-applicative >=0.17.0.0,
- pantry >=0.5.6,
+ pantry >=0.8.1,
path,
path-io,
persistent >=2.13.3.5 && <2.14,
@@ -420,7 +459,7 @@
random,
retry,
rio >=0.1.22.0,
- rio-prettyprint >=0.1.1.0,
+ rio-prettyprint >=0.1.4.0,
semigroups,
split,
stack,
@@ -497,7 +536,7 @@
array,
async,
attoparsec,
- base >=4.16.3.0 && <5,
+ base >=4.14.3.0 && <5,
base64-bytestring,
bytestring,
casa-client,
@@ -516,7 +555,7 @@
file-embed,
filelock,
filepath,
- fsnotify,
+ fsnotify >=0.4.1,
generic-deriving,
hackage-security,
hashable,
@@ -540,7 +579,7 @@
open-browser,
optparse-applicative >=0.17.0.0,
optparse-generic,
- pantry >=0.5.6,
+ pantry >=0.8.1,
path,
path-io,
persistent >=2.13.3.5 && <2.14,
@@ -553,7 +592,7 @@
random,
retry,
rio >=0.1.22.0,
- rio-prettyprint >=0.1.1.0,
+ rio-prettyprint >=0.1.4.0,
semigroups,
split,
stm,
@@ -635,7 +674,7 @@
array,
async,
attoparsec,
- base >=4.16.3.0 && <5,
+ base >=4.14.3.0 && <5,
base64-bytestring,
bytestring,
casa-client,
@@ -654,7 +693,7 @@
file-embed,
filelock,
filepath,
- fsnotify,
+ fsnotify >=0.4.1,
generic-deriving,
hackage-security,
hashable,
@@ -677,7 +716,7 @@
network-uri,
open-browser,
optparse-applicative >=0.17.0.0,
- pantry >=0.5.6,
+ pantry >=0.8.1,
path,
path-io,
persistent >=2.13.3.5 && <2.14,
@@ -691,7 +730,7 @@
raw-strings-qq,
retry,
rio >=0.1.22.0,
- rio-prettyprint >=0.1.1.0,
+ rio-prettyprint >=0.1.4.0,
semigroups,
smallcheck,
split,
diff --git a/stack.yaml b/stack.yaml
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,16 +1,22 @@
-# GHC 9.2.4
-resolver: nightly-2022-09-05
+# GHC 9.2.5
+resolver: lts-20.0
packages:
- .
+extra-deps:
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
+- pantry-0.8.1@sha256:196111414d2489499fda6213deebcb865bc12285023d5af9bd273bf27cdb185d,4099
+- rio-prettyprint-0.1.4.0@sha256:1f8eb3ead0ef33d3736d53e1de5e9b2c91a0c207cdca23321bd74c401e85f23a,1301
+- fsnotify-0.4.1.0@sha256:44540beabea36aeeef930aa4d5f28091d431904bc9923b6ac4d358831c651235,2854
+
drop-packages:
# See https://github.com/commercialhaskell/stack/pull/4712
- cabal-install
docker:
enable: false
- repo: psibi/alpine-haskell-stack:9.2.4
+ repo: fpco/alpine-haskell-stack:9.2.5
nix:
# --nix on the command-line to enable.
@@ -24,11 +30,3 @@
ghc-options:
"$locals": -fhide-source-paths
-
-user-message: |
- If building Stack on macOS, you are advised to use stack-macos.yaml as the
- project-level configuration file, and command:
-
- stack --stack-yaml stack-macos.yaml build
-
- See that configuration file for further information.
diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs
--- a/test/integration/IntegrationSpec.hs
+++ b/test/integration/IntegrationSpec.hs
@@ -99,7 +99,7 @@
myPath <- liftIO getExecutablePath
stack <- canonicalizePath $ takeDirectory myPath "stack" ++ exeExt
- logInfo $ "Using stack located at " <> fromString stack
+ logInfo $ "Using Stack located at " <> fromString stack
proc stack ["--version"] runProcess_
logInfo $ "Using runghc located at " <> fromString runghc
proc runghc ["--version"] runProcess_
@@ -233,10 +233,10 @@
copyTree src dst =
liftIO $
runResourceT (sourceDirectoryDeep False src `connect` mapM_C go)
- `catch` \(_ :: IOException) -> return ()
+ `catch` \(_ :: IOException) -> pure ()
where
go srcfp = liftIO $ do
- Just suffix <- return $ stripPrefix src srcfp
+ Just suffix <- pure $ stripPrefix src srcfp
let dstfp = dst stripHeadSeparator suffix
createDirectoryIfMissing True $ takeDirectory dstfp
-- copying yaml files so lock files won't get created in
diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs
--- a/test/integration/lib/StackTest.hs
+++ b/test/integration/lib/StackTest.hs
@@ -26,22 +26,25 @@
run :: HasCallStack => FilePath -> [String] -> IO ()
run cmd args = do
ec <- run' cmd args
- unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec
+ unless (ec == ExitSuccess) $
+ error $ "Exited with exit code: " ++ displayException ec
runShell :: HasCallStack => String -> IO ()
runShell cmd = do
logInfo $ "Running: " ++ cmd
(Nothing, Nothing, Nothing, ph) <- createProcess (shell cmd)
ec <- waitForProcess ph
- unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec
+ unless (ec == ExitSuccess) $
+ error $ "Exited with exit code: " ++ displayException ec
runWithCwd :: HasCallStack => FilePath -> String -> [String] -> IO String
runWithCwd cwdPath cmd args = do
logInfo $ "Running: " ++ cmd
let cp = proc cmd args
(ec, stdoutStr, _) <- readCreateProcessWithExitCode (cp { cwd = Just cwdPath }) ""
- unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec
- return stdoutStr
+ unless (ec == ExitSuccess) $
+ error $ "Exited with exit code: " ++ displayException ec
+ pure stdoutStr
stackExe :: IO String
stackExe = getEnv "STACK_EXE"
@@ -60,7 +63,8 @@
stack :: HasCallStack => [String] -> IO ()
stack args = do
ec <- stack' args
- unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec
+ unless (ec == ExitSuccess) $
+ error $ "Exited with exit code: " ++ displayException ec
-- Temporary workaround for Windows to ignore exceptions arising out
-- of Windows when we do stack clean. More info here: https://github.com/commercialhaskell/stack/issues/4936
@@ -71,7 +75,7 @@
-- of Windows when we do stack clean. More info here: https://github.com/commercialhaskell/stack/issues/4936
stackIgnoreException :: HasCallStack => [String] -> IO ()
stackIgnoreException args = if isWindows
- then void (stack' args) `catch` (\(_e :: IOException) -> return ())
+ then void (stack' args) `catch` (\(_e :: IOException) -> pure ())
else stack args
stackErr :: HasCallStack => [String] -> IO ()
@@ -93,7 +97,7 @@
c <- liftIO $ hGetChar inputHandle
if c == '>'
then do _ <- liftIO $ hGetChar inputHandle
- return ()
+ pure ()
else nextPrompt
replCommand :: String -> Repl ()
@@ -122,7 +126,7 @@
tempDir <- if isWindows
then fromMaybe "" <$> lookupEnv "TEMP"
- else return "/tmp"
+ else pure "/tmp"
let tempFP = tempDir ++ "/stderr"
_ <- forkIO $ withFile tempFP WriteMode
@@ -138,7 +142,7 @@
repl args action = do
stackExe' <- stackExe
ec <- runRepl stackExe' ("repl":args) action
- unless (ec == ExitSuccess) $ return ()
+ unless (ec == ExitSuccess) $ pure ()
-- TODO: Understand why the exit code is 1 despite running GHCi tests
-- successfully.
-- else error $ "Exited with exit code: " ++ show ec
@@ -149,7 +153,7 @@
logInfo $ "Running: " ++ stackExe' ++ " " ++ unwords (map showProcessArgDebug args)
(ec, _, err) <- readProcessWithExitCode stackExe' args ""
hPutStr stderr err
- return (ec, err)
+ pure (ec, err)
-- | Run stack with arguments and apply a check to the resulting
-- stderr output if the process succeeded.
@@ -157,7 +161,7 @@
stackCheckStderr args check = do
(ec, err) <- stackStderr args
if ec /= ExitSuccess
- then error $ "Exited with exit code: " ++ show ec
+ then error $ "Exited with exit code: " ++ displayException ec
else check err
-- | Same as 'stackCheckStderr', but ensures that the Stack process
@@ -178,7 +182,7 @@
(ec, out, err) <- readProcessWithExitCode cmd args ""
putStr out
hPutStr stderr err
- return (ec, out, err)
+ pure (ec, out, err)
-- | Run stack with arguments and apply a check to the resulting
-- stdout output if the process succeeded.
@@ -190,7 +194,7 @@
stackExe' <- stackExe
(ec, out, _) <- runEx' stackExe' args
if ec /= ExitSuccess
- then error $ "Exited with exit code: " ++ show ec
+ then error $ "Exited with exit code: " ++ displayException ec
else check out
doesNotExist :: HasCallStack => FilePath -> IO ()
@@ -199,26 +203,26 @@
exists <- doesFileOrDirExist fp
case exists of
(Right msg) -> error msg
- (Left _) -> return ()
+ (Left _) -> pure ()
doesExist :: HasCallStack => FilePath -> IO ()
doesExist fp = do
logInfo $ "doesExist " ++ fp
exists <- doesFileOrDirExist fp
case exists of
- (Right _) -> return ()
+ (Right _) -> pure ()
(Left _) -> error "No file or directory exists"
doesFileOrDirExist :: HasCallStack => FilePath -> IO (Either () String)
doesFileOrDirExist fp = do
isFile <- doesFileExist fp
if isFile
- then return (Right ("File exists: " ++ fp))
+ then pure (Right ("File exists: " ++ fp))
else do
isDir <- doesDirectoryExist fp
if isDir
- then return (Right ("Directory exists: " ++ fp))
- else return (Left ())
+ then pure (Right ("Directory exists: " ++ fp))
+ else pure (Left ())
copy :: HasCallStack => FilePath -> FilePath -> IO ()
copy src dest = do
@@ -237,7 +241,7 @@
logInfo :: String -> IO ()
logInfo = hPutStrLn stderr
--- TODO: use stack's process running utilities? (better logging)
+-- TODO: use Stack's process running utilities? (better logging)
-- for now just copy+modifying this one from System.Process.Log
-- | Show a process arg including speechmarks when necessary. Just for
@@ -279,20 +283,20 @@
-- the main @stack.yaml@.
--
defaultResolverArg :: String
-defaultResolverArg = "--resolver=nightly-2022-09-05"
+defaultResolverArg = "--resolver=nightly-2022-11-14"
-- | Remove a file and ignore any warnings about missing files.
removeFileIgnore :: HasCallStack => FilePath -> IO ()
removeFileIgnore fp = removeFile fp `catch` \e ->
if isDoesNotExistError e
- then return ()
+ then pure ()
else throwIO e
-- | Remove a directory and ignore any warnings about missing files.
removeDirIgnore :: HasCallStack => FilePath -> IO ()
removeDirIgnore fp = removeDirectoryRecursive fp `catch` \e ->
if isDoesNotExistError e
- then return ()
+ then pure ()
else throwIO e
-- | Changes to the specified working directory.
|
