eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #1009 from phadej/cleanup-pre-ghc-8.0

Browse source 
Cleanup pre-GHC-8.0 stuff
This commit is contained in:
Oleg Grenrus 2018-07-11 10:10:43 +03:00 committed by GitHub
commit 99e535b579
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
31 changed files with 46 additions and 219 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
servant-client-core/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

6
servant-client-core/servant-client-core.cabal
View file

@ -15,7 +15,6 @@ copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant
category: Web
build-type: Simple
extra-source-files:
include/*.h
CHANGELOG.md
README.md
tested-with:
@ -53,10 +52,6 @@ library
, text >= 1.2.3.0 && < 1.3
, transformers >= 0.3.0.0 && < 0.6
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.18.4 && <0.19
-- Servant dependencies
build-depends:
servant >= 0.14.1 && <0.15
@ -78,7 +73,6 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0

5
servant-client-core/src/Servant/Client/Core/Internal/Generic.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
@ -8,8 +7,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
module Servant.Client.Core.Internal.Generic where
import Generics.SOP
@ -142,7 +139,7 @@ instance (GClientList b acc, GClientList a (ClientList b acc))
=> GClientList (a :<|> b) acc where
gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))
instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc))
=> GClientList client acc where
gClientList c acc = I c :* acc

12
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -12,7 +11,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
module Servant.Client.Core.Internal.HasClient where
import Prelude ()
@ -209,7 +207,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
-- Note [Non-Empty Content Types]
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' a) where
@ -226,7 +224,7 @@ instance OVERLAPPABLE_
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
( RunClient m, ReflectMethod method
) => HasClient m (Verb method status cts NoContent) where
type Client m (Verb method status cts NoContent)
@ -238,7 +236,7 @@ instance OVERLAPPING_
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
-- Note [Non-Empty Content Types]
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
, ReflectMethod method, cts' ~ (ct ': cts)
@ -261,7 +259,7 @@ instance OVERLAPPING_
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
( RunClient m, BuildHeadersTo ls, ReflectMethod method
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
type Client m (Verb method status cts (Headers ls NoContent))
@ -275,7 +273,7 @@ instance OVERLAPPING_
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
( RunClient m, MonadIO m, MimeUnrender ct a, ReflectMethod method,
FramingUnrender framing a, FromResultStream a b
) => HasClient m (Stream method status framing ct b) where

8
servant-client/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

13
servant-client/servant-client.cabal
View file

@ -23,7 +23,6 @@ tested-with:
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
@ -48,9 +47,6 @@ library
, time >= 1.4.2 && < 1.9
, transformers >= 0.3.0.0 && < 0.6
if !impl(ghc >= 8.0)
build-depends: semigroups >=0.18.4 && <0.19
-- Servant dependencies
build-depends:
servant-client-core == 0.14.*
@ -71,10 +67,7 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
ghc-options: -Wall -Wno-redundant-constraints
test-suite spec
type: exitcode-stdio-1.0
@ -104,10 +97,6 @@ test-suite spec
, wai
, warp
if !impl(ghc >= 8.0)
build-depends:
semigroups
-- Additonal dependencies
build-depends:
generics-sop >= 0.3.2.0 && < 0.4

5
servant-client/test/Servant/ClientSpec.hs
View file

@ -15,15 +15,10 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
import Prelude ()

5
servant-client/test/Servant/StreamSpec.hs
View file

@ -15,15 +15,10 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.StreamSpec (spec) where
import Control.Monad

8
servant-docs/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

10
servant-docs/servant-docs.cabal
View file

@ -23,7 +23,6 @@ tested-with:
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
@ -45,10 +44,6 @@ library
, bytestring >= 0.10.4.0 && < 0.11
, text >= 1.2.3.0 && < 1.3
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.18.3 && <0.19
-- Servant dependencies
build-depends:
servant == 0.13.* || ==0.14.*
@ -70,10 +65,7 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
ghc-options: -Wall -Wno-redundant-constraints
executable greet-docs
main-is: greet.hs

10
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
@ -17,7 +16,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
module Servant.Docs.Internal where
import Prelude ()
@ -788,7 +786,7 @@ markdownWith RenderingOptions{..} api = unlines $
-- | The generated docs for @a ':<|>' b@ just appends the docs
-- for @a@ with the docs for @b@.
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
(HasDocs a, HasDocs b)
=> HasDocs (a :<|> b) where
@ -836,7 +834,7 @@ instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
symP = Proxy :: Proxy sym
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method)
=> HasDocs (Verb method status (ct ': cts) a) where
@ -855,7 +853,7 @@ instance OVERLAPPABLE_
-- | TODO: mention the endpoint is streaming, its framing strategy
--
-- Also there are no samples.
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
(MimeRender ct a, KnownNat status
, ReflectMethod method)
=> HasDocs (Stream method status framing ct a) where
@ -870,7 +868,7 @@ instance OVERLAPPABLE_
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
=> HasDocs (Verb method status (ct ': cts) (Headers ls a)) where

5
servant-docs/test/Servant/DocsSpec.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@ -8,11 +7,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
module Servant.DocsSpec where

8
servant-foreign/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

11
servant-foreign/servant-foreign.cabal
View file

@ -19,7 +19,6 @@ category: Servant, Web
build-type: Simple
cabal-version: >=1.10
extra-source-files:
include/*.h
CHANGELOG.md
README.md
bug-reports: http://github.com/haskell-servant/servant/issues
@ -45,10 +44,6 @@ library
base >= 4.7 && <4.12
, text >= 1.2.3.0 && < 1.3
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.18.3 && <0.19
-- Servant dependencies
build-depends:
servant == 0.13.* || ==0.14.*
@ -62,16 +57,12 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
ghc-options: -Wall -Wno-redundant-constraints
test-suite spec
type: exitcode-stdio-1.0
hs-source-dirs: test
ghc-options: -Wall
include-dirs: include
main-is: Spec.hs
other-modules: Servant.ForeignSpec

3
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -12,9 +12,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE NullaryTypeClasses #-}
#endif
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.

9
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
@ -9,10 +8,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#if __GLASGOW_HASKELL__ < 709
{-# OPTIONS_GHC -fcontext-stack=41 #-}
#endif
#include "overlapping-compat.h"
module Servant.ForeignSpec where
@ -59,10 +54,10 @@ instance HasForeignType LangX String Int where
instance HasForeignType LangX String Bool where
typeFor _ _ _ = "boolX"
instance OVERLAPPING_ HasForeignType LangX String String where
instance {-# OVERLAPPING #-} HasForeignType LangX String String where
typeFor _ _ _ = "stringX"
instance OVERLAPPABLE_ HasForeignType LangX String a => HasForeignType LangX String [a] where
instance {-# OVERLAPPABLE #-} HasForeignType LangX String a => HasForeignType LangX String [a] where
typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
instance (HasForeignType LangX String a) => HasForeignType LangX String (Maybe a) where

8
servant-server/Setup.lhs → servant-server/Setup.hs
View file

@ -1,4 +1,3 @@
\begin{code}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
@ -16,6 +15,11 @@ main = defaultMainWithDoctests "doctests"
#else
#ifdef MIN_VERSION_Cabal
-- If the macro is defined, we have new cabal-install,
-- but for some reason we don't have cabal-doctest in package-db
--
-- Probably we are running cabal sdist, when otherwise using new-build
-- workflow
#warning You are configuring this package without cabal-doctest installed. \
The doctests test-suite will not work as a result. \
To fix this, install cabal-doctest before configuring.
@ -27,5 +31,3 @@ main :: IO ()
main = defaultMain
#endif
\end{code}

8
servant-server/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

7
servant-server/servant-server.cabal
View file

@ -26,7 +26,6 @@ tested-with:
GHC==8.2.2
GHC==8.4.3
extra-source-files:
include/*.h
CHANGELOG.md
README.md
@ -103,10 +102,7 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
ghc-options: -Wall -Wno-redundant-constraints
executable greet
main-is: greet.hs
@ -187,4 +183,3 @@ test-suite doctests
ghc-options: -Wall -threaded
if impl(ghc >= 8.2)
x-doctest-options: -fdiagnostics-color=never
include-dirs: include

10
servant-server/src/Servant/Server/Internal.hs
View file

@ -18,8 +18,6 @@
#define HAS_TYPE_ERROR
#endif
#include "overlapping-compat.h"
module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.BasicAuth
@ -256,7 +254,7 @@ methodRouter splitHeaders method proxy status action = leafRouter route'
let bdy = if allowedMethodHead method request then "" else body
in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Verb method status ctypes a) context where
@ -267,7 +265,7 @@ instance OVERLAPPABLE_
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) context where
@ -280,7 +278,7 @@ instance OVERLAPPING_
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
( MimeRender ctype a, ReflectMethod method, KnownNat status,
FramingRender framing ctype, ToStreamGenerator b a
) => HasServer (Stream method status framing ctype b) context where
@ -292,7 +290,7 @@ instance OVERLAPPABLE_
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
( MimeRender ctype a, ReflectMethod method, KnownNat status,
FramingRender framing ctype, ToStreamGenerator b a,
GetHeaders (Headers h b)

7
servant-server/src/Servant/Server/Internal/Context.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -8,8 +7,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
#include "overlapping-compat.h"
module Servant.Server.Internal.Context where
import Data.Proxy
@ -64,11 +61,11 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
class HasContextEntry (context :: [*]) (val :: *) where
getContextEntry :: Context context -> val
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
HasContextEntry xs val => HasContextEntry (notIt ': xs) val where
getContextEntry (_ :. xs) = getContextEntry xs
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
HasContextEntry (val ': xs) val where
getContextEntry (x :. _) = x

11
servant-server/src/Servant/Server/StaticFiles.hs
View file

@ -24,10 +24,6 @@ import Servant.Server
(ServerT, Tagged (..))
import System.FilePath
(addTrailingPathSeparator)
#if !MIN_VERSION_wai_app_static(3,1,0)
import Filesystem.Path.CurrentOS
(decodeString)
#endif
import WaiAppStatic.Storage.Filesystem
(ETagLookup)
@ -84,9 +80,4 @@ serveDirectory = serveDirectoryFileServer
{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}
fixPath :: FilePath -> FilePath
fixPath =
#if MIN_VERSION_wai_app_static(3,1,0)
addTrailingPathSeparator
#else
decodeString . addTrailingPathSeparator
#endif
fixPath = addTrailingPathSeparator

5
servant-server/test/Servant/ServerSpec.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@ -9,11 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
module Servant.ServerSpec where

8
servant/Setup.lhs → servant/Setup.hs
View file

@ -1,4 +1,3 @@
\begin{code}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
@ -16,6 +15,11 @@ main = defaultMainWithDoctests "doctests"
#else
#ifdef MIN_VERSION_Cabal
-- If the macro is defined, we have new cabal-install,
-- but for some reason we don't have cabal-doctest in package-db
--
-- Probably we are running cabal sdist, when otherwise using new-build
-- workflow
#warning You are configuring this package without cabal-doctest installed. \
The doctests test-suite will not work as a result. \
To fix this, install cabal-doctest before configuring.
@ -27,5 +31,3 @@ main :: IO ()
main = defaultMain
#endif
\end{code}

8
servant/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

11
servant/servant.cabal
View file

@ -22,7 +22,6 @@ tested-with:
GHC==8.2.2
GHC==8.4.3
extra-source-files:
include/*.h
CHANGELOG.md
source-repository head
type: git
@ -120,10 +119,7 @@ library
, TypeOperators
, TypeSynonymInstances
, UndecidableInstances
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
ghc-options: -Wall -Wno-redundant-constraints
test-suite spec
type: exitcode-stdio-1.0
@ -146,10 +142,6 @@ test-suite spec
, string-conversions
, text
if !impl(ghc >= 8.0)
build-depends:
semigroups
-- Additonal dependencies
build-depends:
aeson-compat >= 0.3.8 && < 0.4
@ -177,6 +169,5 @@ test-suite doctests
ghc-options: -Wall -threaded
if impl(ghc >= 8.2)
x-doctest-options: -fdiagnostics-color=never
include-dirs: include
x-doctest-source-dirs: test
x-doctest-modules: Servant.LinksSpec

24
servant/src/Servant/API/ContentTypes.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
@ -14,8 +13,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
#include "overlapping-compat.h"
-- | A collection of basic Content-Types (also known as Internet Media
-- Types, or MIME types). Additionally, this module provides classes that
-- encapsulate how to serialize or deserialize values to or from
@ -98,16 +95,13 @@ import qualified Data.Text.Lazy.Encoding as TextL
import Data.Typeable
import GHC.Generics
(Generic)
import qualified GHC.TypeLits as TL
import qualified Network.HTTP.Media as M
import Prelude ()
import Prelude.Compat
import Web.FormUrlEncoded
(FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm)
#if MIN_VERSION_base(4,9,0)
import qualified GHC.TypeLits as TL
#endif
-- * Provided content types
data JSON deriving Typeable
data PlainText deriving Typeable
@ -185,18 +179,16 @@ class (AllMime list) => AllCTRender (list :: [*]) a where
-- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
(Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy (ct ': cts)
amrs = allMimeRender pctyps val
lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
#if MIN_VERSION_base(4,9,0)
instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.")
=> AllCTRender '[] () where
handleAcceptH _ _ _ = error "unreachable"
#endif
--------------------------------------------------------------------------
-- * Unrender
@ -277,13 +269,13 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where
-> a -- value to serialize
-> [(M.MediaType, ByteString)] -- content-types/response pairs
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp
where
bs = mimeRender pctyp a
pctyp = Proxy :: Proxy ctyp
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
( MimeRender ctyp a
, AllMimeRender (ctyp' ': ctyps) a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
@ -299,12 +291,12 @@ instance OVERLAPPABLE_
-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and
-- then this would be taken care of. However there is no more specific instance
-- between that and 'MimeRender JSON a', so we do this instead
instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
where
pctyp = Proxy :: Proxy ctyp
instance OVERLAPPING_
instance {-# OVERLAPPING #-}
( AllMime (ctyp ': ctyp' ': ctyps)
) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where
allMimeRender p _ = zip (allMime p) (repeat "")
@ -334,14 +326,14 @@ instance ( MimeUnrender ctyp a
-- * MimeRender Instances
-- | `encode`
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
ToJSON a => MimeRender JSON a where
mimeRender _ = encode
-- | @urlEncodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance OVERLAPPABLE_
instance {-# OVERLAPPABLE #-}
ToForm a => MimeRender FormUrlEncoded a where
mimeRender _ = urlEncodeAsForm

10
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
@ -15,7 +14,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
#include "overlapping-compat.h"
-- | This module provides facilities for adding headers to a response.
--
-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int
@ -80,10 +78,10 @@ class BuildHeadersTo hs where
-- the values are interspersed with commas before deserialization (see
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
instance OVERLAPPING_ BuildHeadersTo '[] where
instance {-# OVERLAPPING #-} BuildHeadersTo '[] where
buildHeadersTo _ = HNil
instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
=> BuildHeadersTo (Header h v ': xs) where
buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
@ -144,11 +142,11 @@ class AddHeader h v orig new
addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )
instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v
instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v
, new ~ (Headers '[Header h v] a) )
=> AddHeader h v a new where
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

15
servant/src/Servant/API/TypeLevel.hs
View file

@ -41,9 +41,6 @@ module Servant.API.TypeLevel (
-- ** Logic
Or,
And,
-- * Custom type errors
-- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class,
-- which cannot be instantiated.
) where
@ -63,10 +60,8 @@ import Servant.API.Sub
(type (:>))
import Servant.API.Verbs
(Verb)
#if MIN_VERSION_base(4,9,0)
import GHC.TypeLits
(ErrorMessage (..), TypeError)
#endif
@ -222,14 +217,10 @@ type Elem e es = ElemGo e es es
type family ElemGo e es orig :: Constraint where
ElemGo x (x ': xs) orig = ()
ElemGo y (x ': xs) orig = ElemGo y xs orig
#if MIN_VERSION_base(4,9,0)
-- Note [Custom Errors]
ElemGo x '[] orig = TypeError ('ShowType x
':<>: 'Text " expected in list "
':<>: 'ShowType orig)
#else
ElemGo x '[] orig = ElemNotFoundIn x orig
#endif
-- ** Logic
@ -244,12 +235,6 @@ type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
type family And (a :: Constraint) (b :: Constraint) :: Constraint where
And () () = ()
-- * Custom type errors
#if !MIN_VERSION_base(4,9,0)
class ElemNotFoundIn val list
#endif
{- Note [Custom Errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We might try to factor these our more cleanly, but the type synonyms and type

3
servant/test/Servant/API/ContentTypesSpec.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -195,7 +194,6 @@ spec = describe "Servant.API.ContentTypes" $ do
handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"
"foobar" `shouldBe` (Nothing :: Maybe (Either String Int))
#if MIN_VERSION_aeson(0,9,0)
-- aeson >= 0.9 decodes top-level strings
describe "eitherDecodeLenient" $ do
@ -204,7 +202,6 @@ spec = describe "Servant.API.ContentTypes" $ do
-- The Left messages differ, so convert to Maybe
property $ \x -> toMaybe (eitherDecodeLenient x)
`shouldBe` (decode x :: Maybe String)
#endif
data SomeData = SomeData { record1 :: String, record2 :: Int }

4
servant/test/Servant/LinksSpec.hs
View file

@ -1,12 +1,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
#if __GLASGOW_HASKELL__ < 709
{-# OPTIONS_GHC -fcontext-stack=41 #-}
#endif
module Servant.LinksSpec where
import Data.Proxy