From 4757df4195a4292aaa612d59d7a842423557e360 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 22 Mar 2018 13:56:30 +0200 Subject: [PATCH] Support GHC-8.4.1 --- .travis.yml | 5 ++- CHANGELOG.yaml | 15 +++++++-- servant-quickcheck.cabal | 15 ++++++--- src/Servant/QuickCheck/Internal/Equality.hs | 8 +++-- src/Servant/QuickCheck/Internal/ErrorTypes.hs | 8 ++++- src/Servant/QuickCheck/Internal/Predicates.hs | 20 +++++++++--- test/Servant/QuickCheck/InternalSpec.hs | 32 ++++--------------- 7 files changed, 61 insertions(+), 42 deletions(-) diff --git a/.travis.yml b/.travis.yml index 706d2fb..a98fd88 100644 --- a/.travis.yml +++ b/.travis.yml @@ -41,6 +41,9 @@ matrix: - compiler: "ghc-8.2.2" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.4.1" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}} before_install: - HC=${CC} @@ -72,7 +75,7 @@ install: - rm -f cabal.project.freeze - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all - - rm -rf "."/.ghc.environment.* "."/dist + - rm -rf .ghc.environment.* "."/dist - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Here starts the actual work to be performed for the package under test; diff --git a/CHANGELOG.yaml b/CHANGELOG.yaml index f801cdc..8355396 100644 --- a/CHANGELOG.yaml +++ b/CHANGELOG.yaml @@ -1,7 +1,18 @@ -upcoming: - releases: + - version: "0.0.7.0" + changes: + + - description: Support for GHC-8.4.1 + issue: none + authors: phadej + date: 2018-03-23 + + - description: Requires hspec-2.5 + issue: none + authors: phadej + date: 2018-03-23 + - version: "0.0.6.0" changes: diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index bcc0b5e..d4cb383 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -1,5 +1,5 @@ name: servant-quickcheck -version: 0.0.6.0 +version: 0.0.7.0 synopsis: QuickCheck entire APIs description: This packages provides QuickCheck properties that are tested across an entire @@ -17,7 +17,8 @@ extra-source-files: tested-with: GHC==7.10.3, GHC==8.0.2, - GHC==8.2.2 + GHC==8.2.2, + GHC==8.4.1 source-repository head type: git @@ -35,14 +36,14 @@ library , Servant.QuickCheck.Internal.QuickCheck , Servant.QuickCheck.Internal.Equality , Servant.QuickCheck.Internal.ErrorTypes - build-depends: base >=4.8 && <4.11 + build-depends: base >=4.8 && <4.12 , base-compat == 0.9.* , aeson > 0.8 && < 2 , bytestring == 0.10.* , case-insensitive == 1.2.* , clock >= 0.7 && < 0.8 , data-default-class >= 0.0 && < 0.2 - , hspec >= 2.2 && < 2.5 + , hspec >= 2.5 && < 2.6 , http-client >= 0.4.30 && < 0.6 , http-media >= 0.6 && <0.8 , http-types > 0.8 && < 0.13 @@ -60,6 +61,10 @@ library , time >= 1.5 && < 1.9 , warp >= 3.2.4 && < 3.3 + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.18.3 && <0.19 + hs-source-dirs: src default-extensions: TypeOperators , FlexibleInstances @@ -87,7 +92,7 @@ test-suite spec main-is: Spec.hs other-modules: Servant.QuickCheck.InternalSpec build-tool-depends: hspec-discover:hspec-discover - build-depends: base == 4.* + build-depends: base , base-compat , aeson , servant-quickcheck diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs index aa0b53e..a05704f 100644 --- a/src/Servant/QuickCheck/Internal/Equality.hs +++ b/src/Servant/QuickCheck/Internal/Equality.hs @@ -5,15 +5,19 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Function (on) import Network.HTTP.Client (Response, responseBody) +import Data.Semigroup (Semigroup (..)) import Prelude.Compat newtype ResponseEquality b = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool } +instance Semigroup (ResponseEquality b) where + ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y -> + a x y && b x y + instance Monoid (ResponseEquality b) where mempty = ResponseEquality $ \_ _ -> True - ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y -> - a x y && b x y + mappend = (<>) -- | Use `Eq` instance for `Response` -- diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs index 1d9cb9e..f95e4b2 100644 --- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Servant.QuickCheck.Internal.ErrorTypes where import Control.Exception (Exception (..)) @@ -8,9 +9,14 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) import qualified Network.HTTP.Client as C import Network.HTTP.Types (Header, statusCode) -import Prelude.Compat import Text.PrettyPrint +#if MIN_VERSION_base(4,11,0) +import Prelude.Compat hiding ((<>)) +#else +import Prelude.Compat +#endif + data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString) deriving (Typeable, Generic) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index cc0f724..4c2726f 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -11,7 +11,7 @@ import Data.CaseInsensitive (foldCase, foldedCase, mk) import Data.Either (isRight) import Data.List.Split (wordsBy) import Data.Maybe (fromMaybe, isJust) -import Data.Monoid ((<>)) +import Data.Semigroup (Semigroup (..)) import qualified Data.Text as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeM, rfc822DateFormat) @@ -377,9 +377,12 @@ newtype ResponsePredicate = ResponsePredicate { getResponsePredicate :: Response LBS.ByteString -> IO () } deriving (Generic) +instance Semigroup ResponsePredicate where + ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x + instance Monoid ResponsePredicate where mempty = ResponsePredicate $ const $ return () - ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x + mappend = (<>) -- | A predicate that depends on both the request and the response. -- @@ -391,7 +394,11 @@ newtype RequestPredicate = RequestPredicate -- TODO: This isn't actually a monoid instance Monoid RequestPredicate where mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x])) - RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr -> + mappend = (<>) + +-- TODO: This isn't actually a monoid +instance Semigroup RequestPredicate where + RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr -> liftM2 (<>) (a r mgr) (b r mgr) -- | A set of predicates. Construct one with 'mempty' and '<%>'. @@ -400,10 +407,13 @@ data Predicates = Predicates , responsePredicates :: ResponsePredicate } deriving (Generic) +instance Semigroup Predicates where + a <> b = Predicates (requestPredicates a <> requestPredicates b) + (responsePredicates a <> responsePredicates b) + instance Monoid Predicates where mempty = Predicates mempty mempty - a `mappend` b = Predicates (requestPredicates a <> requestPredicates b) - (responsePredicates a <> responsePredicates b) + mappend = (<>) class JoinPreds a where joinPreds :: a -> Predicates -> Predicates diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 5da6667..6d38cdd 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -17,8 +17,8 @@ import qualified Text.Blaze.Html as Blaze import qualified Text.Blaze.Html5 as Blaze5 import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) -import Test.Hspec.Core.Spec (Arg, Example, Result (..), - defaultParams) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..), + defaultParams, safeEvaluateExample) import Test.QuickCheck.Gen (generate, unGen) import Test.QuickCheck.Random (mkQCGen) @@ -30,13 +30,6 @@ import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI, comprehensiveAPI) #endif -#if MIN_VERSION_hspec(2,4,0) -import Test.Hspec.Core.Spec (safeEvaluateExample) -#else -import Control.Exception (try) -import Test.Hspec.Core.Spec (evaluateExample) -#endif - import Servant.QuickCheck import Servant.QuickCheck.Internal (genRequest, runGenRequest, serverDoesntSatisfy) @@ -349,27 +342,14 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext -- Utils ------------------------------------------------------------------------------ evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult -#if MIN_VERSION_hspec(2,4,0) evalExample e = do r <- safeEvaluateExample e defaultParams ($ ()) progCallback - case r of - Left err -> return $ AnException err - Right Success -> return $ AllGood - Right (Failure _ reason) -> return $ FailedWith $ show reason - Right (Pending _) -> error "should not happen" + case resultStatus r of + Success -> return $ AllGood + Failure _ reason -> return $ FailedWith $ show reason + Pending {} -> error "should not happen" where progCallback _ = return () -#else -evalExample e = do - r <- try $ evaluateExample e defaultParams ($ ()) progCallback - case r of - Left err -> return $ AnException err - Right Success -> return $ AllGood - Right (Fail _ reason) -> return $ FailedWith reason - Right (Pending _) -> error "should not happen" - where - progCallback _ = return () -#endif data EvalResult = AnException SomeException