Merge pull request #43 from haskell-servant/ghc-8.4.1

Support GHC-8.4.1
This commit is contained in:
Oleg Grenrus 2018-03-23 08:21:16 +02:00 committed by GitHub
commit d262cead57
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 61 additions and 42 deletions

View File

@ -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;

View File

@ -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:

View File

@ -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

View File

@ -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`
--

View File

@ -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)

View File

@ -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

View File

@ -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