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 11, 2022 · ec2048a · ec2048a
1 parent 9254dec
commit ec2048a
Show file tree

Hide file tree

Showing 16 changed files with 127 additions and 31 deletions.
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
@@ -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-cabal-3.4.yaml b/stack-cabal-3.4.yaml
@@ -4,6 +4,9 @@ resolver: lts-18.28
 extra-deps:
 # lts-18.28 provides Cabal-3.2.1.0
 - Cabal-3.4.0.0
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
 
 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,10 @@ resolver: lts-14.27
 
 extra-deps:
 - Cabal-3.0.0.0
-- hpack-0.35.0
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
+# - hpack-0.35.0
 - 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,10 @@ resolver: lts-16.31
 
 extra-deps:
 - Cabal-3.0.0.0
-- hpack-0.35.0
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
+# - hpack-0.35.0
 
 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,10 @@
 # GHC 9.2.5
 resolver: lts-20.0
 
+extra-deps:
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
+
 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.2.yaml b/stack-ghc-9.4.2.yaml
@@ -70,7 +70,10 @@ extra-deps:
 - haskell-lexer-1.1@sha256:9e0a7633f6bdb59004c6f3144ebfad1edb9e440fc6a94215c3a1d11bcd8656ef,915
 - hedgehog-1.2@sha256:b7abfb2db7638c50eb8ee76186ee627ea7ab187220e4ea966b5738a1bde3b22a,4496
 - hourglass-0.2.12@sha256:e083f5e030dfebe432e30a9c0fa07a99a54eac992f622442646be561fd7a44e8,3085
-- hpack-0.35.0@sha256:8cd6146fae269390f41dc7237ebd2c479074d4163806d349a41f5a7751d6cea5,4726
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
+# - hpack-0.35.0@sha256:8cd6146fae269390f41dc7237ebd2c479074d4163806d349a41f5a7751d6cea5,4726
 - hspec-2.10.1@sha256:a0fefe1a9e013de8a849120393a3ffcd734590ed9bc8875880d041e6968261be,1712
 - hspec-core-2.10.1@sha256:7dd95622fd3423ef37268495eb5dfb59e21bfb21ad668a5aee82be36ccca2510,6617
 - hspec-discover-2.10.1@sha256:c34af877176d1c6c8fc580fd100c5d6c3eb087899438777d18ff615fb9cb0f3c,2166

diff --git a/stack-ghc-9.4.2.yaml.lock b/stack-ghc-9.4.2.yaml.lock
diff --git a/stack-persistent-2.11.yaml b/stack-persistent-2.11.yaml
@@ -2,6 +2,9 @@
 resolver: lts-16.31
 
 extra-deps:
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
 - 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,9 @@
 resolver: lts-18.28
 
 extra-deps:
-- hpack-0.35.0
+# Modified hpack
+- git: https://github.com/sol/hpack
+  commit: beef09faa9fac949be56766a6de788d4cb948115
 
 ghc-options:
    "$locals": -fhide-source-paths
diff --git a/stack.yaml.lock b/stack.yaml.lock