From 4fb87c6359366bd51aab6239b7bb8930930a882b Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Mon, 21 Nov 2022 17:19:54 +0000 Subject: [PATCH] Fix #530 Introduce `HpackError` type, for Hpack errors The `HpackError` type is an instance of `Eq`. Consequently, its data constructors involve only values of types that are instances of `Eq`. The `renderHpackError :: ProgramName -> HpackError -> String` function preserves the existing error messages of all existing Hpack errors. Moves `ProgramName` from `Hpack.Config` to new module `Hpack.Error` because `renderHpackError` makes use of the type. Defines, and applies, `hpackProgName :: ProgramName`, for convenience. The `DecodeOptions` constructor no longer needs its `decodeOptionsProgramName :: ProgramName` field (and `setProgramName` falls away). Its `decodeOptionsDecode` field is of type `FilePath -> IO (Either HpackError ([String], [Value]))`. The module "Hpack" exports new function `hpackResultWithError :: Options -> IO (Either HpackError Result)`. Updates tests accordingly. Some tests use `shouldSatisfy` rather than `shouldReturn`. Also bumps Hpack's `stack.yaml` to use lts-20.1 (GHC 9.2.5) rather than lts-15.11 (GHC 8.8.3). --- hpack.cabal | 4 +- src/Hpack.hs | 59 +++++++++++++------------ src/Hpack/Config.hs | 84 ++++++++++++++++-------------------- src/Hpack/Defaults.hs | 19 +++----- src/Hpack/Error.hs | 88 ++++++++++++++++++++++++++++++++++++++ src/Hpack/Yaml.hs | 21 +++++---- stack.yaml | 2 +- stack.yaml.lock | 8 ++-- test/EndToEndSpec.hs | 88 +++++++++++++++++++++++--------------- test/Hpack/ConfigSpec.hs | 20 +++++++-- test/Hpack/DefaultsSpec.hs | 3 +- test/HpackSpec.hs | 4 +- 12 files changed, 258 insertions(+), 142 deletions(-) create mode 100644 src/Hpack/Error.hs diff --git a/hpack.cabal b/hpack.cabal index 367a9e96..accd1eb9 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 @@ -63,6 +63,7 @@ library Data.Aeson.Config.Util Hpack.CabalFile Hpack.Defaults + Hpack.Error Hpack.Haskell Hpack.License Hpack.Module @@ -188,6 +189,7 @@ test-suite spec Hpack.CabalFile Hpack.Config Hpack.Defaults + Hpack.Error Hpack.Haskell Hpack.License Hpack.Module diff --git a/src/Hpack.hs b/src/Hpack.hs index 30d861c6..80850854 100644 --- a/src/Hpack.hs +++ b/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,11 +128,7 @@ 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 :: (FilePath -> IO (Either HpackError ([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 <- 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 diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs index ce2b5b67..9dcb266d 100644 --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -112,6 +112,7 @@ import Data.Aeson.Config.Types import Data.Aeson.Config.FromValue hiding (decodeValue) import qualified Data.Aeson.Config.FromValue as Config +import Hpack.Error (HpackError (..), ProgramName (..), hpackProgName) import Hpack.Syntax.Defaults import Hpack.Util hiding (expandGlobs) import qualified Hpack.Util as Util @@ -631,29 +632,22 @@ type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSource instance FromValue ParsePackageConfig type Warnings m = WriterT [String] m -type Errors = ExceptT String +type Errors = ExceptT HpackError -decodeYaml :: FromValue a => ProgramName -> FilePath -> Warnings (Errors IO) a -decodeYaml programName file = do +decodeYaml :: FromValue a => FilePath -> Warnings (Errors IO) a +decodeYaml file = do (warnings, a) <- lift (ExceptT $ Yaml.decodeYaml file) tell warnings - decodeValue programName file a + decodeValue file a data DecodeOptions = DecodeOptions { - decodeOptionsProgramName :: ProgramName -, decodeOptionsTarget :: FilePath + decodeOptionsTarget :: FilePath , decodeOptionsUserDataDir :: Maybe FilePath -, decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value)) +, decodeOptionsDecode :: FilePath -> IO (Either HpackError ([String], Value)) } -newtype ProgramName = ProgramName String - deriving (Eq, Show) - -instance IsString ProgramName where - fromString = ProgramName - defaultDecodeOptions :: DecodeOptions -defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml +defaultDecodeOptions = DecodeOptions packageConfig Nothing Yaml.decodeYaml data DecodeResult = DecodeResult { decodeResultPackage :: Package @@ -662,14 +656,14 @@ data DecodeResult = DecodeResult { , decodeResultWarnings :: [String] } deriving (Eq, Show) -readPackageConfig :: DecodeOptions -> IO (Either String DecodeResult) -readPackageConfig (DecodeOptions programName file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do +readPackageConfig :: DecodeOptions -> IO (Either HpackError DecodeResult) +readPackageConfig (DecodeOptions file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do (warnings, value) <- lift . ExceptT $ readValue file tell warnings - config <- decodeValue programName file value + config <- decodeValue file value dir <- liftIO $ takeDirectory <$> canonicalizePath file - userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir - toPackage programName userDataDir dir config + userDataDir <- liftIO $ maybe (getAppUserDataDirectory $ unProgramName hpackProgName) return mUserDataDir + toPackage userDataDir dir config where addCabalFile :: ((Package, String), [String]) -> DecodeResult addCabalFile ((pkg, cabalVersion), warnings) = DecodeResult pkg cabalVersion (takeDirectory_ file (packageName pkg ++ ".cabal")) warnings @@ -890,12 +884,12 @@ determineCabalVersion inferredLicense pkg@Package{..} = ( 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 :: FromValue a => FilePath -> Value -> Warnings (Errors IO) a +decodeValue file value = do + (r, unknown, deprecated) <- lift . ExceptT . return $ first (DecodeValueError 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 file v Hpack.version SupportedSpecVersion a -> do tell (map formatUnknownField unknown) tell (map formatDeprecatedField deprecated) @@ -1049,9 +1043,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 :: ProgramName -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String) -toPackage programName userDataDir dir = - expandDefaultsInConfig programName userDataDir dir +toPackage :: FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String) +toPackage userDataDir dir = + expandDefaultsInConfig userDataDir dir >=> setDefaultLanguage "Haskell2010" >>> traverseConfig (expandForeignSources dir) >=> toPackage_ dir @@ -1061,35 +1055,32 @@ toPackage programName userDataDir dir = setLanguage = (mempty { commonOptionsLanguage = Alias . Last $ Just (Just language) } <>) expandDefaultsInConfig - :: ProgramName - -> FilePath + :: FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Config ParseCSources ParseCxxSources ParseJsSources) -expandDefaultsInConfig programName userDataDir dir = bitraverse (expandGlobalDefaults programName userDataDir dir) (expandSectionDefaults programName userDataDir dir) +expandDefaultsInConfig userDataDir dir = bitraverse (expandGlobalDefaults userDataDir dir) (expandSectionDefaults userDataDir dir) expandGlobalDefaults - :: ProgramName - -> FilePath + :: FilePath -> FilePath -> CommonOptionsWithDefaults Empty -> Warnings (Errors IO) (CommonOptions ParseCSources ParseCxxSources ParseJsSources Empty) -expandGlobalDefaults programName userDataDir dir = do - fmap (`Product` Empty) >>> expandDefaults programName userDataDir dir >=> \ (Product c Empty) -> return c +expandGlobalDefaults userDataDir dir = do + fmap (`Product` Empty) >>> expandDefaults userDataDir dir >=> \ (Product c Empty) -> return c expandSectionDefaults - :: ProgramName - -> FilePath + :: FilePath -> FilePath -> PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources -> Warnings (Errors IO) (PackageConfig ParseCSources ParseCxxSources ParseJsSources) -expandSectionDefaults programName userDataDir dir p@PackageConfig{..} = do - library <- traverse (expandDefaults programName userDataDir dir) packageConfigLibrary - internalLibraries <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigInternalLibraries - executable <- traverse (expandDefaults programName userDataDir dir) packageConfigExecutable - executables <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigExecutables - tests <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigTests - benchmarks <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigBenchmarks +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 return p{ packageConfigLibrary = library , packageConfigInternalLibraries = internalLibraries @@ -1101,12 +1092,11 @@ expandSectionDefaults programName userDataDir dir p@PackageConfig{..} = do expandDefaults :: (FromValue a, Semigroup a, Monoid a) - => ProgramName - -> FilePath + => FilePath -> FilePath -> WithCommonOptionsWithDefaults a -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) -expandDefaults programName userDataDir = expand [] +expandDefaults userDataDir = expand [] where expand :: (FromValue a, Semigroup a, Monoid a) => [FilePath] @@ -1126,14 +1116,14 @@ expandDefaults programName userDataDir = expand [] file <- lift $ ExceptT (ensure userDataDir dir defaults) seen_ <- lift (checkCycle seen file) let dir_ = takeDirectory file - decodeYaml programName file >>= expand seen_ dir_ + decodeYaml 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 ("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)) diff --git a/src/Hpack/Defaults.hs b/src/Hpack/Defaults.hs index ef81ab9a..0d33ea68 100644 --- a/src/Hpack/Defaults.hs +++ b/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,12 +47,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 ++ ")") + 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 @@ -60,14 +57,12 @@ 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 -> 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 diff --git a/src/Hpack/Error.hs b/src/Hpack/Error.hs new file mode 100644 index 00000000..c174693c --- /dev/null +++ b/src/Hpack/Error.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Errors returned by Hpack library functions. +module Hpack.Error + ( HpackError (..) + , hpackProgName + , renderHpackError + , ProgramName (..) + -- * Re-export of types used in Hpack errors + , Status (..) + , Version (..) + , 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 synonyn representing URLs. +type URL = String + +-- | Type representing errors returned by functions exported by the modules of +-- the Hpack library. +data HpackError + = HpackVersionUnsupported !FilePath !Version !Version + | DefaultsFileNotFound !FilePath + | DefaultsFileUrlNotFound !URL + | DownloadingFileFailed !URL !Status + | CycleInDefaultsError ![FilePath] + | HpackParseAesonException !FilePath !String + | HpackParseYamlException !FilePath !String + | HpackParseYamlParseException { + yamlFile :: !FilePath + , yamlProblem :: !String + , yamlContext :: !String + , yamlIndex :: !Int + -- ^ Not displayed by 'renderHpackError'. + , yamlLine :: !Int + , yamlColumn :: !Int + } + | HpackParseOtherException !FilePath !String + | DecodeValueError !FilePath !String + -- | Data constructor for users of the Hpack library that do not use the + -- default 'Hpack.Yaml.decodeYaml' and wish to use 'String' as an + -- error/exception type. + | HpackOtherException !FilePath !String + deriving (Eq, Show) + +renderHpackError :: ProgramName -> HpackError -> String +renderHpackError (ProgramName progName) (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." +renderHpackError _ (DefaultsFileNotFound file) = + "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!" +renderHpackError _ (DefaultsFileUrlNotFound url) = + "Invalid value for \"defaults\"! File " ++ url ++ " does not exist!" +renderHpackError _ (DownloadingFileFailed url status) = + "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")" + where + formatStatus :: Status -> String + formatStatus (Status code message) = show code ++ " " ++ B.unpack message +renderHpackError _ (CycleInDefaultsError files) = + "cycle in defaults (" ++ intercalate " -> " files ++ ")" +renderHpackError _ (HpackParseAesonException file s) = renderFileMsg file s +renderHpackError _ (HpackParseYamlException file s) = renderFileMsg file s +renderHpackError _ (HpackParseYamlParseException{..}) = renderFileMsg yamlFile $ + show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext +renderHpackError _ (HpackParseOtherException file s) = renderFileMsg file s +renderHpackError _ (DecodeValueError file s) = renderFileMsg file s +renderHpackError _ (HpackOtherException file s) = renderFileMsg file s + +-- | Helper function for renderHpackError +renderFileMsg :: FilePath -> String -> String +renderFileMsg file s = file ++ ": " ++ s + +hpackProgName :: ProgramName +hpackProgName = ProgramName "hpack" + +-- | Type representing the names of programs using the Hpack library. +newtype ProgramName = ProgramName {unProgramName :: String} + deriving (Eq, Show) + +instance IsString ProgramName where + fromString = ProgramName diff --git a/src/Hpack/Yaml.hs b/src/Hpack/Yaml.hs index d49f08f2..36e29c76 100644 --- a/src/Hpack/Yaml.hs +++ b/src/Hpack/Yaml.hs @@ -24,19 +24,22 @@ import Data.Yaml.Include import Data.Yaml.Internal (Warning(..)) import Data.Aeson.Config.FromValue import Data.Aeson.Config.Parser (fromAesonPath, formatPath) +import Hpack.Error (HpackError (..)) 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 HpackError ([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 . toHpackError file) (Right . first (map $ formatWarning file)) result + +toHpackError :: FilePath -> ParseException -> HpackError +toHpackError file (AesonException s) = HpackParseAesonException file s +toHpackError file (InvalidYaml (Just (YamlException s))) = HpackParseYamlException file s +toHpackError yamlFile (InvalidYaml (Just (YamlParseException{..}))) = HpackParseYamlParseException {..} + where + YamlMark{..} = yamlProblemMark +-- All other ParseException values are reduced to their show result +toHpackError file e = HpackParseOtherException file (show e) diff --git a/stack.yaml b/stack.yaml index fbf9b199..01b569b5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -resolver: lts-15.11 +resolver: lts-20.1 diff --git a/stack.yaml.lock b/stack.yaml.lock index 4f6b8363..e067f78c 100644 --- a/stack.yaml.lock +++ b/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: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5 + size: 648424 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml + original: lts-20.1 diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs index 19b0ba94..86eaf858 100644 --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -11,19 +11,17 @@ import qualified Prelude import Helper import Test.HUnit -import System.Directory (canonicalizePath) import Data.Maybe import Data.List import Data.String.Interpolate import Data.String.Interpolate.Util -import Data.Version (showVersion) +import Data.Version (makeVersion) +import Hpack.Error (HpackError(..), renderHpackError, hpackProgName) import qualified Hpack.Render as Hpack import Hpack.Config (packageConfig, readPackageConfig, DecodeOptions(..), DecodeResult(..), defaultDecodeOptions) import Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints) -import qualified Paths_hpack as Hpack (version) - writeFile :: FilePath -> String -> IO () writeFile file c = touch file >> Prelude.writeFile file c @@ -173,12 +171,12 @@ spec = around_ (inTempDirectoryNamed "foo") $ do it "fails on malformed spec-version" $ do [i| spec-version: foo - |] `shouldFailWith` "package.yaml: Error while parsing $.spec-version - invalid value \"foo\"" + |] `shouldFailWith` (DecodeValueError "package.yaml" "Error while parsing $.spec-version - invalid value \"foo\"") it "fails on unsupported spec-version" $ do [i| spec-version: 25.0 - |] `shouldFailWith` ("The file package.yaml requires version 25.0 of the Hpack package specification, however this version of hpack only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of hpack may resolve this issue.") + |] `shouldFailWith` (HpackVersionUnsupported "package.yaml" (makeVersion [25,0]) (makeVersion [0,35,0])) it "fails on unsupported spec-version from defaults" $ do let file = joinPath ["defaults", "sol", "hpack-template", "2017", "defaults.yaml"] @@ -192,7 +190,11 @@ spec = around_ (inTempDirectoryNamed "foo") $ do path: defaults.yaml ref: "2017" library: {} - |] `shouldFailWith` ("The file " ++ file ++ " requires version 25.0 of the Hpack package specification, however this version of hpack only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of hpack may resolve this issue.") + |] `shouldFailWith'` (\e -> case e of + -- As file path formats depend on the operating system, do not test + -- the specific file path. + HpackVersionUnsupported _ v1 v2 -> v1 == makeVersion [25,0] && v2 == makeVersion [0,35,0] + _ -> False) describe "data-files" $ do it "accepts data-files" $ do @@ -249,7 +251,7 @@ spec = around_ (inTempDirectoryNamed "foo") $ do it "rejects URLs" $ do [i| github: https://github.com/sol/hpack/issues/365 - |] `shouldFailWith` "package.yaml: Error while parsing $.github - expected owner/repo or owner/repo/subdir, but encountered \"https://github.com/sol/hpack/issues/365\"" + |] `shouldFailWith` (DecodeValueError "package.yaml" "Error while parsing $.github - expected owner/repo or owner/repo/subdir, but encountered \"https://github.com/sol/hpack/issues/365\"") describe "homepage" $ do it "accepts homepage URL" $ do @@ -407,12 +409,14 @@ spec = around_ (inTempDirectoryNamed "foo") $ do file2 = "defaults/foo/bar/v2/.hpack/defaults.yaml" writeFile file1 "defaults: foo/bar@v2" writeFile file2 "defaults: foo/bar@v1" - canonic1 <- canonicalizePath file1 - canonic2 <- canonicalizePath file2 [i| defaults: foo/bar@v1 library: {} - |] `shouldFailWith` [i|cycle in defaults (#{canonic1} -> #{canonic2} -> #{canonic1})|] + |] `shouldFailWith'` (\e -> case e of + -- As the file paths in CycleInDefaultsException are absolute ones we + -- test only that there are three of them. + CycleInDefaultsError [_, _, _] -> True + _ -> False) it "fails if defaults don't exist" $ do pending @@ -421,7 +425,7 @@ spec = around_ (inTempDirectoryNamed "foo") $ do github: sol/foo ref: bar library: {} - |] `shouldFailWith` "Invalid value for \"defaults\"! File https://raw.githubusercontent.com/sol/foo/bar/.hpack/defaults.yaml does not exist!" + |] `shouldFailWith` (DefaultsFileUrlNotFound "https://raw.githubusercontent.com/sol/foo/bar/.hpack/defaults.yaml") it "fails on parse error" $ do let file = joinPath ["defaults", "sol", "hpack-template", "2017", "defaults.yaml"] @@ -432,7 +436,11 @@ spec = around_ (inTempDirectoryNamed "foo") $ do path: defaults.yaml ref: "2017" library: {} - |] `shouldFailWith` (file ++ ": Error while parsing $ - expected Object, but encountered Array") + |] `shouldFailWith'` (\e -> case e of + -- As file path formats depend on the operating system, do not test + -- the specific file path. + DecodeValueError _ "Error while parsing $ - expected Object, but encountered Array" -> True + _ -> False) it "warns on unknown fields" $ do let file = joinPath ["defaults", "sol", "hpack-template", "2017", "defaults.yaml"] @@ -487,7 +495,7 @@ spec = around_ (inTempDirectoryNamed "foo") $ do it "rejects other values" $ do [i| version: {} - |] `shouldFailWith` "package.yaml: Error while parsing $.version - expected Number or String, but encountered Object" + |] `shouldFailWith` (DecodeValueError "package.yaml" "Error while parsing $.version - expected Number or String, but encountered Object") describe "license" $ do it "accepts cabal-style licenses" $ do @@ -593,7 +601,7 @@ spec = around_ (inTempDirectoryNamed "foo") $ do it "rejects invalid values" $ do [i| build-type: foo - |] `shouldFailWith` "package.yaml: Error while parsing $.build-type - expected one of Simple, Configure, Make, or Custom" + |] `shouldFailWith` (DecodeValueError "package.yaml" "Error while parsing $.build-type - expected one of Simple, Configure, Make, or Custom") describe "extra-doc-files" $ do @@ -1732,13 +1740,13 @@ spec = around_ (inTempDirectoryNamed "foo") $ do else: dependencies: unix executable: {} - |] `shouldFailWith` unlines [ - "package.yaml: Error while parsing $.when - an empty \"then\" section is not allowed, try the following instead:" - , "" - , "when:" - , " condition: '!(os(windows))'" - , " dependencies: unix" - ] + |] `shouldFailWith` (DecodeValueError "package.yaml" $ unlines [ + "Error while parsing $.when - an empty \"then\" section is not allowed, try the following instead:" + , "" + , "when:" + , " condition: '!(os(windows))'" + , " dependencies: unix" + ]) context "with empty else-branch" $ do it "provides a hint" $ do @@ -1749,13 +1757,13 @@ spec = around_ (inTempDirectoryNamed "foo") $ do dependencies: Win32 else: {} executable: {} - |] `shouldFailWith` unlines [ - "package.yaml: Error while parsing $.when - an empty \"else\" section is not allowed, try the following instead:" - , "" - , "when:" - , " condition: os(windows)" - , " dependencies: Win32" - ] + |] `shouldFailWith` (DecodeValueError "package.yaml" $ unlines [ + "Error while parsing $.when - an empty \"else\" section is not allowed, try the following instead:" + , "" + , "when:" + , " condition: os(windows)" + , " dependencies: Win32" + ]) it "rejects invalid conditionals" $ do [i| @@ -1764,14 +1772,14 @@ spec = around_ (inTempDirectoryNamed "foo") $ do then: dependencies: Win32 else: null - |] `shouldFailWith` "package.yaml: Error while parsing $.when.else - expected Object, but encountered Null" + |] `shouldFailWith` (DecodeValueError "package.yaml" "Error while parsing $.when.else - expected Object, but encountered Null") it "rejects invalid conditionals" $ do [i| dependencies: - foo - 23 - |] `shouldFailWith` "package.yaml: Error while parsing $.dependencies[1] - expected Object or String, but encountered Number" + |] `shouldFailWith` (DecodeValueError "package.yaml" "Error while parsing $.dependencies[1] - expected Object or String, but encountered Number") it "warns on unknown fields" $ do [i| @@ -1910,9 +1918,9 @@ spec = around_ (inTempDirectoryNamed "foo") $ do |] run :: HasCallStack => FilePath -> FilePath -> String -> IO ([String], String) -run userDataDir c old = run_ userDataDir c old >>= either assertFailure return +run userDataDir c old = run_ userDataDir c old >>= either (assertFailure . renderHpackError hpackProgName) return -run_ :: FilePath -> FilePath -> String -> IO (Either String ([String], String)) +run_ :: FilePath -> FilePath -> String -> IO (Either HpackError ([String], String)) run_ userDataDir c old = do mPackage <- readPackageConfig defaultDecodeOptions {decodeOptionsTarget = c, decodeOptionsUserDataDir = Just userDataDir} return $ case mPackage of @@ -1947,10 +1955,20 @@ shouldWarn input expected = do (warnings, _) <- run "" packageConfig "" sort warnings `shouldBe` sort expected -shouldFailWith :: HasCallStack => String -> String -> Expectation +shouldFailWith :: HasCallStack => String -> HpackError -> Expectation shouldFailWith input expected = do writeFile packageConfig input - run_ "" packageConfig "" `shouldReturn` Left expected + result <- run_ "" packageConfig "" + result `shouldBe` Left expected + +shouldFailWith' :: HasCallStack => String -> Selector HpackError -> Expectation +shouldFailWith' input expected = do + writeFile packageConfig input + result <- run_ "" packageConfig "" + let expected' v = case v of + Left e -> expected e + Right _ -> False + result `shouldSatisfy` expected' customSetup :: String -> Package customSetup a = (package content) {packageCabalVersion = "1.24", packageBuildType = "Custom"} diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs index 1842b249..e53831ba 100644 --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,6 +26,7 @@ import Data.Either import qualified Data.Map.Lazy as Map import Control.Monad.Trans.Writer (runWriter) +import Hpack.Error (HpackError (..)) import Hpack.Syntax.Dependencies import Hpack.Syntax.DependencyVersion import Hpack.Syntax.BuildTools @@ -67,7 +69,7 @@ withPackage content beforeAction expectation = withTempDirectory $ \dir_ -> do writeFile (dir "package.yaml") content withCurrentDirectory dir beforeAction r <- readPackageConfig (testDecodeOptions $ dir "package.yaml") - either expectationFailure (\ (DecodeResult p _ _ warnings) -> expectation (p, warnings)) r + either (expectationFailure . show) (\ (DecodeResult p _ _ warnings) -> expectation (p, warnings)) r withPackageConfig :: String -> IO () -> (Package -> Expectation) -> Expectation withPackageConfig content beforeAction expectation = withPackage content beforeAction (expectation . fst) @@ -632,7 +634,18 @@ spec = do foo: bar foo baz |] - readPackageConfig (testDecodeOptions file) `shouldReturn` Left (file ++ ":3:12: could not find expected ':' while scanning a simple key") + let expected v = case v of + Left (HpackParseYamlParseException {..}) -> + -- As the yamlIndex appears to vary depending on the operating + -- system, we do not test for it. + yamlFile == file + && yamlLine == 3 + && yamlColumn == 12 + && yamlProblem == "could not find expected ':'" + && yamlContext == "while scanning a simple key" + _ -> False + result <- readPackageConfig (testDecodeOptions file) + result `shouldSatisfy` expected context "when package.yaml is invalid" $ do it "returns an error" $ \dir -> do @@ -646,7 +659,8 @@ spec = do context "when package.yaml does not exist" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" - readPackageConfig (testDecodeOptions file) `shouldReturn` Left [i|#{file}: Yaml file not found: #{file}|] + expected = Left (HpackParseYamlException file [i|Yaml file not found: #{file}|]) + readPackageConfig (testDecodeOptions file) `shouldReturn` expected describe "fromValue" $ do context "with Cond" $ do diff --git a/test/Hpack/DefaultsSpec.hs b/test/Hpack/DefaultsSpec.hs index 3e3b4e3e..0f016295 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 (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 diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs index 867fb8b6..fc68ab52 100644 --- a/test/HpackSpec.hs +++ b/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}