Fix sol#530 Introduce HpackException type, for Hpack exceptions

The `Exception` instance for `HpackException` preserves the existing error messages of all existing Hpack exceptions in the `displayException` functions.

Updates tests accordingly. Some tests use `shouldSatisfy` rather than `shouldReturn` as `HpackException` cannot be an instance of `Eq`.

Moves `ProgramName` from `Hpack.Config` to new module `Hpack.ProgramName` because `Hpack.Exception` needs to import the type and `Hpack.Config` now imports `Hpack.Exception`.

Also bumps Hpack's `stack.yaml` to use lts-20.0 (GHC 9.2.5) rather than lts-15.11 (GHC 8.8.3).

src/Hpack.hs

@@ -20,6 +20,7 @@ module Hpack (
 -- * Running Hpack
 , hpack
 , hpackResult
+, hpackResultWithException
 , printResult
 , Result(..)
 , Status(..)
@@ -44,6 +45,7 @@ module Hpack (
 
 import           Imports
 
+import           Control.Exception (throwIO)
 import           Data.Version (Version)
 import qualified Data.Version as Version
 import           System.FilePath
@@ -56,6 +58,7 @@ import           Data.Maybe
 import           Paths_hpack (version)
 import           Hpack.Options
 import           Hpack.Config
+import           Hpack.Exception (HpackException)
 import           Hpack.Render
 import           Hpack.Util
 import           Hpack.Utf8 as Utf8
@@ -131,7 +134,7 @@ setProgramName :: ProgramName -> Options -> Options
 setProgramName name options@Options{..} =
   options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsProgramName = name}}
 
-setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Options
+setDecode :: (FilePath -> IO (Either HpackException ([String], Value))) -> Options -> Options
 setDecode decode options@Options{..} =
   options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}}
 
@@ -188,28 +191,38 @@ calculateHash :: CabalFile -> Hash
 calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body)
 
 hpackResult :: Options -> IO Result
-hpackResult = hpackResultWithVersion version
-
-hpackResultWithVersion :: Version -> Options -> IO Result
-hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = do
-  DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return
-  mExistingCabalFile <- readCabalFile cabalFileName
-  let
-    newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg
-
-    status = case force of
-      Force -> Generated
-      NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile
-
-  case status of
-    Generated -> writeCabalFile options toStdout cabalFileName newCabalFile
-    _ -> return ()
-
-  return Result {
-    resultWarnings = warnings
-  , resultCabalFile = cabalFileName
-  , resultStatus = status
-  }
+hpackResult opts = either throwIO return =<< hpackResultWithException opts
+
+hpackResultWithException :: Options -> IO (Either HpackException Result)
+hpackResultWithException = hpackResultWithVersion version
+
+hpackResultWithVersion :: Version
+                       -> Options
+                       -> IO (Either HpackException Result)
+hpackResultWithVersion
+  v (Options options force generateHashStrategy toStdout) = do
+    eres <- readPackageConfig options
+    case eres of
+      Right
+        (DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings) -> do
+          mExistingCabalFile <- readCabalFile cabalFileName
+          let newCabalFile = makeCabalFile
+                generateHashStrategy mExistingCabalFile cabalVersion v pkg
+              status = case force of
+                Force -> Generated
+                NoForce ->
+                  maybe Generated (mkStatus newCabalFile) mExistingCabalFile
+          case status of
+            Generated ->
+              writeCabalFile options toStdout cabalFileName newCabalFile
+            _ -> return ()
+          return $ Right $
+            Result {
+                resultWarnings = warnings
+              , resultCabalFile = cabalFileName
+              , resultStatus = status
+              }
+      Left e -> return $ Left e
 
 writeCabalFile :: DecodeOptions -> Bool -> FilePath -> CabalFile -> IO ()
 writeCabalFile options toStdout name cabalFile = do

src/Hpack/Config.hs

@@ -112,6 +112,8 @@ import           Data.Aeson.Config.Types
 import           Data.Aeson.Config.FromValue hiding (decodeValue)
 import qualified Data.Aeson.Config.FromValue as Config
 
+import           Hpack.Exception (HpackException (..))
+import           Hpack.ProgramName (ProgramName (..))
 import           Hpack.Syntax.Defaults
 import           Hpack.Util hiding (expandGlobs)
 import qualified Hpack.Util as Util
@@ -631,7 +633,7 @@ type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSource
 instance FromValue ParsePackageConfig
 
 type Warnings m = WriterT [String] m
-type Errors = ExceptT String
+type Errors = ExceptT HpackException
 
 decodeYaml :: FromValue a => ProgramName -> FilePath -> Warnings (Errors IO) a
 decodeYaml programName file = do
