pantry 0.8.1 → 0.8.2

raw patch · 10 files changed

+1472/−193 lines, 10 filesdep +Win32dep +optparse-applicativedep +processnew-component:exe:test-pretty-exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: Win32, optparse-applicative, process

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• app/test-pretty-exceptions/Main.hs +415/−0
• app/test-pretty-exceptions/unix/PathAbsExamples.hs +24/−0
• app/test-pretty-exceptions/unix/System/Terminal.hsc +46/−0
• app/test-pretty-exceptions/windows/PathAbsExamples.hs +24/−0
• app/test-pretty-exceptions/windows/System/Terminal.hs +81/−0
• pantry.cabal +265/−185
• src/Pantry.hs +13/−3
• src/Pantry/HPack.hs +11/−5
• src/Pantry/Types.hs +585/−0

@@ -1,5 +1,13 @@ # Changelog for pantry
 
+## v0.8.2
+
+* `PantryException` is now an instance of the
+  `Text.PrettyPrint.Leijen.Extended.Pretty` class (provided by the
+  `rio-prettyprint` package).
+* Module `Pantry` now exports `FuzzyResults`, `Mismatch` and `SafeFilePath` (and
+  `mkSafeFilePath`), used in data constructors of `PantryException`.
+
 ## v0.8.1
 
 * Support `hpack-0.35.1`, and prettier `HpackLibraryException` error messages.

