Support GHC-8.4.1

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

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:
 

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

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 ->
+  mappend = (<>)
-    a x y && b x y
 
 -- | Use `Eq` instance for `Response`
 --

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)

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)
+  mappend = (<>)
-                             (responsePredicates a <> responsePredicates b)
 
 class JoinPreds a where
   joinPreds :: a -> Predicates -> Predicates

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 (..),
+import           Test.Hspec.Core.Spec    (Arg, Example, Result (..), ResultStatus (..),
-                                          defaultParams)
+                                          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
+  case resultStatus r of
-    Left err -> return $ AnException err
+    Success          -> return $ AllGood
-    Right Success -> return $ AllGood
+    Failure _ reason -> return $ FailedWith $ show reason
-    Right (Failure _ reason) -> return $ FailedWith $ show reason
+    Pending {}       -> error "should not happen"
-    Right (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