@@ -643,15 +645,9 @@ data DecodeOptions = DecodeOptions {
   decodeOptionsProgramName :: ProgramName
 , decodeOptionsTarget :: FilePath
 , decodeOptionsUserDataDir :: Maybe FilePath
-, decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value))
+, decodeOptionsDecode :: FilePath -> IO (Either HpackException ([String], Value))
 }
 
-newtype ProgramName = ProgramName String
-  deriving (Eq, Show)
-
-instance IsString ProgramName where
-  fromString = ProgramName
-
 defaultDecodeOptions :: DecodeOptions
 defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml
 
@@ -662,7 +658,7 @@ data DecodeResult = DecodeResult {
 , decodeResultWarnings :: [String]
 } deriving (Eq, Show)
 
-readPackageConfig :: DecodeOptions -> IO (Either String DecodeResult)
+readPackageConfig :: DecodeOptions -> IO (Either HpackException DecodeResult)
 readPackageConfig (DecodeOptions programName file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do
   (warnings, value) <- lift . ExceptT $ readValue file
   tell warnings
@@ -891,11 +887,11 @@ sectionAll :: (Semigroup b, Monoid b) => (Section a -> b) -> Section a -> b
 sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionConditionals sect)
 
 decodeValue :: FromValue a => ProgramName -> FilePath -> Value -> Warnings (Errors IO) a
-decodeValue (ProgramName programName) file value = do
-  (r, unknown, deprecated) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value)
+decodeValue programName file value = do
+  (r, unknown, deprecated) <- lift . ExceptT . return $ first (DecodeValueException file) (Config.decodeValue value)
   case r of
     UnsupportedSpecVersion v -> do
-      lift $ throwE ("The file " ++ file ++ " requires version " ++ showVersion v ++ " of the Hpack package specification, however this version of " ++ programName ++ " only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of " ++ programName ++ " may resolve this issue.")
+      lift $ throwE $ HpackVersionUnsupported programName file v Hpack.version
     SupportedSpecVersion a -> do
       tell (map formatUnknownField unknown)
       tell (map formatDeprecatedField deprecated)
@@ -1133,7 +1129,7 @@ expandDefaults programName userDataDir = expand []
       canonic <- liftIO $ canonicalizePath file
       let seen_ = canonic : seen
       when (canonic `elem` seen) $ do
-        throwE ("cycle in defaults (" ++ intercalate " -> " (reverse seen_) ++ ")")
+        throwE $ CycleInDefaultsException $ reverse seen_
       return seen_
 
 toExecutableMap :: Monad m => String -> Maybe (Map String a) -> Maybe a -> Warnings m (Maybe (Map String a))

src/Hpack/Defaults.hs

@@ -18,10 +18,10 @@ import           Network.HTTP.Types
 import           Network.HTTP.Client
 import           Network.HTTP.Client.TLS
 import qualified Data.ByteString.Lazy as LB
-import qualified Data.ByteString.Char8 as B
 import           System.FilePath
 import           System.Directory
 
+import           Hpack.Exception (HpackException (..))
 import           Hpack.Syntax.Defaults
 
 type URL = String
@@ -33,8 +33,8 @@ defaultsCachePath :: FilePath -> Github -> FilePath
 defaultsCachePath dir Github{..} = joinPath $
   dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath
 
-data Result = Found | NotFound | Failed String
-  deriving (Eq, Show)
+data Result = Found | NotFound | Failed HpackException
+  deriving Show
 
 get :: URL -> FilePath -> IO Result
 get url file = do
@@ -47,27 +47,22 @@ get url file = do
       LB.writeFile file (responseBody response)
       return Found
     Status 404 _ -> return NotFound
-    status -> return (Failed $ "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")")
+    status -> return (Failed $ DownloadingFileFailed url status)
 
-formatStatus :: Status -> String
-formatStatus (Status code message) = show code ++ " " ++ B.unpack message
-
-ensure :: FilePath -> FilePath -> Defaults -> IO (Either String FilePath)
+ensure :: FilePath -> FilePath -> Defaults -> IO (Either HpackException FilePath)
 ensure userDataDir dir = \ case
   DefaultsGithub defaults -> do
     let
       url = defaultsUrl defaults
       file = defaultsCachePath userDataDir defaults
     ensureFile file url >>= \ case
       Found -> return (Right file)
-      NotFound -> return (Left $ notFound url)
+      NotFound -> return (Left $ DefaultsFileUrlNotFound url)
       Failed err -> return (Left err)
   DefaultsLocal (Local ((dir </>) -> file)) -> do
     doesFileExist file >>= \ case
       True -> return (Right file)
-      False -> return (Left $ notFound file)
-  where
-    notFound file = "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!"
+      False -> return (Left $ DefaultsFileNotFound file)
 
 ensureFile :: FilePath -> URL -> IO Result
 ensureFile file url = do

