From be9b7fa56165b9fc8c8cc8804554ae39c0a67ef0 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 5 Dec 2022 20:53:35 +0700 Subject: [PATCH] Add HpackError type --- hpack.cabal | 4 +- package.yaml | 1 + src/Hpack.hs | 87 +++++++++++++++++++++++++++++--------- src/Hpack/Config.hs | 82 ++++++++++++++++++----------------- src/Hpack/Defaults.hs | 22 ++++------ src/Hpack/Error.hs | 59 ++++++++++++++++++++++++++ src/Hpack/Yaml.hs | 32 ++++++++------ src/Imports.hs | 1 + test/Hpack/DefaultsSpec.hs | 3 +- test/HpackSpec.hs | 5 ++- 10 files changed, 209 insertions(+), 87 deletions(-) create mode 100644 src/Hpack/Error.hs diff --git a/hpack.cabal b/hpack.cabal index 367a9e96..37839267 100644 --- a/hpack.cabal +++ b/hpack.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -54,6 +54,7 @@ library Hpack.Config Hpack.Render Hpack.Yaml + Hpack.Error other-modules: Data.Aeson.Config.FromValue Data.Aeson.Config.Key @@ -188,6 +189,7 @@ test-suite spec Hpack.CabalFile Hpack.Config Hpack.Defaults + Hpack.Error Hpack.Haskell Hpack.License Hpack.Module diff --git a/package.yaml b/package.yaml index 00749110..4aab70c5 100644 --- a/package.yaml +++ b/package.yaml @@ -41,6 +41,7 @@ library: - Hpack.Config - Hpack.Render - Hpack.Yaml + - Hpack.Error executable: main: Main.hs diff --git a/src/Hpack.hs b/src/Hpack.hs index 30d861c6..6f995dde 100644 --- a/src/Hpack.hs +++ b/src/Hpack.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Hpack ( -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into -- other tools. It is not meant for general use by end users. The following @@ -20,6 +21,7 @@ module Hpack ( -- * Running Hpack , hpack , hpackResult +, hpackResultWithError , printResult , Result(..) , Status(..) @@ -29,6 +31,7 @@ module Hpack ( , setProgramName , setTarget , setDecode +, setFormatYamlParseError , getOptions , Verbose(..) , Options(..) @@ -56,10 +59,12 @@ import Data.Maybe import Paths_hpack (version) import Hpack.Options import Hpack.Config +import Hpack.Error (HpackError, formatHpackError) import Hpack.Render import Hpack.Util import Hpack.Utf8 as Utf8 import Hpack.CabalFile +import qualified Data.Yaml as Yaml programVersion :: Maybe Version -> String programVersion Nothing = "hpack" @@ -135,6 +140,41 @@ setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Op setDecode decode options@Options{..} = options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}} +-- | This is used to format any `Yaml.ParseException`s encountered during +-- decoding of . +-- +-- Note that: +-- +-- 1. This is not used to format `Yaml.ParseException`s encountered during +-- decoding of the main @package.yaml@. To customize this you have to set a +-- custom decode function. +-- +-- 2. Some of the constructors of `Yaml.ParseException` are never produced by +-- Hpack (e.g. `Yaml.AesonException` as Hpack uses it's own mechanism to decode +-- `Yaml.Value`s). +-- +-- Example: +-- +-- @ +-- example :: IO (Either `HpackError` `Result`) +-- example = `hpackResultWithError` options +-- where +-- options :: `Options` +-- options = setCustomYamlParseErrorFormat format `defaultOptions` +-- +-- format :: FilePath -> `Yaml.ParseException` -> String +-- format file err = file ++ ": " ++ displayException err +-- +-- setCustomYamlParseErrorFormat :: (FilePath -> `Yaml.ParseException` -> String) -> `Options` -> `Options` +-- setCustomYamlParseErrorFormat format = `setDecode` decode >>> `setFormatYamlParseError` format +-- where +-- decode :: FilePath -> IO (Either String ([String], Value)) +-- decode file = first (format file) \<$> `Hpack.Yaml.decodeYamlWithParseError` file +-- @ +setFormatYamlParseError :: (FilePath -> Yaml.ParseException -> String) -> Options -> Options +setFormatYamlParseError formatYamlParseError options@Options{..} = + options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsFormatYamlParseError = formatYamlParseError}} + data Result = Result { resultWarnings :: [String] , resultCabalFile :: String @@ -188,28 +228,35 @@ calculateHash :: CabalFile -> Hash calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body) hpackResult :: Options -> IO Result -hpackResult = hpackResultWithVersion version +hpackResult opts = hpackResultWithError opts >>= either (die . formatHpackError programName) return + where + programName = decodeOptionsProgramName (optionsDecodeOptions opts) + +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 - } + readPackageConfigWithError options >>= \ case + 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 err -> return $ Left err writeCabalFile :: DecodeOptions -> Bool -> FilePath -> CabalFile -> IO () writeCabalFile options toStdout name cabalFile = do diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs index 5c165011..6fbf5fe8 100644 --- a/src/Hpack/Config.hs +++ b/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,14 +633,16 @@ type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSource instance FromValue ParsePackageConfig type Warnings m = WriterT [String] m -type Errors = ExceptT (ProgramName -> String) +type Errors = ExceptT HpackError -liftEither :: IO (Either String a) -> Warnings (Errors IO) a -liftEither = lift . ExceptT . fmap (first const) +liftEither :: IO (Either HpackError a) -> Warnings (Errors IO) a +liftEither = lift . ExceptT -decodeYaml :: FromValue a => FilePath -> Warnings (Errors IO) a -decodeYaml file = do - (warnings, a) <- liftEither $ Yaml.decodeYaml file +type FormatYamlParseError = FilePath -> Yaml.ParseException -> String + +decodeYaml :: FromValue a => FormatYamlParseError -> FilePath -> Warnings (Errors IO) a +decodeYaml formatYamlParseError file = do + (warnings, a) <- liftEither $ first (ParseError . formatYamlParseError file) <$> Yaml.decodeYamlWithParseError file tell warnings decodeValue file a @@ -647,16 +651,11 @@ data DecodeOptions = DecodeOptions { , decodeOptionsTarget :: FilePath , decodeOptionsUserDataDir :: Maybe FilePath , decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value)) +, decodeOptionsFormatYamlParseError :: FilePath -> Yaml.ParseException -> String } -newtype ProgramName = ProgramName String - deriving (Eq, Show) - -instance IsString ProgramName where - fromString = ProgramName - defaultDecodeOptions :: DecodeOptions -defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml +defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml Yaml.formatYamlParseError data DecodeResult = DecodeResult { decodeResultPackage :: Package @@ -666,13 +665,16 @@ 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) <- liftEither $ readValue file +readPackageConfig options = first (formatHpackError $ decodeOptionsProgramName options) <$> readPackageConfigWithError options + +readPackageConfigWithError :: DecodeOptions -> IO (Either HpackError DecodeResult) +readPackageConfigWithError (DecodeOptions _ file mUserDataDir readValue formatYamlParseError) = runExceptT $ fmap addCabalFile . runWriterT $ do + (warnings, value) <- liftEither $ first ParseError <$> readValue file tell warnings config <- decodeValue file value dir <- liftIO $ takeDirectory <$> canonicalizePath file userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir - toPackage userDataDir dir config + toPackage formatYamlParseError userDataDir dir config where addCabalFile :: ((Package, String), [String]) -> DecodeResult addCabalFile ((pkg, cabalVersion), warnings) = DecodeResult pkg cabalVersion (takeDirectory_ file (packageName pkg ++ ".cabal")) warnings @@ -895,10 +897,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) <- liftEither . return $ first (prefix ++) (Config.decodeValue value) + (r, unknown, deprecated) <- liftEither . 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 $ HpackVersionNotSupported file v Hpack.version SupportedSpecVersion a -> do tell (map formatUnknownField unknown) tell (map formatDeprecatedField deprecated) @@ -1052,9 +1054,9 @@ type ConfigWithDefaults = Product type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseCSources ParseCxxSources ParseJsSources a) type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) -toPackage :: FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String) -toPackage userDataDir dir = - expandDefaultsInConfig userDataDir dir +toPackage :: FormatYamlParseError -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String) +toPackage formatYamlParseError userDataDir dir = + expandDefaultsInConfig formatYamlParseError userDataDir dir >=> setDefaultLanguage "Haskell2010" >>> traverseConfig (expandForeignSources dir) >=> toPackage_ dir @@ -1064,32 +1066,35 @@ toPackage userDataDir dir = setLanguage = (mempty { commonOptionsLanguage = Alias . Last $ Just (Just language) } <>) expandDefaultsInConfig - :: FilePath + :: FormatYamlParseError + -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Config ParseCSources ParseCxxSources ParseJsSources) -expandDefaultsInConfig userDataDir dir = bitraverse (expandGlobalDefaults userDataDir dir) (expandSectionDefaults userDataDir dir) +expandDefaultsInConfig formatYamlParseError userDataDir dir = bitraverse (expandGlobalDefaults formatYamlParseError userDataDir dir) (expandSectionDefaults formatYamlParseError userDataDir dir) expandGlobalDefaults - :: FilePath + :: FormatYamlParseError + -> FilePath -> FilePath -> CommonOptionsWithDefaults Empty -> Warnings (Errors IO) (CommonOptions ParseCSources ParseCxxSources ParseJsSources Empty) -expandGlobalDefaults userDataDir dir = do - fmap (`Product` Empty) >>> expandDefaults userDataDir dir >=> \ (Product c Empty) -> return c +expandGlobalDefaults formatYamlParseError userDataDir dir = do + fmap (`Product` Empty) >>> expandDefaults formatYamlParseError userDataDir dir >=> \ (Product c Empty) -> return c expandSectionDefaults - :: FilePath + :: FormatYamlParseError + -> FilePath -> FilePath -> PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources -> Warnings (Errors IO) (PackageConfig ParseCSources ParseCxxSources ParseJsSources) -expandSectionDefaults userDataDir dir p@PackageConfig{..} = do - library <- traverse (expandDefaults userDataDir dir) packageConfigLibrary - internalLibraries <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigInternalLibraries - executable <- traverse (expandDefaults userDataDir dir) packageConfigExecutable - executables <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigExecutables - tests <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigTests - benchmarks <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigBenchmarks +expandSectionDefaults formatYamlParseError userDataDir dir p@PackageConfig{..} = do + library <- traverse (expandDefaults formatYamlParseError userDataDir dir) packageConfigLibrary + internalLibraries <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigInternalLibraries + executable <- traverse (expandDefaults formatYamlParseError userDataDir dir) packageConfigExecutable + executables <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigExecutables + tests <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigTests + benchmarks <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigBenchmarks return p{ packageConfigLibrary = library , packageConfigInternalLibraries = internalLibraries @@ -1101,11 +1106,12 @@ expandSectionDefaults userDataDir dir p@PackageConfig{..} = do expandDefaults :: (FromValue a, Semigroup a, Monoid a) - => FilePath + => FormatYamlParseError + -> FilePath -> FilePath -> WithCommonOptionsWithDefaults a -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) -expandDefaults userDataDir = expand [] +expandDefaults formatYamlParseError userDataDir = expand [] where expand :: (FromValue a, Semigroup a, Monoid a) => [FilePath] @@ -1125,14 +1131,14 @@ expandDefaults userDataDir = expand [] file <- liftEither (ensure userDataDir dir defaults) seen_ <- lift (checkCycle seen file) let dir_ = takeDirectory file - decodeYaml file >>= expand seen_ dir_ + decodeYaml formatYamlParseError file >>= expand seen_ dir_ checkCycle :: [FilePath] -> FilePath -> Errors IO [FilePath] checkCycle seen file = do canonic <- liftIO $ canonicalizePath file let seen_ = canonic : seen when (canonic `elem` seen) $ do - throwE . const $ "cycle in defaults (" ++ intercalate " -> " (reverse seen_) ++ ")" + throwE $ CycleInDefaults (reverse seen_) return seen_ toExecutableMap :: Monad m => String -> Maybe (Map String a) -> Maybe a -> Warnings m (Maybe (Map String a)) diff --git a/src/Hpack/Defaults.hs b/src/Hpack/Defaults.hs index ef81ab9a..3021271a 100644 --- a/src/Hpack/Defaults.hs +++ b/src/Hpack/Defaults.hs @@ -14,18 +14,15 @@ module Hpack.Defaults ( import Imports -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 import Hpack.Syntax.Defaults -type URL = String - defaultsUrl :: Github -> URL defaultsUrl Github{..} = "https://raw.githubusercontent.com/" ++ githubOwner ++ "/" ++ githubRepo ++ "/" ++ githubRef ++ "/" ++ intercalate "/" githubPath @@ -33,7 +30,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 Status deriving (Eq, Show) get :: URL -> FilePath -> IO Result @@ -47,12 +44,9 @@ get url file = do LB.writeFile file (responseBody response) return Found Status 404 _ -> return NotFound - status -> return (Failed $ "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")") - -formatStatus :: Status -> String -formatStatus (Status code message) = show code ++ " " ++ B.unpack message + status -> return (Failed status) -ensure :: FilePath -> FilePath -> Defaults -> IO (Either String FilePath) +ensure :: FilePath -> FilePath -> Defaults -> IO (Either HpackError FilePath) ensure userDataDir dir = \ case DefaultsGithub defaults -> do let @@ -60,14 +54,14 @@ ensure userDataDir dir = \ case file = defaultsCachePath userDataDir defaults ensureFile file url >>= \ case Found -> return (Right file) - NotFound -> return (Left $ notFound url) - Failed err -> return (Left err) + NotFound -> notFound url + Failed status -> return (Left $ DefaultsDownloadFailed url status) DefaultsLocal (Local ((dir ) -> file)) -> do doesFileExist file >>= \ case True -> return (Right file) - False -> return (Left $ notFound file) + False -> notFound file where - notFound file = "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!" + notFound = return . Left . DefaultsFileNotFound ensureFile :: FilePath -> URL -> IO Result ensureFile file url = do diff --git a/src/Hpack/Error.hs b/src/Hpack/Error.hs new file mode 100644 index 00000000..c6f1b387 --- /dev/null +++ b/src/Hpack/Error.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE LambdaCase #-} +module Hpack.Error ( +-- | /__NOTE:__/ This module is exposed to allow integration of Hpack into +-- other tools. It is not meant for general use by end users. The following +-- caveats apply: +-- +-- * The API is undocumented, consult the source instead. +-- +-- * The exposed types and functions primarily serve Hpack's own needs, not +-- that of a public API. Breaking changes can happen as Hpack evolves. +-- +-- As an Hpack user you either want to use the @hpack@ executable or a build +-- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). + HpackError (..) +, formatHpackError +, ProgramName (..) +, URL +, Status (..) +, formatStatus +) 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 = + HpackVersionNotSupported FilePath Version Version + | DefaultsFileNotFound FilePath + | DefaultsDownloadFailed URL Status + | CycleInDefaults [FilePath] + | ParseError String + | DecodeValueError FilePath String + deriving (Eq, Show) + +newtype ProgramName = ProgramName {unProgramName :: String} + deriving (Eq, Show) + +instance IsString ProgramName where + fromString = ProgramName + +formatHpackError :: ProgramName -> HpackError -> String +formatHpackError (ProgramName progName) = \ case + HpackVersionNotSupported 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!" + DefaultsDownloadFailed url status -> "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")" + CycleInDefaults files -> "cycle in defaults (" ++ intercalate " -> " files ++ ")" + ParseError err -> err + DecodeValueError file err -> file ++ ": " ++ err + +formatStatus :: Status -> String +formatStatus (Status code message) = show code ++ " " ++ B.unpack message diff --git a/src/Hpack/Yaml.hs b/src/Hpack/Yaml.hs index d49f08f2..85ef9a08 100644 --- a/src/Hpack/Yaml.hs +++ b/src/Hpack/Yaml.hs @@ -14,6 +14,10 @@ module Hpack.Yaml ( -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). decodeYaml +, decodeYamlWithParseError +, ParseException +, formatYamlParseError +, formatWarning , module Data.Aeson.Config.FromValue ) where @@ -25,18 +29,22 @@ import Data.Yaml.Internal (Warning(..)) import Data.Aeson.Config.FromValue import Data.Aeson.Config.Parser (fromAesonPath, formatPath) +decodeYaml :: FilePath -> IO (Either String ([String], Value)) +decodeYaml file = first (formatYamlParseError file) <$> decodeYamlWithParseError file + +decodeYamlWithParseError :: FilePath -> IO (Either ParseException ([String], Value)) +decodeYamlWithParseError file = do + result <- decodeFileWithWarnings file + return $ fmap (first (map $ formatWarning file)) result + +formatYamlParseError :: FilePath -> ParseException -> String +formatYamlParseError file 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 + _ -> ": " ++ displayException err + formatWarning :: FilePath -> Warning -> String formatWarning file = \ case DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path) - -decodeYaml :: FilePath -> IO (Either String ([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 diff --git a/src/Imports.hs b/src/Imports.hs index f6a8c362..c4087ae3 100644 --- a/src/Imports.hs +++ b/src/Imports.hs @@ -2,6 +2,7 @@ module Imports (module Imports) where import Control.Applicative as Imports import Control.Arrow as Imports ((>>>), (&&&)) +import Control.Exception as Imports (Exception(..)) import Control.Monad as Imports import Data.Bifunctor as Imports import Data.List as Imports hiding (sort, nub) diff --git a/test/Hpack/DefaultsSpec.hs b/test/Hpack/DefaultsSpec.hs index 3e3b4e3e..96ba13d5 100644 --- a/test/Hpack/DefaultsSpec.hs +++ b/test/Hpack/DefaultsSpec.hs @@ -4,6 +4,7 @@ module Hpack.DefaultsSpec (spec) where import Helper import System.Directory +import Hpack.Error 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 diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs index 867fb8b6..fce31b73 100644 --- a/test/HpackSpec.hs +++ b/test/HpackSpec.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} module HpackSpec (spec) where 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 (formatHpackError) import Hpack hiding (hpack) readFile :: FilePath -> IO String @@ -55,7 +58,7 @@ spec = do let file = "foo.cabal" - hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions + hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions >>= either (die . formatHpackError "hpack") return hpackWithStrategy strategy = hpackResult defaultOptions { optionsGenerateHashStrategy = strategy } hpackForce = hpackResult defaultOptions {optionsForce = Force}