@@ -0,0 +1,415 @@+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
+
+-- | An executable to allow a person to inspect in a terminal the form of
+-- Pantry's pretty exceptions.
+module Main
+ ( main
+ ) where
+
+import qualified Data.Conduit.Tar as Tar
+import           Data.Maybe ( fromJust )
+import qualified Data.Text as T
+import qualified Distribution.Parsec.Error as C
+import qualified Distribution.Parsec.Position as C
+import qualified Distribution.Parsec.Warning as C
+import qualified Distribution.Types.PackageName as C
+import qualified Distribution.Types.Version as C
+import           Options.Applicative
+                   ( Parser, (<**>), auto, execParser, fullDesc, header, help
+                   , helper, info, long, metavar, option, progDesc, showDefault
+                   , strOption, value
+                   )
+import           Network.HTTP.Types.Status ( Status, mkStatus )
+import           Pantry
+                   ( ArchiveLocation (..), BlobKey (..), CabalFileInfo (..)
+                   , FileSize (..), FuzzyResults (..), Mismatch (..)
+                   , PackageName, PantryException (..), PackageIdentifier (..)
+                   , PackageIdentifierRevision (..), PackageMetadata (..)
+                   , RawPackageLocationImmutable (..), RawPackageMetadata (..)
+                   , RawSnapshotLocation (..), RelFilePath (..), Repo (..)
+                   , RepoType (..), ResolvedPath (..), Revision (..), SHA256
+                   , SafeFilePath, SimpleRepo (..), SnapName (..)
+                   , TreeKey (..), Version, WantedCompiler (..), mkSafeFilePath
+                   )
+import           Pantry.SHA256 ( hashBytes )
+import           Path ( File )
+import           PathAbsExamples
+                   ( pathAbsDirExample, pathAbsFileExample
+                   , pathAbsFileExamples
+                   )
+import           RIO
+import qualified RIO.List as L
+import           RIO.NonEmpty ( nonEmpty )
+import           RIO.PrettyPrint ( pretty, prettyError )
+import           RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp )
+import           RIO.PrettyPrint.StylesUpdate
+                   ( StylesUpdate, parseStylesUpdateFromString )
+import           RIO.Time ( fromGregorian )
+import           System.Terminal ( hIsTerminalDeviceOrMinTTY, getTerminalWidth )
+
+-- | Type representing options that can be specified at the command line
+data Options = Options
+  { colours :: String
+  , theme :: Theme
+  }
+
+-- | Type representing styles identified by a theme name
+data Theme
+  = Default
+  | SolarizedDark
+  deriving (Bounded, Enum, Read, Show)
+
+options :: Parser Options
+options = Options
+  <$> strOption
+        (  long "colours"
+        <> metavar "STYLES"
+        <> help "Specify the 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). In shells \
+                \where a semicolon is a command separator, enclose STYLES in \
+                \quotes."
+        <> value ""
+        )
+  <*> option auto
+        ( long "theme"
+        <> metavar "THEME"
+        <> help (  "Specify a theme for output styles. THEME is one of: "
+                <> showThemes <> "."
+                )
+        <> value Default
+        <> showDefault
+        )
+ where
+  showThemes = L.intercalate " " $ map show ([minBound .. maxBound] :: [Theme])
+
+fromTheme :: Theme -> StylesUpdate
+fromTheme Default = mempty
+fromTheme SolarizedDark = parseStylesUpdateFromString
+  "error=31:good=32:shell=35:dir=34:recommendation=32:target=95:module=35:package-component=95:secondary=92:highlight=32"
+
+main :: IO ()
+main = do
+  isTerminal <- hIsTerminalDeviceOrMinTTY stderr
+  if isTerminal
+    then do
+      terminalWidth <- fromMaybe 80 <$> getTerminalWidth
+      mainInTerminal terminalWidth =<< execParser opts
+    else
+      putStrLn "This executable is intended to be run with the standard error \
+               \ channel connected to a terminal. No terminal detected."
+ where
+  opts = info (options <**> helper)
+    (  fullDesc
+    <> progDesc "Allows a person to inspect in a terminal the form of Pantry's \
+                \pretty exceptions."
+    <> header "test-pretty-exceptions - test Pantry's pretty exceptions"
+    )
+
+mainInTerminal :: Int -> Options -> IO ()
+mainInTerminal terminalWidth Options{..} = do
+  let stylesUpdate = fromTheme theme <> parseStylesUpdateFromString colours
+  runSimplePrettyApp terminalWidth stylesUpdate action
+ where
+  action :: RIO SimplePrettyApp ()
+  action = mapM_ (prettyError . pretty) examples
+
+-- | The intention is that there shoud be examples for every data constructor of
+-- the PantryException type.
+examples :: [PantryException]
+examples = concat
+  [ [ PackageIdentifierRevisionParseFail hackageMsg ]
+  , [ InvalidCabalFile loc version pErrorExamples pWarningExamples
+    | loc <- map Left rawPackageLocationImmutableExamples <> [Right pathAbsFileExample]
+    , version <- [Nothing, Just versionExample]
+    ]
+  , [ TreeWithoutCabalFile rawPackageLocationImmutable
+    | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples
+    ]
+  , [ TreeWithMultipleCabalFiles rawPackageLocationImmutable safeFilePathExamples
+    | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples
+    ]
+  , [ MismatchedCabalName pathAbsFileExample packageNameExample ]
+  , [ NoCabalFileFound pathAbsDirExample ]
+  , [ MultipleCabalFilesFound pathAbsDirExample pathAbsFileExamples ]
+  , [ InvalidWantedCompiler "my-wanted-compiler" ]
+  , [ InvalidSnapshotLocation pathAbsDirExample rawPathExample ]
+  , [ InvalidOverrideCompiler wantedCompiler1 wantedCompiler2
+    | wantedCompiler1 <- wantedCompilerExamples
+    , wantedCompiler2 <- wantedCompilerExamples
+    ]
+  , [ InvalidFilePathSnapshot rawPathExample ]
+  , [ InvalidSnapshot rawSnapshotLocation someExceptionExample
+    | rawSnapshotLocation <- rawSnapshotLocationExamples
+    ]
+  , [ MismatchedPackageMetadata rawPackageLocationImmutable rawPackageMetadata treeKey packageIdentifierExample
+    | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples
+    , rawPackageMetadata <- rawPackageMetadataExamples
+    , treeKey <- [Nothing, Just treeKeyExample]
+    ]
+  , [ Non200ResponseStatus statusExample ]
+  , [ InvalidBlobKey (Mismatch blobKeyExample blobKeyExample) ]
+  , [ Couldn'tParseSnapshot rawSnapshotLocation errorMessageExample
+    | rawSnapshotLocation <- rawSnapshotLocationExamples
+    ]
+  , [ WrongCabalFileName rawPackageLocationImmutable safeFilePathExample packageNameExample
+    | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples
+    ]
+  , [ DownloadInvalidSHA256 urlExample (Mismatch sha256Example sha256Example) ]
+  , [ DownloadInvalidSize urlExample (Mismatch fileSizeExample fileSizeExample) ]
+  , [ DownloadTooLarge urlExample (Mismatch fileSizeExample fileSizeExample) ]
+  , [ LocalInvalidSHA256 pathAbsFileExample (Mismatch sha256Example sha256Example) ]
+  , [ LocalInvalidSize pathAbsFileExample (Mismatch fileSizeExample fileSizeExample) ]
+  , [ UnknownArchiveType archiveLocation
+    | archiveLocation <- archiveLocationExamples
+    ]
+  , [ InvalidTarFileType archiveLocation filePathExample fileTypeExample
+    | archiveLocation <- archiveLocationExamples
+    ]
+  , [ UnsupportedTarball archiveLocation (T.pack errorMessageExample)
+    | archiveLocation <- archiveLocationExamples
+    ]
+  , [ NoHackageCryptographicHash packageIdentifierExample ]
+  , [ FailedToCloneRepo simpleRepoExample ]
+  , [ TreeReferencesMissingBlob rawPackageLocationImmutable safeFilePathExample blobKeyExample
+    | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples
+    ]
+  , [ CompletePackageMetadataMismatch rawPackageLocationImmutable packageMetadataExample
+    | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples
+    ]
+  , [ CRC32Mismatch archiveLocation filePathExample (Mismatch 1024 1024 )
+    | archiveLocation <- archiveLocationExamples
+    ]
+  , [ UnknownHackagePackage packageIdentifierRevisionExample fuzzyResults
+    | packageIdentifierRevisionExample <- packageIdentifierRevisionExamples
+    , fuzzyResults <- fuzzyResultsExamples
+    ]
+  , [ CannotCompleteRepoNonSHA1 repoExample ]
+  , [ MutablePackageLocationFromUrl urlExample ]
+  , [ MismatchedCabalFileForHackage packageIdentifierRevision (Mismatch packageIdentifierExample packageIdentifierExample)
+    | packageIdentifierRevision <- packageIdentifierRevisionExamples
+    ]
+  , [ PackageNameParseFail rawPackageName ]
+  , [ PackageVersionParseFail rawPackageVersion ]
+  , [ InvalidCabalFilePath pathAbsFileExample ]
+  , [ DuplicatePackageNames sourceMsgExample duplicatePackageNamesExamples ]
+  , [ MigrationFailure descriptionExample pathAbsFileExample someExceptionExample ]
+  , [ InvalidTreeFromCasa blobKeyExample blobExample ]
+  , [ ParseSnapNameException rawSnapNameExample ]
+  , [ HpackLibraryException pathAbsFileExample errorMessageExample ]
+  , [ HpackExeException hpackCommandExample pathAbsDirExample someExceptionExample ]
+  ]
+
+hackageMsg :: Text
+hackageMsg = "<Example message from Hackage.>"
+
+pErrorExamples :: [C.PError]
+pErrorExamples =
+  [ C.PError (C.Position 10 20) "<Example error message1.>"
+  , C.PError (C.Position 12 10) "<Example error message2.>"
+  , C.PError (C.Position 14 30) "<Example error message3.>"
+  ]
+
+pWarningExamples :: [C.PWarning]
+pWarningExamples =
+  [ C.PWarning C.PWTOther (C.Position 10 20) "<Example warning message1.>"
+  , C.PWarning C.PWTOther (C.Position 12 10) "<Example warning message2.>"
+  , C.PWarning C.PWTOther (C.Position 14 30) "<Example warning message3.>"
+  ]
+
+packageNameExample :: PackageName
+packageNameExample = C.mkPackageName "my-package"
+
+versionExample :: Version
+versionExample = C.mkVersion [1, 0, 0]
+
+sha256Example :: SHA256
+sha256Example = hashBytes "example"
+
+fileSizeExample :: FileSize
+fileSizeExample = FileSize 1234
+
+revisionExample :: Revision
+revisionExample = Revision 1
+
+cabalFileInfoExamples :: [CabalFileInfo]
+cabalFileInfoExamples = concat
+  [ [CFILatest]
+  , [ CFIHash sha256Example fileSize
+    | fileSize <- [Nothing, Just fileSizeExample]
+    ]
+  , [CFIRevision revisionExample]
+  ]
+
+packageIdentifierRevisionExamples :: [PackageIdentifierRevision]
+packageIdentifierRevisionExamples =
+  [ PackageIdentifierRevision packageNameExample versionExample cabalFileInfo
+  | cabalFileInfo <- cabalFileInfoExamples
+  ]
+
+blobKeyExample :: BlobKey
+blobKeyExample = BlobKey sha256Example fileSizeExample
+
+treeKeyExample :: TreeKey
+treeKeyExample = TreeKey blobKeyExample
+
+rawPackageLocationImmutableExamples :: [RawPackageLocationImmutable]
+rawPackageLocationImmutableExamples = concat
+  [ [ RPLIHackage packageIdentifierRevision treeKey
+    | packageIdentifierRevision <- packageIdentifierRevisionExamples
+    , treeKey <- [Nothing, Just treeKeyExample]
+    ]
+--, RPLIArchive
+  , [ RPLIRepo repoExample rawPackageMetadata
+    | rawPackageMetadata <- rawPackageMetadataExamples
+    ]
+  ]
+
+safeFilePathExamples :: [SafeFilePath]
+safeFilePathExamples =
+  [ fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example1.ext"
+  , fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example2.ext"
+  , fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example3.ext"
+  ]
+
+rawPathExample :: Text
+rawPathExample = "<Example raw path.>"
+
+wantedCompilerExamples :: [WantedCompiler]
+wantedCompilerExamples =
+  [ WCGhc versionExample
+  , WCGhcGit "<commit1>" "<commit2>"
+  , WCGhcjs versionExample versionExample
+  ]
+
+data ExceptionExample
+  = ExceptionExample !Text
+  deriving (Show, Typeable)
+
+instance Exception ExceptionExample where
+  displayException (ExceptionExample t) = T.unpack t
+
+errorMessageExample :: String
+errorMessageExample =
+  "This is the first line of some example text for the message in an exception \
+  \example. This is example text for an exception example.\n\
+  \This is the second line of some example text for the message in an exception \
+  \example. This is example text for an exception example."
+
+someExceptionExample :: SomeException
+someExceptionExample =
+  SomeException (ExceptionExample $ T.pack errorMessageExample)
+
+urlExample :: Text
+urlExample = "https://example.com"
+
+relFilePathExample :: RelFilePath
+relFilePathExample = RelFilePath "jane/my-project-dir"
+
+resolvedPathFileExample :: ResolvedPath File
+resolvedPathFileExample = ResolvedPath relFilePathExample pathAbsFileExample
+
+snapNameExamples :: [SnapName]
+snapNameExamples =
+  [ LTS 20 17
+  , Nightly $ fromGregorian 2023 4 5
+  ]
+
+rawSnapshotLocationExamples :: [RawSnapshotLocation]
+rawSnapshotLocationExamples = concat
+  [ [ RSLCompiler wantedCompiler
+    | wantedCompiler <- wantedCompilerExamples
+    ]
+  , [ RSLUrl urlExample blobKey
+    | blobKey <- [Nothing, Just blobKeyExample]
+    ]
+  , [ RSLFilePath resolvedPathFileExample ]
+  , [ RSLSynonym snapNameExample
+    | snapNameExample <- snapNameExamples
+    ]
+  ]
+
+rawPackageMetadataExamples :: [RawPackageMetadata]
+rawPackageMetadataExamples =
+  [ RawPackageMetadata name version treeKey
+  | name <- [ Nothing, Just packageNameExample]
+  , version <- [ Nothing, Just versionExample ]
+  , treeKey <- [Nothing, Just treeKeyExample]
+  ]
+
+statusExample :: Status
+statusExample = mkStatus 100 "<Example status message.>"
+
+safeFilePathExample :: SafeFilePath
+safeFilePathExample =
+  fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example.ext"
+
+archiveLocationExamples :: [ArchiveLocation]
+archiveLocationExamples =
+  [ ALUrl urlExample
+  , ALFilePath resolvedPathFileExample
+  ]
+
+filePathExample :: FilePath
+filePathExample = "<file-path>"
+
+fileTypeExample :: Tar.FileType
+fileTypeExample = Tar.FTNormal
+
+commitExample :: Text
+commitExample = "b8b34bf5571de75909d97f687e3d37909b1dc9f7"
+
+simpleRepoExample :: SimpleRepo
+simpleRepoExample = SimpleRepo urlExample commitExample RepoGit
+
+packageIdentifierExample :: PackageIdentifier
+packageIdentifierExample = PackageIdentifier packageNameExample versionExample
+
+packageMetadataExample :: PackageMetadata
+packageMetadataExample = PackageMetadata packageIdentifierExample treeKeyExample
+
+fuzzyResultsExamples :: [FuzzyResults]
+fuzzyResultsExamples =
+  [ FRNameNotFound packageNameExamples
+  , FRVersionNotFound $ fromJust $ nonEmpty packageIdentifierRevisionExamples
+  , FRRevisionNotFound $ fromJust $ nonEmpty packageIdentifierRevisionExamples
+  ]
+
+repoExample :: Repo
+repoExample = Repo urlExample commitExample RepoGit "my-subdirectory"
+
+rawPackageName :: Text
+rawPackageName = "<raw-package-name>"
+
+rawPackageVersion :: Text
+rawPackageVersion = "<raw-package-version>"
+
+sourceMsgExample :: Utf8Builder
+sourceMsgExample = "<Example source message.>"
+
+packageNameExamples :: [PackageName]
+packageNameExamples =
+  [ C.mkPackageName "my-package1"
+  , C.mkPackageName "my-package2"
+  , C.mkPackageName "my-package3"
+  ]
+
+duplicatePackageNamesExamples :: [(PackageName, [RawPackageLocationImmutable])]
+duplicatePackageNamesExamples = map
+  ((, rawPackageLocationImmutableExamples))
+  packageNameExamples
+
+descriptionExample :: Text
+descriptionExample = "<Example description.>"
+
+blobExample :: ByteString
+blobExample = "b8b34bf5571de75909d97f687e3d37909b1dc9f7"
+
+rawSnapNameExample :: Text
+rawSnapNameExample = "<raw-snapshot-name>"
+
+hpackCommandExample :: FilePath
+hpackCommandExample = "<path-to-hpack>/hpack"