src/Hpack/Exception.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Exceptions thrown by the Hpack library.
+module Hpack.Exception
+  ( HpackException (..)
+    -- * Re-export of types used in Hpack exceptions
+  , FilePath
+  , ParseException (..)
+  , ProgramName (..)
+  , Status (..)
+  , Version (..)
+  , URL
+  , YamlException (..)
+  , YamlMark (..)
+  ) where
+
+import           Control.Exception (Exception (..))
+import qualified Data.ByteString.Char8 as B
+import           Data.List (intercalate)
+import           Data.Typeable (Typeable)
+import           Data.Version (Version (..), showVersion)
+import           Data.Yaml
+                   (ParseException (..), YamlException (..), YamlMark (..))
+import           Network.HTTP.Types.Status (Status (..))
+
+import           Hpack.ProgramName (ProgramName (..))
+
+-- | Type synonyn representing URLs.
+type URL = String
+
+-- | Type representing exceptions thrown by functions exported by the modules of
+-- the Hpack library.
+data HpackException
+  = CycleInDefaultsException ![FilePath]
+  | DecodeValueException !FilePath !String
+  | DefaultsFileNotFound !FilePath
+  | DefaultsFileUrlNotFound !URL
+  | DownloadingFileFailed !URL !Status
+  | HpackParseException !FilePath !ParseException
+  | HpackVersionUnsupported !ProgramName !FilePath !Version !Version
+  deriving (Show, Typeable)
+
+instance Exception HpackException where
+  displayException (CycleInDefaultsException files) =
+    "cycle in defaults (" ++ intercalate " -> " files ++ ")"
+  displayException (DecodeValueException file s) =
+    file ++ ": " ++ s
+  displayException (DefaultsFileNotFound file) =
+    "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!"
+  displayException (DefaultsFileUrlNotFound url) =
+    "Invalid value for \"defaults\"! File " ++ url ++ " does not exist!"
+  displayException (DownloadingFileFailed url status) =
+    "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")"
+   where
+    formatStatus :: Status -> String
+    formatStatus (Status code message) = show code ++ " " ++ B.unpack message
+  displayException (HpackParseException file e) = file ++ case e of
+    AesonException s -> ": " ++ s
+    InvalidYaml (Just (YamlException s)) -> ": " ++ s
+    InvalidYaml (Just (YamlParseException{..})) ->
+      let YamlMark{..} = yamlProblemMark
+      in  ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++
+            yamlProblem ++ " " ++ yamlContext
+    err -> ": " ++ displayException err
+  displayException
+    (HpackVersionUnsupported (ProgramName progName) file wanted supported) =
+      "The file " ++ file ++ " requires version " ++ showVersion wanted ++
+      " of the Hpack package specification, however this version of " ++
+      progName ++ " only supports versions up to " ++ showVersion supported ++
+      ". Upgrading to the latest version of " ++ progName ++
+      " may resolve this issue."

src/Hpack/ProgramName.hs

@@ -0,0 +1,12 @@
+module Hpack.ProgramName
+  ( ProgramName (..)
+  ) where
+
+import Data.String (IsString (..))
+
+-- | Type representing the names of programs using the Hpack library.
+newtype ProgramName = ProgramName String
+  deriving (Eq, Show)
+
+instance IsString ProgramName where
+  fromString = ProgramName

src/Hpack/Yaml.hs

@@ -25,18 +25,13 @@ import           Data.Yaml.Internal (Warning(..))
 import           Data.Aeson.Config.FromValue
 import           Data.Aeson.Config.Parser (fromAesonPath, formatPath)
 
+import           Hpack.Exception (HpackException (..))
+
 formatWarning :: FilePath -> Warning -> String
 formatWarning file = \ case
   DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path)
 
-decodeYaml :: FilePath -> IO (Either String ([String], Value))
+decodeYaml :: FilePath -> IO (Either HpackException ([String], Value))
 decodeYaml file = do
   result <- decodeFileWithWarnings file
-  return $ either (Left . errToString) (Right . first (map $ formatWarning file)) result
-  where
-    errToString err = file ++ case err of
-      AesonException e -> ": " ++ e
-      InvalidYaml (Just (YamlException s)) -> ": " ++ s
-      InvalidYaml (Just (YamlParseException{..})) -> ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext
-        where YamlMark{..} = yamlProblemMark
-      _ -> ": " ++ show err
+  return $ either (Left . HpackParseException file) (Right . first (map $ formatWarning file)) result

stack.yaml

@@ -1 +1 @@
-resolver: lts-15.11
+resolver: lts-20.0

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 494638
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/11.yaml
-    sha256: 5747328cdcbb8fe9c96fc048b5566167c80dd176a41b52d3b363058e3cc1dc5d
-  original: lts-15.11
+    sha256: a2cbcd2f37010a64c4ef74c21fd7e55982a07b49840d2bed306f9bac9981a9c3
+    size: 648420
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/0.yaml
+  original: lts-20.0