wip

src/Hpack.hs

@@ -20,13 +20,13 @@ module Hpack (
 -- * Running Hpack
 , hpack
 , hpackResult
+, hpackResultWithError
 , printResult
 , Result(..)
 , Status(..)
 
 -- * Options
 , defaultOptions
-, setProgramName
 , setTarget
 , setDecode
 , getOptions
@@ -56,14 +56,15 @@ import           Data.Maybe
 import           Paths_hpack (version)
 import           Hpack.Options
 import           Hpack.Config
+import           Hpack.Error (HpackError, renderHpackError, hpackProgName)
 import           Hpack.Render
 import           Hpack.Util
 import           Hpack.Utf8 as Utf8
 import           Hpack.CabalFile
 
 programVersion :: Maybe Version -> String
-programVersion Nothing = "hpack"
-programVersion (Just v) = "hpack version " ++ Version.showVersion v
+programVersion Nothing = unProgramName hpackProgName
+programVersion (Just v) = unProgramName hpackProgName ++ " version " ++ Version.showVersion v
 
 header :: FilePath -> Maybe Version -> (Maybe Hash) -> [String]
 header p v hash = [
@@ -127,10 +128,6 @@ setTarget :: FilePath -> Options -> Options
 setTarget target options@Options{..} =
   options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsTarget = target}}
 
-setProgramName :: ProgramName -> Options -> Options
-setProgramName name options@Options{..} =
-  options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsProgramName = name}}
-
 setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Options
 setDecode decode options@Options{..} =
   options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}}
@@ -188,28 +185,34 @@ calculateHash :: CabalFile -> Hash
 calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body)
 
 hpackResult :: Options -> IO Result
-hpackResult = hpackResultWithVersion version
+hpackResult opts = hpackResultWithError opts >>= either (die . renderHpackError hpackProgName) return
+
+hpackResultWithError :: Options -> IO (Either HpackError Result)
+hpackResultWithError = hpackResultWithVersion version
 
-hpackResultWithVersion :: Version -> Options -> IO Result
+hpackResultWithVersion :: Version -> Options -> IO (Either HpackError 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
-  }
+  eres <- readPackageConfigWithError 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

@@ -33,6 +33,7 @@ module Hpack.Config (
 , packageConfig
 , DecodeResult(..)
 , readPackageConfig
+, readPackageConfigWithError
 
 , renamePackage
 , packageDependencies
@@ -112,6 +113,7 @@ import           Data.Aeson.Config.Types
 import           Data.Aeson.Config.FromValue hiding (decodeValue)
 import qualified Data.Aeson.Config.FromValue as Config
 
+import           Hpack.Error
 import           Hpack.Syntax.Defaults
 import           Hpack.Util hiding (expandGlobs)
 import qualified Hpack.Util as Util
@@ -631,11 +633,11 @@ type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSource
 instance FromValue ParsePackageConfig
 
 type Warnings m = WriterT [String] m
-type Errors = ExceptT (ProgramName -> String)
+type Errors = ExceptT HpackError
 
 decodeYaml :: FromValue a => FilePath -> Warnings (Errors IO) a
 decodeYaml file = do
-  (warnings, a) <- lift (ExceptT $ first const <$> Yaml.decodeYaml file)
+  (warnings, a) <- lift (ExceptT $ first HpackParseYamlException <$> Yaml.decodeYaml file)
   tell warnings
   decodeValue file a
 
@@ -646,12 +648,6 @@ data DecodeOptions = DecodeOptions {
 , decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value))
 }
 
-newtype ProgramName = ProgramName String
-  deriving (Eq, Show)
-
-instance IsString ProgramName where
-  fromString = ProgramName
-
 defaultDecodeOptions :: DecodeOptions
 defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml
 
@@ -663,12 +659,15 @@ data DecodeResult = DecodeResult {
 } deriving (Eq, Show)
 
 readPackageConfig :: DecodeOptions -> IO (Either String DecodeResult)
-readPackageConfig (DecodeOptions programName file mUserDataDir readValue) = fmap (first ($ programName)) . runExceptT $ fmap addCabalFile . runWriterT $ do
-  (warnings, value) <- lift . ExceptT $ first const <$> readValue file
+readPackageConfig options = first (renderHpackError $ decodeOptionsProgramName options) <$> readPackageConfigWithError options
+
+readPackageConfigWithError :: DecodeOptions -> IO (Either HpackError DecodeResult)
+readPackageConfigWithError (DecodeOptions _ file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do
+  (warnings, value) <- lift . ExceptT $ first HpackParseYamlException <$> readValue file
   tell warnings
   config <- decodeValue file value
   dir <- liftIO $ takeDirectory <$> canonicalizePath file
-  userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir
+  userDataDir <- liftIO $ maybe (getAppUserDataDirectory $ unProgramName hpackProgName) return mUserDataDir
   toPackage userDataDir dir config
   where
     addCabalFile :: ((Package, String), [String]) -> DecodeResult
@@ -892,10 +891,10 @@ sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionCondition
 
 decodeValue :: FromValue a => FilePath -> Value -> Warnings (Errors IO) a
 decodeValue file value = do
-  (r, unknown, deprecated) <- lift . ExceptT . return $ first (const . (prefix ++)) (Config.decodeValue value)
+  (r, unknown, deprecated) <- lift . ExceptT . return $ first (DecodeValueError file) (Config.decodeValue value)
   case r of
     UnsupportedSpecVersion v -> do
-      lift $ throwE $ \ (ProgramName programName) -> "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 file v Hpack.version
     SupportedSpecVersion a -> do
       tell (map formatUnknownField unknown)
       tell (map formatDeprecatedField deprecated)
@@ -1119,7 +1118,7 @@ expandDefaults userDataDir = expand []
       -> Defaults
       -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)
     get seen dir defaults = do