@@ -0,0 +1,24 @@+{-# LANGUAGE QuasiQuotes #-}
+
+-- | The module of this name differs as between Windows and non-Windows builds.
+-- This is the non-Windows version.
+module PathAbsExamples
+  ( pathAbsDirExample
+  , pathAbsFileExample
+  , pathAbsFileExamples
+  ) where
+
+import           Path ( Abs, Dir, File, Path, absdir, absfile )
+
+pathAbsDirExample :: Path Abs Dir
+pathAbsDirExample = [absdir|/home/jane/my-project-dir|]
+
+pathAbsFileExample :: Path Abs File
+pathAbsFileExample = [absfile|/home/jane/my-project-dir/example.ext|]
+
+pathAbsFileExamples :: [Path Abs File]
+pathAbsFileExamples =
+  [ [absfile|/home/jane/my-project-dir/example1.ext|]
+  , [absfile|/home/jane/my-project-dir/example2.ext|]
+  , [absfile|/home/jane/my-project-dir/example3.ext|]
+  ]

@@ -0,0 +1,46 @@+{-# LANGUAGE CApiFFI #-}
+
+-- | The module of this name differs as between Windows and non-Windows builds.
+-- This is the non-Windows version.
+module System.Terminal
+( getTerminalWidth
+, hIsTerminalDeviceOrMinTTY
+) where
+
+import           Foreign
+import           Foreign.C.Types
+import           RIO (MonadIO, Handle, hIsTerminalDevice)
+
+#include <sys/ioctl.h>
+#include <unistd.h>
+
+
+newtype WindowWidth = WindowWidth CUShort
+    deriving (Eq, Ord, Show)
+
+instance Storable WindowWidth where
+  sizeOf _ = (#size struct winsize)
+  alignment _ = (#alignment struct winsize)
+  peek p = WindowWidth <$> (#peek struct winsize, ws_col) p
+  poke p (WindowWidth w) = do
+    (#poke struct winsize, ws_col) p w
+
+-- `ioctl` is variadic, so `capi` is needed, see:
+-- https://www.haskell.org/ghc/blog/20210709-capi-usage.html
+foreign import capi "sys/ioctl.h ioctl"
+  ioctl :: CInt -> CInt -> Ptr WindowWidth -> IO CInt
+
+getTerminalWidth :: IO (Maybe Int)
+getTerminalWidth =
+  alloca $ \p -> do
+    errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p
+    if errno < 0
+    then return Nothing
+    else do
+      WindowWidth w <- peek p
+      return . Just . fromIntegral $ w
+
+-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal
+-- devices, but isMinTTYHandle does.
+hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool
+hIsTerminalDeviceOrMinTTY = hIsTerminalDevice

@@ -0,0 +1,24 @@+{-# LANGUAGE QuasiQuotes #-}
+
+-- | The module of this name differs as between Windows and non-Windows builds.
+-- This is the Windows version.
+module PathAbsExamples
+ ( pathAbsDirExample
+ , pathAbsFileExample
+ , pathAbsFileExamples
+ ) where
+
+import           Path ( Abs, Dir, File, Path, absdir, absfile )
+
+pathAbsDirExample :: Path Abs Dir
+pathAbsDirExample = [absdir|C:/Users/jane/my-project-dir|]
+
+pathAbsFileExample :: Path Abs File
+pathAbsFileExample = [absfile|C:/Users/jane/my-project-dir/example.ext|]
+
+pathAbsFileExamples :: [Path Abs File]
+pathAbsFileExamples =
+  [ [absfile|C:/Users/jane/my-project-dir/example1.ext|]
+  , [absfile|C:/Users/jane/my-project-dir/example2.ext|]
+  , [absfile|C:/Users/jane/my-project-dir/example3.ext|]
+  ]

@@ -0,0 +1,81 @@+{-# LANGUAGE NoImplicitPrelude        #-}
+{-# LANGUAGE OverloadedStrings        #-}
+
+-- | The module of this name differs as between Windows and non-Windows builds.
+-- This is the Windows version.
+module System.Terminal
+  ( getTerminalWidth
+  , hIsTerminalDeviceOrMinTTY
+  ) where
+
+import           Foreign.Marshal.Alloc ( allocaBytes )
+import           Foreign.Ptr ( Ptr )
+import           Foreign.Storable ( peekByteOff )
+import           RIO
+import           RIO.Partial ( read )
+import           System.IO hiding ( hIsTerminalDevice )
+import           System.Process
+                   ( StdStream (..), createProcess, shell, std_err, std_in
+                   , std_out, waitForProcess
+                   )
+import           System.Win32 ( isMinTTYHandle, withHandleToHANDLE )
+
+type HANDLE = Ptr ()
+
+data CONSOLE_SCREEN_BUFFER_INFO
+
+sizeCONSOLE_SCREEN_BUFFER_INFO :: Int
+sizeCONSOLE_SCREEN_BUFFER_INFO = 22
+
+posCONSOLE_SCREEN_BUFFER_INFO_srWindow :: Int
+posCONSOLE_SCREEN_BUFFER_INFO_srWindow = 10 -- 4 x Word16 Left,Top,Right,Bottom
+
+c_STD_OUTPUT_HANDLE :: Int
+c_STD_OUTPUT_HANDLE = -11
+
+foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo"
+  c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool
+
+foreign import ccall unsafe "windows.h GetStdHandle"
+  c_GetStdHandle :: Int -> IO HANDLE
+
+
+getTerminalWidth :: IO (Maybe Int)
+getTerminalWidth = do
+  hdl <- c_GetStdHandle c_STD_OUTPUT_HANDLE
+  allocaBytes sizeCONSOLE_SCREEN_BUFFER_INFO $ \p -> do
+    b <- c_GetConsoleScreenBufferInfo hdl p
+    if not b
+      then do -- This could happen on Cygwin or MSYS
+        let stty = (shell "stty size") {
+              std_in  = UseHandle stdin
+            , std_out = CreatePipe
+            , std_err = CreatePipe
+            }
+        (_, mbStdout, _, rStty) <- createProcess stty
+        exStty <- waitForProcess rStty
+        case exStty of
+          ExitFailure _ -> pure Nothing
+          ExitSuccess ->
+            maybe (pure Nothing)
+                  (\hSize -> do
+                      sizeStr <- hGetContents hSize
+                      case map read $ words sizeStr :: [Int] of
+                        [_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)
+          pure $ fromIntegral (v :: Word16)
+        pure $ Just (1 + right - left)
+
+-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal
+-- devices, but isMinTTYHandle does.
+hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool
+hIsTerminalDeviceOrMinTTY h = do
+  isTD <- hIsTerminalDevice h
+  if isTD
+    then pure True
+    else liftIO $ withHandleToHANDLE h isMinTTYHandle

@@ -1,186 +1,266 @@ cabal-version: 1.12
-
--- This file has been generated from package.yaml by hpack version 0.35.0.
---
--- see: https://github.com/sol/hpack
-
-name:           pantry
-version:        0.8.1
-synopsis:       Content addressable Haskell package management
-description:    Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme>
-category:       Development
-homepage:       https://github.com/commercialhaskell/pantry#readme
-bug-reports:    https://github.com/commercialhaskell/pantry/issues
-author:         Michael Snoyman
-maintainer:     michael@snoyman.com
-copyright:      2018-2022 FP Complete
-license:        BSD3
-license-file:   LICENSE
-build-type:     Simple
-extra-source-files:
-    README.md
-    ChangeLog.md
-    attic/hpack-0.1.2.3.tar.gz
-    attic/package-0.1.2.3.tar.gz
-    attic/symlink-to-dir.tar.gz
-
-source-repository head
-  type: git
-  location: https://github.com/commercialhaskell/pantry
-
-library
-  exposed-modules:
-      Pantry
-      Pantry.SHA256
-      Pantry.Internal
-      Pantry.Internal.StaticBytes
-      Pantry.Internal.Stackage
-      Pantry.Internal.Companion
-      Pantry.Internal.AesonExtended
-  other-modules:
-      Hackage.Security.Client.Repository.HttpLib.HttpClient
-      Pantry.Archive
-      Pantry.HTTP
-      Pantry.HPack
-      Pantry.Hackage
-      Pantry.Repo
-      Pantry.SQLite
-      Pantry.Storage
-      Pantry.Casa
-      Pantry.Tree
-      Pantry.Types
-  hs-source-dirs:
-      src/
-  ghc-options: -Wall
-  build-depends:
-      Cabal >=3 && <3.9
-    , aeson
-    , ansi-terminal
-    , base >=4.10 && <5
-    , bytestring
-    , casa-client
-    , casa-types
-    , conduit
-    , conduit-extra
-    , containers
-    , cryptonite
-    , cryptonite-conduit
-    , digest
-    , filelock
-    , generic-deriving
-    , hackage-security
-    , hpack >=0.35.1
-    , http-client
-    , http-client-tls
-    , http-conduit
-    , http-download
-    , http-types
-    , memory
-    , mtl
-    , network-uri
-    , path
-    , path-io
-    , persistent
-    , persistent-sqlite >=2.9.3
-    , persistent-template
-    , primitive
-    , resourcet
-    , rio
-    , rio-orphans
-    , rio-prettyprint
-    , tar-conduit
-    , text
-    , text-metrics
-    , time
-    , transformers
-    , unix-compat
-    , unliftio
-    , unordered-containers
-    , vector
-    , yaml
-    , zip-archive
-  default-language: Haskell2010
-  if os(windows)
-    other-modules:
-        System.IsWindows
-    hs-source-dirs:
-        src/windows/
-  else
-    other-modules:
-        System.IsWindows
-    hs-source-dirs:
-        src/unix/
-
-test-suite spec
-  type: exitcode-stdio-1.0
-  main-is: Spec.hs
-  other-modules:
-      Pantry.ArchiveSpec
-      Pantry.BuildPlanSpec
-      Pantry.CabalSpec
-      Pantry.CasaSpec
-      Pantry.FileSpec
-      Pantry.GlobalHintsSpec
-      Pantry.HackageSpec
-      Pantry.Internal.StaticBytesSpec
-      Pantry.InternalSpec
-      Pantry.TreeSpec
-      Pantry.TypesSpec
-      Paths_pantry
-  hs-source-dirs:
-      test
-  ghc-options: -Wall
-  build-depends:
-      Cabal >=3 && <3.9
-    , QuickCheck
-    , aeson
-    , ansi-terminal
-    , base >=4.10 && <5
-    , bytestring
-    , casa-client
-    , casa-types
-    , conduit
-    , conduit-extra
-    , containers
-    , cryptonite
-    , cryptonite-conduit
-    , digest
-    , exceptions
-    , filelock
-    , generic-deriving
-    , hackage-security
-    , hedgehog
-    , hpack >=0.35.1
-    , hspec
-    , http-client
-    , http-client-tls
-    , http-conduit
-    , http-download
-    , http-types
-    , memory
-    , mtl
-    , network-uri
-    , pantry
-    , path
-    , path-io
-    , persistent
-    , persistent-sqlite >=2.9.3
-    , persistent-template
-    , primitive
-    , raw-strings-qq
-    , resourcet
-    , rio
-    , rio-orphans
-    , rio-prettyprint
-    , tar-conduit
-    , text
-    , text-metrics
-    , time
-    , transformers
-    , unix-compat
-    , unliftio
-    , unordered-containers
-    , vector
-    , yaml
-    , zip-archive
-  default-language: Haskell2010
++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           pantry+version:        0.8.2+synopsis:       Content addressable Haskell package management+description:    Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme>+category:       Development+homepage:       https://github.com/commercialhaskell/pantry#readme+bug-reports:    https://github.com/commercialhaskell/pantry/issues+author:         Michael Snoyman+maintainer:     michael@snoyman.com+copyright:      2018-2022 FP Complete+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+    attic/hpack-0.1.2.3.tar.gz+    attic/package-0.1.2.3.tar.gz+    attic/symlink-to-dir.tar.gz++source-repository head+  type: git+  location: https://github.com/commercialhaskell/pantry++flag test-pretty-exceptions+  description: Build an executable to test pretty exceptions+  manual: False+  default: False++library+  exposed-modules:+      Pantry+      Pantry.SHA256+      Pantry.Internal+      Pantry.Internal.StaticBytes+      Pantry.Internal.Stackage+      Pantry.Internal.Companion+      Pantry.Internal.AesonExtended+  other-modules:+      Hackage.Security.Client.Repository.HttpLib.HttpClient+      Pantry.Archive+      Pantry.HTTP+      Pantry.HPack+      Pantry.Hackage+      Pantry.Repo+      Pantry.SQLite+      Pantry.Storage+      Pantry.Casa+      Pantry.Tree+      Pantry.Types+  hs-source-dirs:+      src/+  ghc-options: -Wall+  build-depends:+      Cabal >=3 && <3.11+    , aeson+    , ansi-terminal+    , base >=4.10 && <5+    , bytestring+    , casa-client+    , casa-types+    , conduit+    , conduit-extra+    , containers+    , cryptonite+    , cryptonite-conduit+    , digest+    , filelock+    , generic-deriving+    , hackage-security+    , hpack >=0.35.1+    , http-client+    , http-client-tls+    , http-conduit+    , http-download+    , http-types+    , memory+    , mtl+    , network-uri+    , path+    , path-io+    , persistent+    , persistent-sqlite >=2.9.3+    , persistent-template+    , primitive+    , resourcet+    , rio+    , rio-orphans+    , rio-prettyprint+    , tar-conduit+    , text+    , text-metrics+    , time+    , transformers+    , unix-compat+    , unliftio+    , unordered-containers+    , vector+    , yaml+    , zip-archive+  default-language: Haskell2010+  if os(windows)+    other-modules:+        System.IsWindows+    hs-source-dirs:+        src/windows/+  else+    other-modules:+        System.IsWindows+    hs-source-dirs:+        src/unix/++executable test-pretty-exceptions+  main-is: Main.hs+  other-modules:+      Paths_pantry+  hs-source-dirs:+      app/test-pretty-exceptions+  ghc-options: -Wall+  build-depends:+      Cabal >=3 && <3.11+    , aeson+    , ansi-terminal+    , base >=4.10 && <5+    , bytestring+    , casa-client+    , casa-types+    , conduit+    , conduit-extra+    , containers+    , cryptonite+    , cryptonite-conduit+    , digest+    , filelock+    , generic-deriving+    , hackage-security+    , hpack >=0.35.1+    , http-client+    , http-client-tls+    , http-conduit+    , http-download+    , http-types+    , memory+    , mtl+    , network-uri+    , optparse-applicative+    , pantry+    , path+    , path-io+    , persistent+    , persistent-sqlite >=2.9.3+    , persistent-template+    , primitive+    , resourcet+    , rio+    , rio-orphans+    , rio-prettyprint+    , tar-conduit+    , text+    , text-metrics+    , time+    , transformers+    , unix-compat+    , unliftio+    , unordered-containers+    , vector+    , yaml+    , zip-archive+  default-language: Haskell2010+  if !flag(test-pretty-exceptions)+    buildable: False+  if os(windows)+    other-modules:+        PathAbsExamples+        System.Terminal+    hs-source-dirs:+        app/test-pretty-exceptions/windows/+    build-depends:+        Win32+      , process+  else+    other-modules:+        PathAbsExamples+        System.Terminal+    hs-source-dirs:+        app/test-pretty-exceptions/unix/++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Pantry.ArchiveSpec+      Pantry.BuildPlanSpec+      Pantry.CabalSpec+      Pantry.CasaSpec+      Pantry.FileSpec+      Pantry.GlobalHintsSpec+      Pantry.HackageSpec+      Pantry.Internal.StaticBytesSpec+      Pantry.InternalSpec+      Pantry.TreeSpec+      Pantry.TypesSpec+      Paths_pantry+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      Cabal >=3 && <3.11+    , QuickCheck+    , aeson+    , ansi-terminal+    , base >=4.10 && <5+    , bytestring+    , casa-client+    , casa-types+    , conduit+    , conduit-extra+    , containers+    , cryptonite+    , cryptonite-conduit+    , digest+    , exceptions+    , filelock+    , generic-deriving+    , hackage-security+    , hedgehog+    , hpack >=0.35.1+    , hspec+    , http-client+    , http-client-tls+    , http-conduit+    , http-download+    , http-types+    , memory+    , mtl+    , network-uri+    , pantry+    , path+    , path-io+    , persistent+    , persistent-sqlite >=2.9.3+    , persistent-template+    , primitive+    , raw-strings-qq+    , resourcet+    , rio+    , rio-orphans+    , rio-prettyprint+    , tar-conduit+    , text+    , text-metrics+    , time+    , transformers+    , unix-compat+    , unliftio+    , unordered-containers+    , vector+    , yaml+    , zip-archive+  default-language: Haskell2010

@@ -35,6 +35,8 @@ 
     -- ** Exceptions
   , PantryException (..)
+  , Mismatch (..)
+  , FuzzyResults (..)
 
     -- ** Cabal types
   , PackageName
@@ -47,6 +49,8 @@   , RelFilePath (..)
   , ResolvedPath (..)
   , Unresolved
+  , SafeFilePath
+  , mkSafeFilePath
 
     -- ** Cryptography
   , SHA256
@@ -785,13 +789,19 @@                       logDebug $ "Hpack output unchanged in " <> cabalFile
                     Hpack.AlreadyGeneratedByNewerHpack -> logWarn $
                         cabalFile <>
-                        " was generated with a newer version of Hpack,\n" <>
-                        "please upgrade and try again."
+                        " was generated with a newer version of Hpack. Ignoring " <>
+                        fromString (toFilePath hpackFile) <>
+                        " in favor of the Cabal file.\n" <>
+                        "Either please upgrade and try again or, if you want to use the " <>
+                        fromString (toFilePath (filename hpackFile)) <>
+                        " file instead of the Cabal file,\n" <>
+                        "then please delete the Cabal file."
                     Hpack.ExistingCabalFileWasModifiedManually -> logWarn $
                         cabalFile <>
                         " was modified manually. Ignoring " <>
                         fromString (toFilePath hpackFile) <>
-                        " in favor of the Cabal file.\nIf you want to use the " <>
+                        " in favor of the Cabal file.\n" <>
+                        "If you want to use the " <>
                         fromString (toFilePath (filename hpackFile)) <>
                         " file instead of the Cabal file,\n" <>
                         "then please delete the Cabal file."

@@ -57,16 +57,22 @@                     Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile
                     Hpack.AlreadyGeneratedByNewerHpack -> logWarn $
                         cabalFile <>
-                        " was generated with a newer version of hpack,\n" <>
-                        "please upgrade and try again."
+                        " was generated with a newer version of hpack. Ignoring " <>
+                        fromString (toFilePath hpackFile) <>
+                        " in favor of the Cabal file.\n" <>
+                        "Either please upgrade and try again or, if you want to use the " <>
+                        fromString (toFilePath (filename hpackFile)) <>
+                        " file instead of the Cabal file,\n" <>
+                        "then please delete the Cabal file."
                     Hpack.ExistingCabalFileWasModifiedManually -> logWarn $
                         cabalFile <>
                         " was modified manually. Ignoring " <>
                         fromString (toFilePath hpackFile) <>
-                        " in favor of the cabal file.\nIf you want to use the " <>
+                        " in favor of the Cabal file.\n" <>
+                        "If you want to use the " <>
                         fromString (toFilePath (filename hpackFile)) <>
-                        " file instead of the cabal file,\n" <>
-                        "then please delete the cabal file."
+                        " file instead of the Cabal file,\n" <>
+                        "then please delete the Cabal file."
             HpackCommand command ->
                 withWorkingDir (toFilePath pkgDir) $
                 proc command [] runProcess_

@@ -131,10 +131,18 @@ import RIO.List (intersperse, groupBy)
 import RIO.Time (toGregorian, Day, UTCTime)
 import qualified RIO.Map as Map
+import RIO.PrettyPrint (bulletedList, fillSep, flow, hang, line, mkNarrativeList, parens, string, style)
+import RIO.PrettyPrint.Types (Style (..))
 import qualified Data.Map.Strict as Map (mapKeysMonotonic)
 import qualified RIO.Set as Set
 import Data.Aeson.Types (toJSONKeyText, Parser)
 import Pantry.Internal.AesonExtended
+         ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..), Object
+         , ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..)
+         , WarningParser, WithJSONWarnings, (..:), (..:?), (..!=), (.=), (.:)
+         , (...:?), jsonSubWarnings, jsonSubWarningsT, noJSONWarnings, object
+         , tellJSONField, withObject, withObjectWarnings, withText
+         )
 import Data.Aeson.Encoding.Internal (unsafeToEncoding)
 import Data.ByteString.Builder (toLazyByteString, byteString, wordDec)
 import Database.Persist
@@ -160,6 +168,7 @@ import Distribution.Types.Version (Version, mkVersion, nullVersion)
 import Network.HTTP.Client (parseRequest)
 import Network.HTTP.Types (Status, statusCode)
+import Text.PrettyPrint.Leijen.Extended (Pretty (..), StyleDoc)
 import Data.Text.Read (decimal)
 import Path (Path, Abs, Dir, File, toFilePath, filename, (</>), parseRelFile)
 import Path.IO (resolveFile, resolveDir)
@@ -392,6 +401,34 @@        then mempty
        else " in subdir " <> display (repoSubdir repo))
 
+instance Pretty RawPackageLocationImmutable where
+  pretty (RPLIHackage pir _tree) = fillSep
+    [ fromString . T.unpack $ textDisplay pir
+    , parens (flow "from Hackage")
+    ]
+  pretty (RPLIArchive archive _pm) = fillSep
+    [ flow "Archive from"
+    , pretty (raLocation archive)
+    , if T.null $ raSubdir archive
+        then mempty
+        else fillSep
+          [ flow "in subdir"
+          , style Dir (fromString $ T.unpack (raSubdir archive))
+          ]
+    ]
+  pretty (RPLIRepo repo _pm) = fillSep
+    [ flow "Repo from"
+    , style Url (fromString $ T.unpack (repoUrl repo)) <> ","
+    , "commit"
+    , fromString $ T.unpack (repoCommit repo)
+    , if T.null $ repoSubdir repo
+        then mempty
+        else fillSep
+          [ flow "in subdir"
+          , style Dir (fromString $ T.unpack (repoSubdir repo))
+          ]
+    ]
+
 -- | Location for remote packages or archives assumed to be immutable.
 --
 -- @since 0.1.0.0
@@ -400,6 +437,7 @@   | PLIArchive !Archive !PackageMetadata
   | PLIRepo    !Repo !PackageMetadata
   deriving (Generic, Show, Eq, Ord, Typeable)
+
 instance NFData PackageLocationImmutable
 
 instance Display PackageLocationImmutable where
@@ -983,6 +1021,9 @@ -- error messages generated by Pantry itself begin with an unique code in the
 -- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999.
 -- The numbers are selected at random, not in sequence.
+--
+-- Prettier versions of these error messages are also provided. See the instance
+-- of Pretty.
 instance Display PantryException where
   display (InvalidTreeFromCasa blobKey _bs) =
     "Error: [S-258]\n"
@@ -1296,6 +1337,509 @@     <> "The error encountered was:\n\n"
     <> fromString (show err)
 
+-- See also the instance of Display. Although prettier, these messages are
+-- intended to be substantively the same as the corresponding 'black and white'
+-- versions.
+instance Pretty PantryException where
+  pretty (InvalidTreeFromCasa blobKey _bs) =
+    "[S-258]"
+    <> line
+    <> fillSep
+         [ flow "Invalid tree from casa:"
+         , fromString . T.unpack $ textDisplay blobKey
+         ]
+  pretty (PackageIdentifierRevisionParseFail text) =
+    "[S-360]"
+    <> line
+    <> fillSep
+         [ flow "Invalid package identifier (with optional revision):"
+         , fromString $ T.unpack text
+         ]
+  pretty (InvalidCabalFile loc mversion errs warnings) =
+    "[S-242]"
+    <> line
+    <> fillSep
+         [ flow "Unable to parse Cabal file from package"
+         , either pretty pretty loc <> ":"
+         ]
+    <> line
+    <> bulletedList
+         ( map (\(PError pos msg) -> fillSep
+             [ fromString (showPos pos) <> ":"
+             , fromString msg
+             ])
+             errs
+         )
+    <> line
+    <> bulletedList
+         ( map (\(PWarning _ pos msg) -> fillSep
+             [ fromString (showPos pos) <> ":"
+             , fromString msg
+             ])
+             warnings
+         )
+    <> ( case mversion of
+           Just version | version > cabalSpecLatestVersion ->
+                line
+             <> fillSep
+                  [ flow "The Cabal file uses the Cabal specification version"
+                  , style Current (fromString $ versionString version) <> ","
+                  , flow "but we only support up to version"
+                  , fromString (versionString cabalSpecLatestVersion) <> "."
+                  , flow "Recommended action: upgrade your build tool"
+                  , parens (fillSep
+                      [ "e.g."
+                      , style Shell (flow "stack upgrade")
+                      ]) <> "."
+                  ]
+           _ -> mempty
+       )
+  pretty (TreeWithoutCabalFile loc) =
+    "[S-654]"
+    <> line
+    <> fillSep
+         [ flow "No Cabal file found for"
+         , pretty loc <> "."
+         ]
+  pretty (TreeWithMultipleCabalFiles loc sfps) =
+    "[S-500]"
+    <> line
+    <> fillSep
+         ( flow "Multiple Cabal files found for"
+         : (pretty loc <> ":")
+         : mkNarrativeList (Just File) False
+             (map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc])
+         )
+  pretty (MismatchedCabalName fp name) =
+    "[S-910]"
+    <> line
+    <> fillSep
+         [ flow "The Cabal file"
+         , pretty fp
+         , flow "is not named after the package that it defines. Please rename"
+         , flow "the file to"
+         , style File (fromString $ packageNameString name <> ".cabal") <> "."
+         , flow "Hackage rejects packages where the first part of the Cabal"
+         , flow "file name is not the package name."
+         ]
+  pretty (NoCabalFileFound dir) =
+    "[S-636]"
+    <> line
+    <> fillSep
+         [ flow "Stack looks for packages in the directories configured in the"
+         , style Shell "packages"
+         , "and"
+         , style Shell "extra-deps"
+         , flow "fields defined in your"
+         , style File "stack.yaml" <> "."
+         , flow "The current entry points to"
+         , pretty dir
+         , flow "but no Cabal file or"
+         , style File "package.yaml"
+         , flow "could be found there."
+         ]
+  pretty (MultipleCabalFilesFound dir files) =
+    "[S-368]"
+    <> line
+    <> fillSep
+         ( flow "Multiple Cabal files found in directory"
+         : (pretty dir <> ":")
+         : mkNarrativeList (Just File) False
+             (map (pretty . filename) files)
+         )
+  pretty (InvalidWantedCompiler t) =
+    "[S-204]"
+    <> line
+    <> fillSep
+         [ flow "Invalid wanted compiler:"
+         , style Current (fromString $ T.unpack t) <> "."
+         ]
+  pretty (InvalidSnapshotLocation dir t) =
+    "[S-935]"
+    <> line
+    <> fillSep
+         [ flow "Invalid snapshot location"
+         , style Current (fromString $ T.unpack t)
+         , flow "relative to directory"
+         , pretty dir <> "."
+         ]
+  pretty (InvalidOverrideCompiler x y) =
+    "[S-287]"
+    <> line
+    <> fillSep
+         [ flow "Specified compiler for a resolver"
+         , parens (style Shell (fromString . T.unpack $ textDisplay x))
+         , flow "but also specified an override compiler"
+         , parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "."
+         ]
+  pretty (InvalidFilePathSnapshot t) =
+    "[S-617]"
+    <> line
+    <> fillSep
+         [ flow "Specified snapshot as file path with"
+         , style File (fromString $ T.unpack t) <> ","
+         , flow "but not reading from a local file."
+         ]
+  pretty (InvalidSnapshot loc err) =
+    "[S-775]"
+    <> line
+    <> fillSep
+         [ flow "Exception while reading snapshot from"
+         , pretty loc <> ":"
+         ]
+    <> blankLine
+    <> string (displayException err)
+  pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
+    "[S-427]"
+    <> line
+    <> fillSep
+         [ flow "Mismatched package metadata for"
+         , pretty loc <> "."
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , let t = textDisplay pm
+           in  if T.null t
+                 then "nothing."
+                 else fromString $ T.unpack t <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Found:   "
+         , fromString $ packageIdentifierString foundIdent <> case mtreeKey of
+             Nothing -> "."
+             _ -> mempty
+         , case mtreeKey of
+             Nothing -> mempty
+             Just treeKey -> fillSep
+               [ "with tree"
+               , fromString . T.unpack $ textDisplay treeKey <> "."
+               ]
+         ])
+  pretty (Non200ResponseStatus status) =
+    "[S-571]"
+    <> line
+    <> fillSep
+         [ flow "Unexpected non-200 HTTP status code:"
+         , (fromString . show $ statusCode status) <> "."
+         ]
+  pretty (InvalidBlobKey Mismatch{..}) =
+    "[S-236]"
+    <> line
+    <> fillSep
+         [ flow "Invalid blob key found, expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> ","
+         , "actual:"
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ]
+  pretty (Couldn'tParseSnapshot sl err) =
+    "[S-645]"
+    <> line
+    <> fillSep
+         [ flow "Couldn't parse snapshot from"
+         , pretty sl <> ":"
+         ]
+    <> blankLine
+    <> string err
+  pretty (WrongCabalFileName loc sfp name) =
+    "[S-575]"
+    <> line
+    <> fillSep
+         [ flow "Wrong Cabal file name for package"
+         , pretty loc <> "."
+         , flow "The Cabal file is named"
+         , style File (fromString . T.unpack $ textDisplay sfp) <> ","
+         , flow "but package name is"
+         , fromString (packageNameString name) <> "."
+         , flow "For more information, see"
+         , style Url "https://github.com/commercialhaskell/stack/issues/317"
+         , "and"
+         , style Url "https://github.com/commercialhaskell/stack/issues/895" <> "."
+         ]
+  pretty (DownloadInvalidSHA256 url Mismatch {..}) =
+    "[S-394]"
+    <> line
+    <> fillSep
+         [ flow "Mismatched SHA256 hash from"
+         , style Url (fromString $ T.unpack url) <> "."
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Actual:  "
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ])
+  pretty (DownloadInvalidSize url Mismatch {..}) =
+    "[S-401]"
+    <> line
+    <> fillSep
+         [ flow "Mismatched download size from"
+         , style Url (fromString $ T.unpack url) <> "."
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Actual:  "
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ])
+  pretty (DownloadTooLarge url Mismatch {..}) =
+    "[S-113]"
+    <> line
+    <> fillSep
+         [ flow "Download from"
+         , style Url (fromString $ T.unpack url)
+         , flow "was too large. Expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> ","
+         , flow "stopped after receiving:"
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ]
+  pretty (LocalInvalidSHA256 path Mismatch {..}) =
+    "[S-834]"
+    <> line
+    <> fillSep
+         [ flow "Mismatched SHA256 hash from"
+         , pretty path <> "."
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Actual:  "
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ])
+  pretty (LocalInvalidSize path Mismatch {..}) =
+    "[S-713]"
+    <> line
+    <> fillSep
+         [ flow "Mismatched file size from"
+         , pretty path <> "."
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Actual:  "
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ])
+  pretty (UnknownArchiveType loc) =
+    "[S-372]"
+    <> line
+    <> fillSep
+         [ flow "Unable to determine archive type of:"
+         , pretty loc <> "."
+         ]
+  pretty (InvalidTarFileType loc fp x) =
+    "[S-950]"
+    <> line
+    <> fillSep
+         [ flow "Unsupported tar file type in archive"
+         , pretty loc
+         , flow "at file"
+         , style File (fromString fp) <> ":"
+         , fromString $ show x <> "."
+         ]
+  pretty (UnsupportedTarball loc err) =
+    "[S-760]"
+    <> line
+    <> fillSep
+         [ flow "Unsupported tarball from"
+         , pretty loc <> ":"
+         ]
+    <> blankLine
+    <> string (T.unpack err)
+  pretty (NoHackageCryptographicHash ident) =
+    "[S-922]"
+    <> line
+    <> fillSep
+         [ flow "No cryptographic hash found for Hackage package"
+         , fromString (packageIdentifierString ident) <> "."
+         ]
+  pretty (FailedToCloneRepo repo) =
+    "[S-109]"
+    <> line
+    <> fillSep
+         [ flow "Failed to clone repository"
+         , fromString . T.unpack $ textDisplay repo
+         ]
+  pretty (TreeReferencesMissingBlob loc sfp key) =
+    "[S-237]"
+    <> line
+    <> fillSep
+         [ flow "The package"
+         , pretty loc
+         , flow "needs blob"
+         , fromString . T.unpack $ textDisplay key
+         , flow "for file path"
+         , style File (fromString . T.unpack $ textDisplay sfp) <> ","
+         , flow "but the blob is not available."
+         ]
+  pretty (CompletePackageMetadataMismatch loc pm) =
+    "[S-984]"
+    <> line
+    <> fillSep
+         [ flow "When completing package metadata for"
+         , pretty loc <> ","
+         , flow "some values changed in the new package metadata:"
+         , fromString . T.unpack $ textDisplay pm <> "."
+         ]
+  pretty (CRC32Mismatch loc fp Mismatch {..}) =
+    "[S-607]"
+    <> line
+    <> fillSep
+         [ flow "CRC32 mismatch in Zip file from"
+         , pretty loc
+         , flow "on internal file"
+         , style File (fromString fp)
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Actual:  "
+         , fromString . T.unpack $ textDisplay mismatchActual <> "."
+         ])
+  pretty (UnknownHackagePackage pir fuzzy) =
+    "[S-476]"
+    <> line
+    <> fillSep
+         [ flow "Could not find"
+         , style Error (fromString . T.unpack $ textDisplay pir)
+         , flow "on Hackage."
+         ]
+    <> prettyFuzzy fuzzy
+  pretty (CannotCompleteRepoNonSHA1 repo) =
+    "[S-112]"
+    <> line
+    <> fillSep
+         [ flow "Cannot complete repo information for a non SHA1 commit due to"
+         , "non-reproducibility:"
+         , fromString . T.unpack $ textDisplay repo <> "."
+         ]
+  pretty (MutablePackageLocationFromUrl t) =
+    "[S-321]"
+    <> line
+    <> fillSep
+         [ flow "Cannot refer to a mutable package location from a URL:"
+         , style Url (fromString $ T.unpack t) <> "."
+         ]
+  pretty (MismatchedCabalFileForHackage pir Mismatch{..}) =
+    "[S-377]"
+    <> line
+    <> fillSep
+         [ flow "When processing Cabal file for Hackage package"
+         , fromString . T.unpack $ textDisplay pir <> ","
+         , flow "mismatched package identifier."
+         ]
+    <> blankLine
+    <> hang 10 (fillSep
+         [ "Expected:"
+         , fromString (packageIdentifierString mismatchExpected) <> "."
+         ])
+    <> line
+    <> hang 10 (fillSep
+         [ "Actual:  "
+         , fromString (packageIdentifierString mismatchActual) <> "."
+         ])
+  pretty (PackageNameParseFail t) =
+    "[S-580]"
+    <> line
+    <> fillSep
+         [ flow "Invalid package name:"
+         , fromString $ T.unpack t <> "."
+         ]
+  pretty (PackageVersionParseFail t) =
+    "[S-479]"
+    <> line
+    <> fillSep
+         [ flow "Invalid version:"
+         , fromString $ T.unpack t <> "."
+         ]
+  pretty (InvalidCabalFilePath fp) =
+    "[S-824]"
+    <> line
+    <> fillSep
+         [ flow "File path contains a name which is not a valid package name:"
+         , pretty fp <> "."
+         ]
+  pretty (DuplicatePackageNames source pairs') =
+    "[S-674]"
+    <> line
+    <> fillSep
+         [ flow "Duplicate package names"
+         , parens (fromString . T.unpack $ textDisplay source) <> ":"
+         ]
+    <> line
+    <> foldMap
+         ( \(name, locs) ->
+                fromString (packageNameString name) <> ":"
+             <> line
+             <> bulletedList (map pretty locs)
+             <> line
+         )
+         pairs'
+  pretty (MigrationFailure desc fp err) =
+    "[S-536]"
+    <> line
+    <> fillSep
+         [ flow "Encountered error while migrating database"
+         , fromString $ T.unpack desc
+         , flow "located at"
+         , pretty fp <> ":"
+         ]
+    <> blankLine
+    <> string (displayException err)
+  pretty (ParseSnapNameException t) =
+    "[S-994]"
+    <> line
+    <> fillSep
+         [ flow "Invalid snapshot name:"
+         , fromString $ T.unpack t <> "."
+         ]
+  pretty (HpackLibraryException file err) =
+    "[S-305]"
+    <> line
+    <> fillSep
+         [ flow "Failed to generate a Cabal file using the Hpack library on"
+         , "file:"
+         , pretty file <> "."
+         , flow "The error encountered was:"
+         ]
+    <> blankLine
+    <> string err
+  pretty (HpackExeException fp dir err) =
+    "[S-720]"
+    <> line
+    <> fillSep
+         [ flow "Failed to generate a Cabal file using the Hpack executable:"
+         , style File (fromString fp)
+         , flow "in directory:"
+         , pretty dir <> "."
+         , flow "The error encountered was:"
+         ]
+    <> blankLine
+    <> string (displayException err)
+
+blankLine :: StyleDoc
+blankLine = line <> line
+
 data FuzzyResults
   = FRNameNotFound ![PackageName]
   | FRVersionNotFound !(NonEmpty PackageIdentifierRevision)
@@ -1318,6 +1862,32 @@   commaSeparated (NE.map display pirs) <>
   "."
 
+prettyFuzzy :: FuzzyResults -> StyleDoc
+prettyFuzzy (FRNameNotFound names) =
+  case NE.nonEmpty names of
+    Nothing -> mempty
+    Just names' ->
+         line
+      <> fillSep
+           ( flow "Perhaps you meant one of"
+           : mkNarrativeList Nothing False
+               (NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc])
+           )
+prettyFuzzy (FRVersionNotFound pirs) =
+     line
+  <> fillSep
+       ( flow "Possible candidates:"
+       : mkNarrativeList Nothing False
+           (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc])
+       )
+prettyFuzzy (FRRevisionNotFound pirs) =
+     line
+  <> fillSep
+       ( flow "The specified revision was not found. Possible candidates:"
+       : mkNarrativeList Nothing False
+           (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc])
+       )
+
 orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
 orSeparated xs
   | NE.length xs == 1 = NE.head xs
@@ -1729,6 +2299,10 @@   display (ALUrl url) = display url
   display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved
 
+instance Pretty ArchiveLocation where
+  pretty (ALUrl url) = style Url (fromString $ T.unpack url)
+  pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved
+
 parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation)
 parseArchiveLocationObject o =
     ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) <|>
@@ -2269,6 +2843,17 @@   display (RSLFilePath resolved) = display (resolvedRelative resolved)
   display (RSLSynonym syn) = display syn
 
+instance Pretty RawSnapshotLocation where
+  pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler
+  pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url)
+  pretty (RSLUrl url (Just blob)) = fillSep
+    [ style Url (fromString $ T.unpack  url)
+    , parens (fromString . T.unpack $ textDisplay blob)
+    ]
+  pretty (RSLFilePath resolved) =
+    style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved))
+  pretty (RSLSynonym syn) =
+    style Shell (fromString . T.unpack $ textDisplay syn)
 
 instance ToJSON RawSnapshotLocation where
   toJSON (RSLCompiler compiler) = object ["compiler" .= compiler]