Fix Hpack #530

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).
commercialhaskell · Dec 7, 2022 · 155c16c · 155c16c
1 parent 4066718
commit 155c16c
Show file tree

Hide file tree

Showing 3 changed files with 23 additions and 10 deletions.
diff --git a/src/Pantry.hs b/src/Pantry.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
 -- | Content addressable Haskell package management, providing for
 -- secure, reproducible acquisition of Haskell package contents and
 -- metadata.
@@ -227,6 +228,16 @@ import Pantry.HTTP
 import Data.Char (isHexDigit)
 import Data.Time (getCurrentTime, diffUTCTime)
 
+import Data.Yaml.Include (decodeFileWithWarnings)
+import Hpack.Yaml (formatWarning)
+import Hpack.Error (renderHpackError)
+
+decodeYaml :: FilePath -> IO (Either String ([String], Value))
+decodeYaml file = do
+  bimap displayException (first formatWarnings) <$> decodeFileWithWarnings file
+  where
+    formatWarnings = map (formatWarning file)
+
 -- | Create a new 'PantryConfig' with the given settings.
 --
 -- For something easier to use in simple cases, see 'runPantryApp'.
@@ -741,15 +752,16 @@ hpack progName pkgDir = do
 
         he <- view $ pantryConfigL.to pcHpackExecutable
         case he of
-            HpackBundled -> do
-                r <- catchAny
+            HpackBundled ->
                        ( liftIO
-                           $ Hpack.hpackResult
+                           $ Hpack.hpackResultWithError
                            $ mHpackProgName
+                           $ Hpack.setDecode decodeYaml
                            $ Hpack.setTarget
                                (toFilePath hpackFile) Hpack.defaultOptions
-                       )
-                       ( throwIO . HpackLibraryException hpackFile )
+                       ) >>= \ case
+              Left err -> throwIO (HpackLibraryException hpackFile $ renderHpackError (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
@@ -1279,13 +1279,13 @@ instance Display PantryException where
     "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)
+    <> "The error encountered was:\n\n"
+    <> fromString err
   display (HpackExeException fp dir e) =
     "Error: [S-720]\n"
     <> "Failed to generate a Cabal file using the Hpack executable:\n"

diff --git a/stack.yaml b/stack.yaml
@@ -2,7 +2,8 @@
 resolver: lts-18.28
 
 extra-deps:
-- hpack-0.35.0
+- git: https://github.com/sol/hpack
+  commit: 1ecc4158bdfc03609c88d0b1908fa9f41fdfbf5c
 
 ghc-options:
    "$locals": -fhide-source-paths