-      file <- lift $ ExceptT $ first const <$> (ensure userDataDir dir defaults)
+      file <- lift $ ExceptT (ensure userDataDir dir defaults)
       seen_ <- lift (checkCycle seen file)
       let dir_ = takeDirectory file
       decodeYaml file >>= expand seen_ dir_
@@ -1129,7 +1128,7 @@ expandDefaults userDataDir = expand []
       canonic <- liftIO $ canonicalizePath file
       let seen_ = canonic : seen
       when (canonic `elem` seen) $ do
-        throwE . const $ "cycle in defaults (" ++ intercalate " -> " (reverse seen_) ++ ")"
+        throwE $ CycleInDefaultsError $ 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.Error (HpackError (..))
 import           Hpack.Syntax.Defaults
 
 type URL = String
@@ -33,7 +33,7 @@ defaultsCachePath :: FilePath -> Github -> FilePath
 defaultsCachePath dir Github{..} = joinPath $
   dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath
 
-data Result = Found | NotFound | Failed String
+data Result = Found | NotFound | Failed URL Status
   deriving (Eq, Show)
 
 get :: URL -> FilePath -> IO Result
@@ -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 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 HpackError 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)
-      Failed err -> return (Left err)
+      NotFound -> return (Left $ DefaultsFileUrlNotFound url)
+      Failed url' status -> return (Left $ DownloadingFileFailed url' status)
   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/Error.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE LambdaCase #-}
+module Hpack.Error (
+  HpackError (..)
+, hpackProgName
+, renderHpackError
+, ProgramName (..)
+, formatStatus
+  -- * Re-export of types used in Hpack errors
+, Status (..)
+, URL
+) where
+
+import qualified Data.ByteString.Char8 as B
+import           Data.List (intercalate)
+import           Data.String (IsString (..))
+import           Data.Version (Version (..), showVersion)
+import           Network.HTTP.Types.Status (Status (..))
+
+type URL = String
+
+data HpackError =
+    HpackVersionUnsupported !FilePath !Version !Version
+  | DefaultsFileNotFound !FilePath
+  | DefaultsFileUrlNotFound !URL
+  | DownloadingFileFailed !URL !Status
+  | CycleInDefaultsError ![FilePath]
+  | HpackParseYamlException !String
+  | DecodeValueError !FilePath !String
+  deriving (Eq, Show)
+
+renderHpackError :: ProgramName -> HpackError -> String
+renderHpackError (ProgramName progName) = \ case
+  HpackVersionUnsupported 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."
+  DefaultsFileNotFound file -> "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!"
+  DefaultsFileUrlNotFound url -> "Invalid value for \"defaults\"! File " ++ url ++ " does not exist!"
+  DownloadingFileFailed url status -> "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")"
+  CycleInDefaultsError files -> "cycle in defaults (" ++ intercalate " -> " files ++ ")"
+  HpackParseYamlException s -> s
+  DecodeValueError file s -> renderFileMsg file s
+
+formatStatus :: Status -> String
+formatStatus (Status code message) = show code ++ " " ++ B.unpack message
+
+renderFileMsg :: FilePath -> String -> String
+renderFileMsg file s = file ++ ": " ++ s
+
+hpackProgName :: ProgramName
+hpackProgName = ProgramName "hpack"
+
+newtype ProgramName = ProgramName {unProgramName :: String}
+  deriving (Eq, Show)
+
+instance IsString ProgramName where
+  fromString = ProgramName

test/Hpack/DefaultsSpec.hs

@@ -4,6 +4,7 @@ module Hpack.DefaultsSpec (spec) where
 import           Helper
 import           System.Directory
 
+import           Hpack.Error (HpackError (..))
 import           Hpack.Syntax.Defaults
 import           Hpack.Defaults
 
@@ -12,7 +13,7 @@ spec = do
   describe "ensure" $ do
     it "fails when local file does not exist" $ do
       cwd <- getCurrentDirectory
-      let expected = Left $ "Invalid value for \"defaults\"! File " ++ (cwd </> "foo") ++ " does not exist!"
+      let expected = Left (DefaultsFileNotFound $ cwd </> "foo")
       ensure undefined cwd (DefaultsLocal $ Local "foo") `shouldReturn` expected
 
   describe "ensureFile" $ do

test/HpackSpec.hs

@@ -4,11 +4,13 @@ import           Helper
 
 import           Prelude hiding (readFile)
 import qualified Prelude as Prelude
+import           System.Exit (die)
 
 import           Control.DeepSeq
 
 import           Hpack.Config
 import           Hpack.CabalFile
+import           Hpack.Error (hpackProgName, renderHpackError)
 import           Hpack hiding (hpack)
 
 readFile :: FilePath -> IO String
@@ -55,7 +57,7 @@ spec = do
     let
       file = "foo.cabal"
 
-      hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions
+      hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions >>= either (die . renderHpackError hpackProgName) return
       hpackWithStrategy strategy = hpackResult defaultOptions { optionsGenerateHashStrategy = strategy }
       hpackForce = hpackResult defaultOptions {optionsForce = Force}