From 981fe749073825e372f453504b7c59eb4eb558c2 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sat, 19 Nov 2022 00:35:16 +0000 Subject: [PATCH] Add `RIO.PrettyPrint` to `Stack.Prelude` Also makes Error: S-6602 a pretty exception. Also refactors some import lists, in passing, with a longer term view to a more consistent approach. --- src/Data/Attoparsec/Args.hs | 7 +- src/Data/Attoparsec/Interpreter.hs | 4 +- src/Network/HTTP/StackClient.hs | 48 ++-- src/Options/Applicative/Args.hs | 12 +- src/Path/CheckInstall.hs | 3 +- src/Stack/Build/ConstructPlan.hs | 26 +-- src/Stack/Build/Execute.hs | 63 ++--- src/Stack/Build/Haddock.hs | 11 +- src/Stack/BuildPlan.hs | 6 +- src/Stack/ComponentFile.hs | 8 +- src/Stack/Config.hs | 17 +- src/Stack/ConfigCmd.hs | 4 +- src/Stack/Coverage.hs | 1 - src/Stack/Dot.hs | 1 - src/Stack/FileWatch.hs | 21 +- src/Stack/Ghci.hs | 6 +- src/Stack/Ghci/Script.hs | 2 +- src/Stack/Init.hs | 16 +- src/Stack/Ls.hs | 49 ++-- src/Stack/Options/DotParser.hs | 8 +- src/Stack/Package.hs | 6 +- src/Stack/PackageDump.hs | 4 +- src/Stack/PackageFile.hs | 1 - src/Stack/Path.hs | 7 +- src/Stack/Prelude.hs | 81 ++++++- src/Stack/SDist.hs | 1 - src/Stack/Setup.hs | 9 - src/Stack/Setup/Installed.hs | 9 +- src/Stack/Types/Build.hs | 16 +- src/Stack/Types/Config.hs | 361 +++++++++++++++-------------- src/Stack/Types/Docker.hs | 8 +- src/Stack/Types/PackageFile.hs | 3 +- src/Stack/Types/TemplateName.hs | 8 +- src/Stack/Upgrade.hs | 13 +- src/Stack/Upload.hs | 12 +- src/main/Main.hs | 20 +- 36 files changed, 465 insertions(+), 407 deletions(-) diff --git a/src/Data/Attoparsec/Args.hs b/src/Data/Attoparsec/Args.hs index cf12c431d8..3191909de5 100644 --- a/src/Data/Attoparsec/Args.hs +++ b/src/Data/Attoparsec/Args.hs @@ -36,10 +36,11 @@ argsParser mode = many (P.skipSpace *> (quoted <|> unquoted)) <* P.skipSpace <* (P.endOfInput "unterminated string") where unquoted = P.many1 naked - quoted = P.char '"' *> string <* P.char '"' - string = many (case mode of + quoted = P.char '"' *> str <* P.char '"' + str = many ( case mode of Escaping -> escaped <|> nonquote - NoEscaping -> nonquote) + NoEscaping -> nonquote + ) escaped = P.char '\\' *> P.anyChar nonquote = P.satisfy (/= '"') naked = P.satisfy (not . flip elem ("\" " :: String)) diff --git a/src/Data/Attoparsec/Interpreter.hs b/src/Data/Attoparsec/Interpreter.hs index 56a79b0a74..5a3b178ed5 100644 --- a/src/Data/Attoparsec/Interpreter.hs +++ b/src/Data/Attoparsec/Interpreter.hs @@ -145,9 +145,9 @@ getInterpreterArgs file = do decodeError e = case e of - ParseError ctxs _ (Position line col _) -> + ParseError ctxs _ (Position l col _) -> if null ctxs then "Parse error" else ("Expecting " ++ intercalate " or " ctxs) - ++ " at line " ++ show line ++ ", column " ++ show col + ++ " at line " ++ show l ++ ", column " ++ show col DivergentParser -> "Divergent parser" diff --git a/src/Network/HTTP/StackClient.hs b/src/Network/HTTP/StackClient.hs index 441dfd026c..9ea17e1337 100644 --- a/src/Network/HTTP/StackClient.hs +++ b/src/Network/HTTP/StackClient.hs @@ -58,30 +58,44 @@ module Network.HTTP.StackClient , setForceDownload ) where -import Control.Monad.State (get, put, modify) -import Data.Aeson (FromJSON) +import Control.Monad.State ( get, put, modify ) +import Data.Aeson ( FromJSON ) import qualified Data.ByteString as Strict -import Data.Conduit (ConduitM, ConduitT, awaitForever, (.|), yield, await) -import Data.Conduit.Lift (evalStateC) +import Data.Conduit + ( ConduitM, ConduitT, awaitForever, (.|), yield, await ) +import Data.Conduit.Lift ( evalStateC ) import qualified Data.Conduit.List as CL -import Data.Monoid (Sum (..)) +import Data.Monoid ( Sum (..) ) import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) -import Network.HTTP.Client (Request, RequestBody(..), Response, parseRequest, getUri, path, checkResponse, parseUrlThrow) -import Network.HTTP.Simple (setRequestCheckStatus, setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders) -import Network.HTTP.Types (hAccept, hContentLength, hContentMD5, methodPut) -import Network.HTTP.Conduit (requestHeaders) -import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException) -import Network.HTTP.Download hiding (download, redownload, verifiedDownload) +import Data.Time.Clock + ( NominalDiffTime, diffUTCTime, getCurrentTime ) +import Network.HTTP.Client + ( Request, RequestBody (..), Response, parseRequest, getUri + , path, checkResponse, parseUrlThrow + ) +import Network.HTTP.Simple + ( setRequestCheckStatus, setRequestMethod, setRequestBody + , setRequestHeader, addRequestHeader, HttpException (..) + , getResponseBody, getResponseStatusCode, getResponseHeaders + ) +import Network.HTTP.Types + ( hAccept, hContentLength, hContentMD5, methodPut ) +import Network.HTTP.Conduit ( requestHeaders ) +import Network.HTTP.Client.TLS + ( getGlobalManager, applyDigestAuth + , displayDigestAuthException + ) +import Network.HTTP.Download + hiding ( download, redownload, verifiedDownload ) import qualified Network.HTTP.Download as Download import qualified Network.HTTP.Simple -import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS) +import Network.HTTP.Client.MultipartFormData + ( formDataBody, partFileRequestBody, partBS, partLBS ) import Path -import Prelude (until, (!!)) +import Prelude ( until, (!!) ) import RIO -import RIO.PrettyPrint -import Text.Printf (printf) - +import RIO.PrettyPrint ( HasTerm ) +import Text.Printf ( printf ) setUserAgent :: Request -> Request setUserAgent = setRequestHeader "User-Agent" ["The Haskell Stack"] diff --git a/src/Options/Applicative/Args.hs b/src/Options/Applicative/Args.hs index 71e5d6f444..b98b04df19 100644 --- a/src/Options/Applicative/Args.hs +++ b/src/Options/Applicative/Args.hs @@ -17,22 +17,22 @@ import Stack.Prelude argsArgument :: O.Mod O.ArgumentFields [String] -> O.Parser [String] argsArgument = O.argument - (do string <- O.str - either O.readerError pure (parseArgsFromString Escaping string)) + (do s <- O.str + either O.readerError pure (parseArgsFromString Escaping s)) -- | An option which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@. argsOption :: O.Mod O.OptionFields [String] -> O.Parser [String] argsOption = O.option - (do string <- O.str - either O.readerError pure (parseArgsFromString Escaping string)) + (do s <- O.str + either O.readerError pure (parseArgsFromString Escaping s)) -- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@ cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String]) cmdOption = O.option - (do string <- O.str - xs <- either O.readerError pure (parseArgsFromString Escaping string) + (do s <- O.str + xs <- either O.readerError pure (parseArgsFromString Escaping s) case xs of [] -> O.readerError "Must provide a command" x:xs' -> pure (x, xs')) diff --git a/src/Path/CheckInstall.hs b/src/Path/CheckInstall.hs index 407924ba85..2a04bcbefa 100644 --- a/src/Path/CheckInstall.hs +++ b/src/Path/CheckInstall.hs @@ -4,10 +4,9 @@ module Path.CheckInstall where -import Control.Monad.Extra (anyM, (&&^)) +import Control.Monad.Extra ( anyM, (&&^) ) import qualified Data.Text as T import Stack.Prelude -import RIO.PrettyPrint import Stack.Types.Config import qualified System.Directory as D import qualified System.FilePath as FP diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 8b5e587db1..9d80135a77 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -13,20 +13,20 @@ module Stack.Build.ConstructPlan ( constructPlan ) where -import Stack.Prelude hiding (Display (..), loadPackage) -import Control.Monad.RWS.Strict hiding ((<>)) -import Control.Monad.State.Strict (execState) +import Control.Monad.RWS.Strict hiding ( (<>) ) +import Control.Monad.State.Strict ( execState ) import qualified Data.List as L import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map -import Data.Monoid.Map (MonoidMap(..)) +import Data.Monoid.Map ( MonoidMap(..) ) import qualified Data.Set as Set import qualified Data.Text as T -import Distribution.Types.BuildType (BuildType (Configure)) -import Distribution.Types.PackageName (mkPackageName) -import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Path (parent) +import Distribution.Types.BuildType ( BuildType (Configure) ) +import Distribution.Types.PackageName ( mkPackageName ) +import Generics.Deriving.Monoid ( memptydefault, mappenddefault ) +import Path ( parent ) import qualified RIO +import RIO.Process ( findExecutable, HasProcessContext (..) ) import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed @@ -34,20 +34,20 @@ import Stack.Build.Source import Stack.Constants import Stack.Package import Stack.PackageDump +import Stack.Prelude hiding ( Display (..), loadPackage ) import Stack.SourceMap import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config +import Stack.Types.Dependency + ( DepValue (DepValue), DepType (AsLibrary) ) import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.SourceMap import Stack.Types.Version -import System.Environment (lookupEnv) -import System.IO (putStrLn) -import RIO.PrettyPrint -import RIO.Process (findExecutable, HasProcessContext (..)) -import Stack.Types.Dependency (DepValue(DepValue), DepType (AsLibrary)) +import System.Environment ( lookupEnv ) +import System.IO ( putStrLn ) data PackageInfo = diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 8051ce2125..caf7947309 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -24,48 +24,51 @@ module Stack.Build.Execute ) where import Control.Concurrent.Execute -import Control.Concurrent.STM (check) -import Stack.Prelude hiding (Display (..)) +import Control.Concurrent.STM ( check ) import Crypto.Hash -import Data.Attoparsec.Text hiding (try) -import qualified Data.ByteArray as Mem (convert) +import Data.Attoparsec.Text as P hiding ( try ) +import qualified Data.ByteArray as Mem ( convert ) import qualified Data.ByteString as S import qualified Data.ByteString.Builder import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base64.URL as B64URL -import Data.Char (isSpace) +import Data.Char ( isSpace ) import Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Filesystem as CF import qualified Data.Conduit.List as CL -import Data.Conduit.Process.Typed (createSource) +import Data.Conduit.Process.Typed ( createSource ) import qualified Data.Conduit.Text as CT import qualified Data.List as L -import Data.List.NonEmpty (nonEmpty) -import qualified Data.List.NonEmpty as NonEmpty (toList) -import Data.List.Split (chunksOf) +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NonEmpty ( toList ) +import Data.List.Split ( chunksOf ) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) +import Data.Text.Encoding ( decodeUtf8 ) import Data.Tuple -import Data.Time (ZonedTime, getZonedTime, formatTime, defaultTimeLocale) +import Data.Time + ( ZonedTime, getZonedTime, formatTime, defaultTimeLocale ) import qualified Data.ByteString.Char8 as S8 import qualified Distribution.PackageDescription as C import qualified Distribution.Simple.Build.Macros as C -import Distribution.System (OS (Windows), - Platform (Platform)) +import Distribution.System ( OS (Windows), Platform (Platform) ) import qualified Distribution.Text as C -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.UnqualComponentName (mkUnqualComponentName) -import Distribution.Verbosity (showForCabal) -import Distribution.Version (mkVersion) +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.UnqualComponentName + ( mkUnqualComponentName ) +import Distribution.Verbosity ( showForCabal ) +import Distribution.Version ( mkVersion ) +import Pantry.Internal.Companion import Path import Path.CheckInstall -import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) -import Path.IO hiding (findExecutable, makeAbsolute, withSystemTempDir) +import Path.Extra ( toFilePathNoTrailingSep, rejectMissingFile ) +import Path.IO + hiding ( findExecutable, makeAbsolute, withSystemTempDir ) import qualified RIO +import RIO.Process import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed @@ -75,10 +78,11 @@ import Stack.Config import Stack.Constants import Stack.Constants.Config import Stack.Coverage -import Stack.DefaultColorWhen (defaultColorWhen) +import Stack.DefaultColorWhen ( defaultColorWhen ) import Stack.GhcPkg import Stack.Package import Stack.PackageDump +import Stack.Prelude hiding ( Display (..) ) import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config @@ -88,15 +92,16 @@ import Stack.Types.Package import Stack.Types.PackageFile import Stack.Types.Version import qualified System.Directory as D -import System.Environment (getExecutablePath, lookupEnv) -import System.FileLock (withTryFileLock, SharedExclusive (Exclusive), withFileLock) +import System.Environment ( getExecutablePath, lookupEnv ) +import System.FileLock + ( withTryFileLock, SharedExclusive (Exclusive) + , withFileLock + ) import qualified System.FilePath as FP -import System.IO.Error (isDoesNotExistError) -import System.PosixCompat.Files (createLink, modificationTime, getFileStatus) -import RIO.PrettyPrint -import RIO.Process -import Pantry.Internal.Companion -import System.Random (randomIO) +import System.IO.Error ( isDoesNotExistError ) +import System.PosixCompat.Files + ( createLink, modificationTime, getFileStatus ) +import System.Random ( randomIO ) -- | Has an executable been built or not? data ExecutableBuildStatus @@ -2193,7 +2198,7 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ lineCol = char ':' >> choice [ num >> char ':' >> num >> optional (char '-' >> num) >> pure () - , char '(' >> num >> char ',' >> num >> string ")-(" >> num >> char ',' >> num >> char ')' >> pure () + , char '(' >> num >> char ',' >> num >> P.string ")-(" >> num >> char ',' >> num >> char ')' >> pure () ] >> char ':' >> pure () diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 21f3320ed0..dae960c57b 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -16,26 +16,25 @@ module Stack.Build.Haddock , 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 diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 0d3e40f4bb..2cd9bae16e 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -421,13 +421,13 @@ selectBestSnapshot pkgDirs snaps = do reportResult r@BuildPlanCheckPartial {} loc = do logWarn $ "* Partially matches " <> RIO.display loc - logWarn $ RIO.display $ indent $ T.pack $ show r + logWarn $ RIO.display $ ind $ T.pack $ show r reportResult r@BuildPlanCheckFail {} loc = do logWarn $ "* Rejected " <> RIO.display loc - logWarn $ RIO.display $ indent $ T.pack $ show r + logWarn $ RIO.display $ ind $ T.pack $ show r - indent t = T.unlines $ fmap (" " <>) (T.lines t) + ind t = T.unlines $ fmap (" " <>) (T.lines t) showItems :: [String] -> Text showItems items = T.concat (map formatItem items) diff --git a/src/Stack/ComponentFile.hs b/src/Stack/ComponentFile.hs index 8d7436d2d9..24b3dbfa52 100644 --- a/src/Stack/ComponentFile.hs +++ b/src/Stack/ComponentFile.hs @@ -31,7 +31,9 @@ import Distribution.ModuleName ( ModuleName ) import qualified Distribution.ModuleName as Cabal import Distribution.Package hiding - ( Package, PackageIdentifier, packageName, packageVersion ) + ( Module, Package, PackageIdentifier, packageName + , packageVersion + ) import Distribution.PackageDescription hiding ( FlagName ) import Distribution.Text ( display ) import Distribution.Utils.Path ( getSymbolicPath ) @@ -40,8 +42,6 @@ import qualified HiFileParser as Iface import Path as FL hiding ( replaceExtension ) import Path.Extra import Path.IO hiding ( findFiles ) -import RIO.PrettyPrint -import qualified RIO.PrettyPrint as PP ( Style (Module) ) import Stack.Constants import Stack.Prelude hiding ( Display (..) ) import Stack.Types.Config @@ -395,7 +395,7 @@ 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) <> "," + , (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" diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 2c659ec271..e99d57aafa 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -59,15 +59,18 @@ 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.SourceMap import Stack.Storage.Project (initProjectStorage) import Stack.Storage.User (initUserStorage) -import Stack.SourceMap import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config @@ -81,13 +84,6 @@ 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) -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -869,7 +865,8 @@ loadConfigYaml loadConfigYaml parser path = do eres <- loadYaml parser path case eres of - Left err -> liftIO $ throwM (ParseConfigFileException path err) + Left err -> liftIO $ + throwM $ PrettyException (ParseConfigFileException path err) Right res -> pure res -- | Load and parse YAML from the given file. diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 1d936076a9..ab0210581d 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -166,7 +166,7 @@ cfgCmdSet cmd = do parsePlainKey :: Text -> Parser KeyType parsePlainKey key = do - _ <- string key + _ <- P.string key pure PlainKey parseSingleQuotedKey :: Text -> Parser KeyType @@ -178,7 +178,7 @@ cfgCmdSet cmd = do parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType parseQuotedKey kt c key = do skip (==c) - _ <- string key + _ <- P.string key skip (==c) pure kt diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 1728ca32dc..c179cb00b3 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -41,7 +41,6 @@ import Stack.Types.Package import Stack.Types.SourceMap import System.FilePath (isPathSeparator) import qualified RIO -import RIO.PrettyPrint import RIO.Process import Trace.Hpc.Tix import Web.Browser (openBrowser) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index e93c7f60e0..b67346dbd9 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -31,7 +31,6 @@ import qualified Distribution.SPDX.License as SPDX import Distribution.License (License(BSD3), licenseFromSPDX) 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) diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs index f7e45d272c..2ebd74479a 100644 --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -8,15 +8,14 @@ module Stack.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) @@ -86,9 +85,9 @@ fileWatchConf cfg inner = withRunInIO $ \run -> withManagerConf cfg $ \manager - 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" @@ -102,7 +101,7 @@ fileWatchConf cfg inner = withRunInIO $ \run -> withManagerConf cfg $ \manager - "" -> atomically $ writeTVar dirtyVar True _ -> logInfo $ "Unknown command: " <> - displayShow line <> + displayShow l <> ". Try 'help'" watchInput diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 67d431e8a1..6ac7c34c11 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -33,8 +33,10 @@ 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 RIO.Process + ( HasProcessContext, exec, proc, readProcess_ + , withWorkingDir + ) import Stack.Build import Stack.Build.Installed import Stack.Build.Source diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs index 8829eafbc2..6319c19c99 100644 --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -18,7 +18,7 @@ import Data.ByteString.Builder (toLazyByteString) import qualified Data.List as L import qualified Data.Set as S import Path -import Stack.Prelude +import Stack.Prelude hiding (Module) import System.IO (hSetBinaryMode) import Distribution.ModuleName hiding (toFilePath) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 9a706b642c..c5888f29c4 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -180,7 +180,7 @@ initProject currDir initOpts mresolver = do makeRel = fmap toFilePath . makeRelativeToCurrentDir - indent t = T.unlines $ fmap (" " <>) (T.lines t) + ind t = T.unlines $ fmap (" " <>) (T.lines t) logInfo $ "Initialising configuration using resolver: " <> display snapshotLoc logInfo $ "Total number of user packages considered: " @@ -191,14 +191,14 @@ initProject currDir initOpts mresolver = do <> displayShow (length dupPkgs) <> " duplicate packages:" rels <- mapM makeRel dupPkgs - logWarn $ display $ indent $ showItems rels + logWarn $ display $ ind $ showItems 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 + logWarn $ display $ ind $ showItems rels when (Map.size extraDeps > 0) $ do logWarn $ "Warning! " <> displayShow (Map.size extraDeps) @@ -437,7 +437,7 @@ getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do if length ignored > 1 then do logWarn "*** Ignoring packages:" - logWarn $ display $ indent $ showItems $ map packageNameString ignored + logWarn $ display $ ind $ showItems $ map packageNameString ignored else logWarn $ "*** Ignoring package: " <> fromString @@ -447,7 +447,7 @@ getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do go available where - indent t = T.unlines $ fmap (" " <>) (T.lines t) + ind t = T.unlines $ fmap (" " <>) (T.lines t) isAvailable k _ = k `notElem` ignored available = Map.filterWithKey isAvailable pkgDirs @@ -476,15 +476,15 @@ checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do | omitPackages initOpts -> do logWarn $ "*** Resolver compiler mismatch: " <> display snapshotLoc - logWarn $ display $ indent $ T.pack $ show result + logWarn $ display $ ind $ T.pack $ show result pure $ Left $ failedUserPkgs e | otherwise -> throwM $ 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)) diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index 70c817acfa..1cc77c8680 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -8,36 +8,37 @@ module Stack.Ls , lsParser ) where -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, globalFooter) -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. diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index d3e18a3d46..269eff07f3 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -3,11 +3,11 @@ module Stack.Options.DotParser 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 import Stack.Dot @@ -66,7 +66,7 @@ separatorParser = "and package version.") <> value " " <> showDefault)) - where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep) + where escapeSep s = T.replace "\\t" "\t" (T.replace "\\n" "\n" s) licenseParser :: Parser Bool licenseParser = boolFlags False diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index b2a77e69ca..92d2c9532e 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -63,9 +63,11 @@ import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.Version import System.FilePath (replaceExtension) -import RIO.PrettyPrint import Stack.Types.Dependency (DepValue(..), DepType (..)) -import Stack.Types.PackageFile (GetPackageFileContext(..), DotCabalPath, GetPackageFiles(..)) +import Stack.Types.PackageFile + ( GetPackageFileContext (..), DotCabalPath + , GetPackageFiles (..) + ) import Stack.PackageFile (packageDescModulesAndFiles) import Stack.ComponentFile -- | Read @.buildinfo@ ancillary files produced by some Setup.hs hooks. diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 0567e01e75..681ab1dbbd 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -296,11 +296,11 @@ eachPair inner = 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 diff --git a/src/Stack/PackageFile.hs b/src/Stack/PackageFile.hs index 1ea96f54a3..bed7cdceb1 100644 --- a/src/Stack/PackageFile.hs +++ b/src/Stack/PackageFile.hs @@ -18,7 +18,6 @@ import qualified Distribution.Types.UnqualComponentName as Cabal import Path as FL hiding ( replaceExtension ) import Path.Extra import Path.IO hiding ( findFiles ) -import RIO.PrettyPrint import Stack.ComponentFile import Stack.Prelude hiding ( Display (..) ) import Stack.Types.NamedComponent diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index 23f8a1fb90..83d105aa07 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -9,21 +9,20 @@ module Stack.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 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). diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index e0b4430368..5eb46bbf39 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -4,9 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Stack.Prelude - ( PrettyException (..) - , Pretty (..) - , withSystemTempDir + ( withSystemTempDir , withKeepSystemTempDir , sinkProcessStderrStdout , sinkProcessStdout @@ -29,16 +27,56 @@ module Stack.Prelude , bugPrettyReport , blankLine , module X + -- * Re-exports from the rio-pretty print package, and 'string' + , HasStylesUpdate (..) + , HasTerm (..) + , Pretty (..) + , PrettyException (..) + , StyleDoc + , Style (..) + , StyleSpec + , StylesUpdate (..) + , (<+>) + , align + , bulletedList + , debugBracket + , defaultStyles + , encloseSep + , fillSep + , flow + , hang + , hcat + , indent + , line + , logLevelToStyle + , parens + , parseStylesUpdateFromString + , prettyDebugL + , prettyError + , prettyErrorL + , prettyInfo + , prettyInfoL + , prettyInfoS + , prettyNote + , prettyWarn + , prettyWarnL + , prettyWarnS + , punctuate + , sep + , softbreak + , softline + , string + , style + , vsep ) where import Data.Monoid as X - ( First (..), Any (..), Sum (..), Endo (..) ) - + ( 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) + ( byteStringInput, createSource, withLoggedProcess_ ) import qualified Data.Text.IO as T import Pantry as X hiding ( Package (..), loadSnapshot ) import Path as X @@ -46,13 +84,26 @@ import Path as X import qualified Path.IO import RIO as X import RIO.File as X hiding ( writeBinaryFileAtomic ) -import RIO.PrettyPrint ( Pretty (..), StyleDoc, (<+>), flow, line ) +import RIO.PrettyPrint + ( HasStylesUpdate (..), HasTerm (..), Pretty (..) + , Style (..), StyleDoc, (<+>), align, bulletedList + , debugBracket, encloseSep, fillSep, flow, hang, hcat + , indent, line, logLevelToStyle, parens, prettyDebugL + , prettyError, prettyErrorL, prettyInfo, prettyInfoL + , prettyInfoS, prettyNote, prettyWarn, prettyWarnL + , prettyWarnS, punctuate, sep, softbreak, softline, 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 (..), ProcessContext, setStdin, closed - , getStderr, getStdout, proc, withProcessWait_, setStdout - , setStderr, ProcessConfig, readProcess_, workingDirL - , waitExitCode + ( 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 ) @@ -237,6 +288,14 @@ writeBinaryFileAtomic fp builder = liftIO $ withBinaryFileAtomic (toFilePath fp) WriteMode (`hPutBuilder` builder) +-- | @string@ is not exported by module "Text.PrettyPrint.Leijen.Extended" of +-- the @rio-prettyprint@ package. +string :: String -> StyleDoc +string "" = mempty +string ('\n':s) = line <> string s +string s = let (xs, ys) = span (/='\n') s + in fromString xs <> string ys + -- | Report a bug in Stack. bugReport :: String -> String -> String bugReport code msg = diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 5af9d86181..28c050f09c 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -50,7 +50,6 @@ import Path import Path.IO hiding ( getModificationTime, getPermissions, withSystemTempDir ) -import RIO.PrettyPrint import Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets ) import Stack.Build.Execute import Stack.Build.Installed diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index c046f963a0..15c9718465 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -69,7 +69,6 @@ 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) @@ -384,14 +383,6 @@ instance Pretty SetupPrettyException where <> flow "For more information consider rerunning with --verbose flag" <> line --- | @string@ is not exported by module "Text.PrettyPrint.Leijen.Extended" of --- the @rio-prettyprint@ package. -string :: String -> StyleDoc -string "" = mempty -string ('\n':s) = line <> string s -string s = let (xs, ys) = span (/='\n') s - in fromString xs <> string ys - instance Exception SetupPrettyException -- | Type representing exceptions thrown by 'performPathChecking' diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 4da6da5a32..0ecfdb4761 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -21,20 +21,21 @@ module Stack.Setup.Installed , tempInstallDir ) where -import Stack.Prelude import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL +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 @@ -125,7 +126,7 @@ getCompilerVersion wc exe = do 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 diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index ce596597d6..fb9c147ad5 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -60,7 +60,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Database.Persist.Sql ( PersistField (..), PersistFieldSql(..) - , PersistValue(PersistText), SqlType(SqlString) + , PersistValue (PersistText), SqlType (SqlString) ) import Distribution.PackageDescription ( TestSuiteInterface, mkPackageName ) @@ -69,10 +69,7 @@ import qualified Distribution.Text as C import qualified Distribution.Version as C import Path (parseRelDir, (), parent) import Path.Extra (toFilePathNoTrailingSep) -import RIO.PrettyPrint - ( Style (..), StyleDoc, (<+>), align, encloseSep, flow, hcat - , indent, line, parens, sep, softline, style, vsep - ) +import RIO.Process (showProcessArgDebug) import Stack.Constants import Stack.Prelude import Stack.Types.Compiler @@ -83,7 +80,6 @@ import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.Version import System.FilePath (pathSeparator) -import RIO.Process (showProcessArgDebug) -- | Type representing exceptions thrown by functions exported by modules with -- names beginning @Stack.Build@. @@ -408,14 +404,6 @@ instance Pretty BuildPrettyException where showBuildError "[S-6374]" True exitCode mtaskProvides execName fullArgs logFiles bss --- | @string@ is not exported by module "Text.PrettyPrint.Leijen.Extended" of --- the @rio-prettyprint@ package. -string :: String -> StyleDoc -string "" = mempty -string ('\n':s) = line <> string s -string s = let (xs, ys) = span (/='\n') s - in fromString xs <> string ys - instance Exception BuildPrettyException pprintExceptions diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 7baba04945..4378877a17 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -22,214 +22,211 @@ module Stack.Types.Config ( -- * 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(..) + , AllowNewerDeps(..) -- ** CabalConfigKey - ,CabalConfigKey(..) + , CabalConfigKey(..) -- ** ConfigException - ,HpackExecutable(..) - ,ConfigException(..) - ,ParseAbsolutePathException(..) - ,packageIndicesWarning + , 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 - ,stackGlobalConfigL - ,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 Control.Monad.Writer ( Writer, tell ) +import Control.Monad.Trans.Except ( ExceptT ) +import Crypto.Hash ( hashWith, SHA1 (..) ) import Stack.Prelude 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', 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, prettyDebugL, prettyWarnL ) -import RIO.PrettyPrint.StylesUpdate - ( HasStylesUpdate (..), StylesUpdate - , parseStylesUpdateFromString - ) import Stack.Constants import Stack.Types.Compiler import Stack.Types.CompilerBuild @@ -242,9 +239,9 @@ import Stack.Types.SourceMap import Stack.Types.TemplateName import Stack.Types.Version 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 @@ -252,8 +249,7 @@ import Stack.Types.Config.Build as X -- | Type representing exceptions thrown by functions exported by the -- "Stack.Config" module. data ConfigException - = ParseConfigFileException (Path Abs File) ParseException - | ParseCustomSnapshotException Text ParseException + = ParseCustomSnapshotException Text ParseException | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File] | UnableToExtractArchive Text (Path Abs File) @@ -276,14 +272,6 @@ data ConfigException deriving Typeable instance Show ConfigException where - show (ParseConfigFileException configFile exception) = concat - [ "Error: [S-6602]\n" - , "Could not parse '" - , toFilePath configFile - , "':\n" - , Yaml.prettyPrintParseException exception - , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/" - ] show (ParseCustomSnapshotException url exception) = concat [ "Error: [S-8981]\n" , "Could not parse '" @@ -434,6 +422,37 @@ instance Show ConfigException where instance Exception ConfigException +-- | Type representing 'pretty' exceptions thrown by functions exported by the +-- "Stack.Config" module. +data ConfigPrettyException + = ParseConfigFileException (Path Abs File) ParseException + deriving (Typeable) + +instance Show ConfigPrettyException where + show (ParseConfigFileException {}) = "ParseConfigFileException" + +instance Pretty ConfigPrettyException where + pretty (ParseConfigFileException configFile exception) = + "[S-6602]" + <> line + <> 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 \ + \exception:" + <> blankLine + <> string (Yaml.prettyPrintParseException exception) + <> blankLine + <> 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/" + <> "." + +instance Exception ConfigPrettyException + data ParseAbsolutePathException = ParseAbsolutePathException String String deriving Typeable diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index 2c142164e4..88a2517d34 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -85,16 +85,16 @@ instance Show DockerException where , unwords [stackProgName, dockerCmdName, dockerPullCmdName] , "' to download it, then try again." ] - show (InvalidImagesOutputException line) = concat + show (InvalidImagesOutputException l) = concat [ "Error: [S-5841]\n" , "Invalid 'docker images' output line: '" - , line + , l , "'." ] - show (InvalidPSOutputException line) = concat + show (InvalidPSOutputException l) = concat [ "Error: [S-9608]\n" , "Invalid 'docker ps' output line: '" - , line + , l ,"'." ] show (InvalidInspectOutputException msg) = concat diff --git a/src/Stack/Types/PackageFile.hs b/src/Stack/Types/PackageFile.hs index 35ac66a9c6..d3440ca310 100644 --- a/src/Stack/Types/PackageFile.hs +++ b/src/Stack/Types/PackageFile.hs @@ -17,7 +17,6 @@ module Stack.Types.PackageFile ) where import Distribution.ModuleName ( ModuleName ) -import RIO.PrettyPrint ( HasStylesUpdate (..), HasTerm (..) ) import RIO.Process ( HasProcessContext (processContextL) ) import Stack.Prelude import Stack.Types.Config @@ -99,4 +98,4 @@ data PackageWarning {- | MissingModulesWarning (Path Abs File) (Maybe String) [ModuleName] -- ^ Modules not found in file system, which are listed in Cabal file - -} \ No newline at end of file + -} diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index 9c0562b139..adca7fddc8 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -75,16 +75,16 @@ templateNameArgument :: O.Mod O.ArgumentFields TemplateName -> O.Parser TemplateName templateNameArgument = O.argument - (do string <- O.str - either O.readerError pure (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 pure (parsePair string)) + (do s <- O.str + either O.readerError pure (parsePair s)) where parsePair :: String -> Either String (Text, Text) parsePair s = diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 1f2afc5fb7..6234920f04 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -10,22 +10,21 @@ module Stack.Upgrade , upgradeOpts ) where -import Stack.Prelude hiding (force, Display (..)) import qualified Data.Text as T -import Distribution.Version (mkVersion') +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. diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index 0b910e329e..71244b14eb 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -21,7 +21,6 @@ module Stack.Upload , maybeGetHackageKey ) where -import Stack.Prelude import Conduit ( mapOutput, sinkList ) import Data.Aeson ( FromJSON (..), ToJSON (..), decode', toEncoding @@ -39,9 +38,8 @@ import Network.HTTP.StackClient , parseRequest, formDataBody, partFileRequestBody, partBS , partLBS, applyDigestAuth, displayDigestAuthException ) -import RIO.PrettyPrint - ( Style (..), StyleDoc, (<+>), flow, line, style, vsep ) import Stack.Options.UploadParser +import Stack.Prelude import Stack.Types.Config import System.Directory ( createDirectoryIfMissing, removeFile, renameFile ) @@ -72,14 +70,6 @@ instance Pretty UploadPrettyException where <> line <> vsep (map string res) --- | @string@ is not exported by module "Text.PrettyPrint.Leijen.Extended" of --- the @rio-prettyprint@ package. -string :: String -> StyleDoc -string "" = mempty -string ('\n':s) = line <> string s -string s = let (xs, ys) = span (/='\n') s - in fromString xs <> string ys - instance Exception UploadPrettyException newtype HackageKey = HackageKey Text diff --git a/src/main/Main.hs b/src/main/Main.hs index 5f3a444e55..6c310089bb 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -11,7 +11,6 @@ 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) @@ -36,8 +35,6 @@ 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) @@ -74,6 +71,7 @@ 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 (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..)) @@ -687,7 +685,7 @@ uninstallCmd () = withConfig NoReexec $ do globalConfig <- view stackGlobalConfigL programsDir <- view $ configL.to configLocalProgramsBase localBinDir <- view $ configL.to configLocalBin - let toStyleDoc = PP.style Dir . fromString . toFilePath + let toStyleDoc = style Dir . fromString . toFilePath stackRoot' = toStyleDoc stackRoot globalConfig' = toStyleDoc globalConfig programsDir' = toStyleDoc programsDir @@ -704,11 +702,11 @@ uninstallCmd () = withConfig NoReexec $ do , 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", PP.style File ".stack-work", + , fillSep [flow "You may also want to delete", style File ".stack-work", flow "directories in any Haskell projects that you have built."] ] where - styleShell = PP.style Shell + styleShell = style Shell howToFindStack | osIsWindows = styleShell "where.exe stack" | otherwise = styleShell "which stack" @@ -745,7 +743,7 @@ uploadCmd :: UploadOpts -> RIO Runner () uploadCmd (UploadOpts (SDistOpts [] _ _ _ _) _) = do prettyErrorL [ flow "To upload the current package, please run" - , PP.style Shell "stack upload ." + , style Shell "stack upload ." , flow "(with the period at the end)" ] liftIO exitFailure @@ -760,9 +758,9 @@ uploadCmd uploadOpts = do (dirs, invalid) <- liftIO $ partitionM D.doesDirectoryExist nonFiles withConfig YesReexec $ withDefaultEnvConfig $ do unless (null invalid) $ do - let invalidList = bulletedList $ map (PP.style File . fromString) invalid + let invalidList = bulletedList $ map (style File . fromString) invalid prettyErrorL - [ PP.style Shell "stack upload" + [ style Shell "stack upload" , flow "expects a list of sdist tarballs or package directories." , flow "Can't find:" , line <> invalidList @@ -770,7 +768,7 @@ uploadCmd uploadOpts = do exitFailure when (null files && null dirs) $ do prettyErrorL - [ PP.style Shell "stack upload" + [ style Shell "stack upload" , flow "expects a list of sdist tarballs or package directories, but none were specified." ] exitFailure @@ -801,7 +799,7 @@ sdistCmd sdistOpts = when (null dirs) $ do stackYaml <- view stackYamlL prettyErrorL - [ PP.style Shell "stack sdist" + [ 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