Fix Hpack #530 Make use of prettier Hpack error messages

Prettier Hpack error messages are enabled by hpack-0.35.1. For the context to this pull request see [Hpack issue #530](sol/hpack#530), the [Hpack PR #531](sol/hpack#531) and the alternative [Hpack PR #535](sol/hpack#535) (on which this PR builds). Also conforms form of messages of Errors [S-305] and [S-720] and the naming of arguments (`err`) in the `PantryException` instance of `Display`. Also bumps from lts-20.0 to lts-20.4 (most recent GHC 9.2.5).
commercialhaskell · Dec 12, 2022 · dd37355 · dd37355
1 parent 3e19cf9
commit dd37355
Show file tree

Hide file tree

Showing 18 changed files with 108 additions and 49 deletions.
diff --git a/package.yaml b/package.yaml
@@ -1,5 +1,5 @@
 name:        pantry
-version:     0.8.0
+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
@@ -53,7 +53,7 @@ dependencies:
 - tar-conduit
 - time
 - unix-compat
-- hpack >= 0.31.2
+- hpack >= 0.35.1
 - yaml
 - zip-archive
 - text-metrics

diff --git a/pantry.cabal b/pantry.cabal
diff --git a/src/Pantry.hs b/src/Pantry.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
 -- | Content addressable Haskell package management, providing for
 -- secure, reproducible acquisition of Haskell package contents and
 -- metadata.
@@ -188,6 +190,9 @@ module Pantry
 
 import Database.Persist (entityKey)
 import RIO
+#if !MIN_VERSION_rio(0,1,17)
+import Data.Bifunctor (bimap)
+#endif
 import Conduit
 import Control.Arrow (right)
 import Control.Monad.State.Strict (State, execState, get, modify')
@@ -227,6 +232,23 @@ import Pantry.HTTP
 import Data.Char (isHexDigit)
 import Data.Time (getCurrentTime, diffUTCTime)
 
+import Data.Yaml.Include (decodeFileWithWarnings)
+import Hpack.Yaml (formatWarning)
+import Hpack.Error (formatHpackError)
+
+decodeYaml :: FilePath -> IO (Either String ([String], Value))
+decodeYaml file = do
+  bimap displayException (first formatWarnings) <$> decodeFileWithWarnings file
+  where
+    formatWarnings = map (formatWarning file)
+
+formatYamlParseError :: FilePath -> Yaml.ParseException -> String
+formatYamlParseError file e =
+  "In respect of an Hpack defaults file:\n"
+  <> file
+  <> ":\n\n"
+  <> displayException e
+
 -- | Create a new 'PantryConfig' with the given settings.
 --
 -- For something easier to use in simple cases, see 'runPantryApp'.
@@ -741,15 +763,18 @@ hpack progName pkgDir = do
 
         he <- view $ pantryConfigL.to pcHpackExecutable
         case he of
-            HpackBundled -> do
-                r <- catchAny
-                       ( liftIO
-                           $ Hpack.hpackResult
+            HpackBundled ->
+                        liftIO
+                           ( Hpack.hpackResultWithError
                            $ mHpackProgName
+                           $ Hpack.setDecode decodeYaml
+                           $ Hpack.setFormatYamlParseError formatYamlParseError
                            $ Hpack.setTarget
                                (toFilePath hpackFile) Hpack.defaultOptions
-                       )
-                       ( throwIO . HpackLibraryException hpackFile )
+                           )
+                         >>= \ case
+              Left err -> throwIO (HpackLibraryException hpackFile $ formatHpackError (fromMaybe "hpack" progName) err)
+              Right r -> do
                 forM_ (Hpack.resultWarnings r) (logWarn . fromString)
                 let cabalFile = fromString . Hpack.resultCabalFile $ r
                 case Hpack.resultStatus r of

diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs
@@ -970,7 +970,7 @@ data PantryException
   | MigrationFailure !Text !(Path Abs File) !SomeException
   | InvalidTreeFromCasa !BlobKey !ByteString
   | ParseSnapNameException !Text
-  | HpackLibraryException !(Path Abs File) !SomeException
+  | HpackLibraryException !(Path Abs File) !String
   | HpackExeException !FilePath !(Path Abs Dir) !SomeException
 
   deriving Typeable
@@ -1084,12 +1084,12 @@ instance Display PantryException where
     <> "Specified snapshot as file path with "
     <> displayShow t
     <> ", but not reading from a local file"
-  display (InvalidSnapshot loc e) =
+  display (InvalidSnapshot loc err) =
     "Error: [S-775]\n"
     <> "Exception while reading snapshot from "
     <> display loc
     <> ":\n"
-    <> displayShow e
+    <> displayShow err
   display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
     "Error: [S-427]\n"
     <> "Mismatched package metadata for "
@@ -1112,12 +1112,12 @@ instance Display PantryException where
     <> display mismatchExpected
     <> ", actual: "
     <> display mismatchActual
-  display (Couldn'tParseSnapshot sl e) =
+  display (Couldn'tParseSnapshot sl err) =
     "Error: [S-645]\n"
     <> "Couldn't parse snapshot from "
     <> display sl
     <> ": "
-    <> fromString e
+    <> fromString err
   display (WrongCabalFileName pl sfp name) =
     "Error: [S-575]\n"
     <> "Wrong cabal file name for package "
@@ -1180,12 +1180,12 @@ instance Display PantryException where
     <> fromString fp
     <> ": "
     <> displayShow x
-  display (UnsupportedTarball loc e) =
+  display (UnsupportedTarball loc err) =
     "Error: [S-760]\n"
     <> "Unsupported tarball from "
     <> display loc
     <> ": "
-    <> display e
+    <> display err
   display (NoHackageCryptographicHash ident) =
     "Error: [S-922]\n"
     <> "No cryptographic hash found for Hackage package "
@@ -1266,35 +1266,35 @@ instance Display PantryException where
              <> foldMap (\loc -> "- " <> display loc <> "\n") locs
          )
          pairs'
-  display (MigrationFailure desc fp ex) =
+  display (MigrationFailure desc fp err) =
     "Error: [S-536]\n"
     <> "Encountered error while migrating database "
     <> display desc
     <> "\nlocated at "
     <> fromString (toFilePath fp)
     <> ":"
     <> "\n    "
-    <> displayShow ex
+    <> displayShow err
   display (ParseSnapNameException t) =
     "Error: [S-994]\n"
      <> "Invalid snapshot name: "
      <> display t
-  display (HpackLibraryException file e) =
+  display (HpackLibraryException file err) =
     "Error: [S-305]\n"
     <> "Failed to generate a Cabal file using the Hpack library on file:\n"
     <> fromString (toFilePath file)
     <> "\n\n"
-    <> "The exception encountered was:\n\n"
-    <> fromString (show e)
-  display (HpackExeException fp dir e) =
+    <> "The error encountered was:\n\n"
+    <> fromString err
+  display (HpackExeException fp dir err) =
     "Error: [S-720]\n"
     <> "Failed to generate a Cabal file using the Hpack executable:\n"
     <> fromString fp
     <> "in directory: "
     <> fromString (toFilePath dir)
     <> "\n\n"
-    <> "The exception encountered was:\n\n"
-    <> fromString (show e)
+    <> "The error encountered was:\n\n"
+    <> fromString (show err)
 
 data FuzzyResults
   = FRNameNotFound ![PackageName]

diff --git a/stack-cabal-3.4.yaml b/stack-cabal-3.4.yaml
@@ -4,6 +4,7 @@ resolver: lts-18.28
 extra-deps:
 # lts-18.28 provides Cabal-3.2.1.0
 - Cabal-3.4.0.0
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 
 ghc-options:
    "$locals": -fhide-source-paths
diff --git a/stack-cabal-3.4.yaml.lock b/stack-cabal-3.4.yaml.lock
diff --git a/stack-ghc-8.6.5.yaml b/stack-ghc-8.6.5.yaml
@@ -3,7 +3,7 @@ resolver: lts-14.27
 
 extra-deps:
 - Cabal-3.0.0.0
-- hpack-0.35.0
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 - casa-client-0.0.1
 - casa-types-0.0.1
 

diff --git a/stack-ghc-8.6.5.yaml.lock b/stack-ghc-8.6.5.yaml.lock
diff --git a/stack-ghc-8.8.4.yaml b/stack-ghc-8.8.4.yaml
@@ -3,7 +3,7 @@ resolver: lts-16.31
 
 extra-deps:
 - Cabal-3.0.0.0
-- hpack-0.35.0
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 
 ghc-options:
    "$locals": -fhide-source-paths
diff --git a/stack-ghc-8.8.4.yaml.lock b/stack-ghc-8.8.4.yaml.lock
diff --git a/stack-ghc-9.2.5.yaml b/stack-ghc-9.2.5.yaml
@@ -1,5 +1,8 @@
 # GHC 9.2.5
-resolver: lts-20.0
+resolver: lts-20.4
+
+extra-deps:
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 
 ghc-options:
    "$locals": -fhide-source-paths
diff --git a/stack-ghc-9.2.5.yaml.lock b/stack-ghc-9.2.5.yaml.lock
diff --git a/stack-ghc-9.4.3.yaml b/stack-ghc-9.4.3.yaml
@@ -2,7 +2,8 @@
 resolver: nightly-2022-12-09
 
 extra-deps:
-- hackage-security-0.6.2.3
+- hackage-security-0.6.2.3@sha256:64fc60f3f4d02047c54956b6976c0e4fc72722891c6875ab10d95359bc00355a,12649
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 
 flags:
   mintty:

diff --git a/stack-ghc-9.4.3.yaml.lock b/stack-ghc-9.4.3.yaml.lock
diff --git a/stack-persistent-2.11.yaml b/stack-persistent-2.11.yaml
@@ -2,6 +2,7 @@
 resolver: lts-16.31
 
 extra-deps:
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 - persistent-2.11.0.4@rev:0
 - persistent-sqlite-2.11.1.0@rev:0
 - persistent-template-2.9.1.0@rev:0

diff --git a/stack-persistent-2.11.yaml.lock b/stack-persistent-2.11.yaml.lock
diff --git a/stack.yaml b/stack.yaml
@@ -2,7 +2,7 @@
 resolver: lts-18.28
 
 extra-deps:
-- hpack-0.35.0
+- hpack-0.35.1@sha256:ef816234cbc7b52b0a6c55f7e904b6bc5292b8dd8f2d81ffcbcbc69ab80d75e5,4762
 
 ghc-options:
    "$locals": -fhide-source-paths
diff --git a/stack.yaml.lock b/stack.yaml.lock