less OverlappingInstances noise

This commit is contained in:
Julian K. Arni 2015-12-27 17:54:29 +01:00
parent 9cc344b95b
commit e7c9084917
31 changed files with 197 additions and 257 deletions

View file

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

View file

@ -30,3 +30,4 @@ library
, blaze-html , blaze-html
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
include-dirs: include

View file

@ -3,10 +3,8 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
-- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s -- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s
-- `ToMarkup` class and `Html` datatype. -- `ToMarkup` class and `Html` datatype.
-- You should only need to import this module for it's instances and the -- You should only need to import this module for it's instances and the
@ -29,17 +27,9 @@ data HTML deriving Typeable
instance Accept HTML where instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8") contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToMarkup a => MimeRender HTML a where
mimeRender _ = renderHtml . toHtml mimeRender _ = renderHtml . toHtml
instance instance OVERLAPPING_ MimeRender HTML Html where
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender HTML Html where
mimeRender _ = renderHtml mimeRender _ = renderHtml

View file

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

View file

@ -27,3 +27,4 @@ library
, vector , vector
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
include-dirs: include

View file

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

View file

@ -49,6 +49,7 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
include-dirs: include
test-suite spec test-suite spec
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0

View file

@ -8,9 +8,8 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} #include "overlapping-compat.h"
#endif
-- | This module provides 'client' which can automatically generate -- | This module provides 'client' which can automatically generate
-- querying functions for each endpoint just from the type representing your -- querying functions for each endpoint just from the type representing your
-- API. -- API.
@ -123,19 +122,13 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
type Client (Delete cts' a) = ExceptT ServantError IO a type Client (Delete cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Delete cts ()) where HasClient (Delete cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO () type Client (Delete cts ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
@ -143,10 +136,7 @@ instance
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
) => HasClient (Delete cts' (Headers ls a)) where ) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
@ -160,19 +150,13 @@ instance
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = ExceptT ServantError IO result type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Get (ct ': cts) ()) where HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
@ -180,10 +164,7 @@ instance
-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where ) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
@ -240,19 +221,13 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = ExceptT ServantError IO a type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Post (ct ': cts) ()) where HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
@ -260,10 +235,7 @@ instance
-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where ) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
@ -277,19 +249,13 @@ instance
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = ExceptT ServantError IO a type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Put (ct ': cts) ()) where HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
@ -297,10 +263,7 @@ instance
-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where ) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
@ -314,19 +277,13 @@ instance
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Patch (ct ': cts) ()) where HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
@ -334,10 +291,7 @@ instance
-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

View file

@ -6,9 +6,6 @@
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -20,6 +17,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.ClientSpec where module Servant.ClientSpec where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -323,33 +321,21 @@ pathGen = fmap NonEmpty path
class GetNth (n :: Nat) a b | n a -> b where class GetNth (n :: Nat) a b | n a -> b where
getNth :: Proxy n -> a -> b getNth :: Proxy n -> a -> b
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
GetNth 0 (x :<|> y) x where GetNth 0 (x :<|> y) x where
getNth _ (x :<|> _) = x getNth _ (x :<|> _) = x
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(GetNth (n - 1) x y) => GetNth n (a :<|> x) y where (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where
getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x
class GetLast a b | a -> b where class GetLast a b | a -> b where
getLast :: a -> b getLast :: a -> b
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(GetLast b c) => GetLast (a :<|> b) c where (GetLast b c) => GetLast (a :<|> b) c where
getLast (_ :<|> b) = getLast b getLast (_ :<|> b) = getLast b
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
GetLast a a where GetLast a a where
getLast a = a getLast a = a

View file

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

View file

@ -49,6 +49,7 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
include-dirs: include
executable greet-docs executable greet-docs
main-is: greet.hs main-is: greet.hs

View file

@ -16,9 +16,8 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} #include "overlapping-compat.h"
#endif
module Servant.Docs.Internal where module Servant.Docs.Internal where
import Control.Applicative import Control.Applicative
@ -661,10 +660,7 @@ markdown api = unlines $
-- | The generated docs for @a ':<|>' b@ just appends the docs -- | The generated docs for @a ':<|>' b@ just appends the docs
-- for @a@ with the docs for @b@. -- for @a@ with the docs for @b@.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(HasDocs layout1, HasDocs layout2) (HasDocs layout1, HasDocs layout2)
=> HasDocs (layout1 :<|> layout2) where => HasDocs (layout1 :<|> layout2) where
@ -692,10 +688,7 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
symP = Proxy :: Proxy sym symP = Proxy :: Proxy sym
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Delete cts a) where => HasDocs (Delete cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -707,10 +700,7 @@ instance
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a (ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Delete cts (Headers ls a)) where => HasDocs (Delete cts (Headers ls a)) where
@ -725,10 +715,7 @@ instance
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Get cts a) where => HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -740,10 +727,7 @@ instance
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a (ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Get cts (Headers ls a)) where => HasDocs (Get cts (Headers ls a)) where
@ -767,10 +751,7 @@ instance (KnownSymbol sym, HasDocs sublayout)
action' = over headers (|> headername) action action' = over headers (|> headername) action
headername = pack $ symbolVal (Proxy :: Proxy sym) headername = pack $ symbolVal (Proxy :: Proxy sym)
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Post cts a) where => HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -783,10 +764,7 @@ instance
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a (ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Post cts (Headers ls a)) where => HasDocs (Post cts (Headers ls a)) where
@ -802,10 +780,7 @@ instance
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Put cts a) where => HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -818,10 +793,7 @@ instance
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( ToSample a, IsNonEmpty cts, AllMimeRender cts a, ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
AllHeaderSamples ls , GetHeaders (HList ls) ) AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Put cts (Headers ls a)) where => HasDocs (Put cts (Headers ls a)) where

View file

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

View file

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

View file

@ -33,6 +33,7 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
include-dirs: include
test-suite spec test-suite spec

View file

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

View file

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

View file

@ -49,6 +49,7 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
include-dirs: include
executable counter executable counter
main-is: counter.hs main-is: counter.hs

View file

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

View file

@ -30,3 +30,4 @@ library
, servant == 0.5.* , servant == 0.5.*
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
include-dirs: include

View file

@ -3,9 +3,8 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} #include "overlapping-compat.h"
#endif
-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s
-- `ToHtml` class and `Html` datatype. -- `ToHtml` class and `Html` datatype.
@ -28,16 +27,10 @@ data HTML deriving Typeable
instance Accept HTML where instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8") contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToHtml a => MimeRender HTML a where ToHtml a => MimeRender HTML a where
mimeRender _ = renderBS . toHtml mimeRender _ = renderBS . toHtml
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender HTML (Html a) where MimeRender HTML (Html a) where
mimeRender _ = renderBS mimeRender _ = renderBS

View file

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

View file

@ -34,6 +34,7 @@ library
wai >= 3.0 && <3.1 wai >= 3.0 && <3.1
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
include-dirs: include
executable mock-app executable mock-app
main-is: main.hs main-is: main.hs

View file

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

View file

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

View file

@ -69,6 +69,7 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
include-dirs: include
executable greet executable greet
main-is: greet.hs main-is: greet.hs
@ -134,3 +135,4 @@ test-suite doctests
buildable: True buildable: True
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -threaded ghc-options: -threaded
include-dirs: include

View file

@ -8,9 +8,8 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} #include "overlapping-compat.h"
#endif
module Servant.Server.Internal module Servant.Server.Internal
( module Servant.Server.Internal ( module Servant.Server.Internal
@ -206,10 +205,7 @@ methodRouterEmpty method action = LeafRouter route'
-- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to -- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to
-- painlessly error out if the conditions for a successful deletion -- painlessly error out if the conditions for a successful deletion
-- are not met. -- are not met.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a ( AllCTRender ctypes a
) => HasServer (Delete ctypes a) where ) => HasServer (Delete ctypes a) where
@ -217,10 +213,7 @@ instance
route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Delete ctypes ()) where HasServer (Delete ctypes ()) where
type ServerT (Delete ctypes ()) m = m () type ServerT (Delete ctypes ()) m = m ()
@ -228,10 +221,7 @@ instance
route Proxy = methodRouterEmpty methodDelete route Proxy = methodRouterEmpty methodDelete
-- Add response headers -- Add response headers
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v ( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Delete ctypes (Headers h v)) where ) => HasServer (Delete ctypes (Headers h v)) where
@ -252,10 +242,7 @@ instance
-- (returning a status code of 200). If there was no @Accept@ header or it -- (returning a status code of 200). If there was no @Accept@ header or it
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- was @*\/\*@, we return encode using the first @Content-Type@ type on the
-- list. -- list.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a ) => HasServer (Get ctypes a) where ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
type ServerT (Get ctypes a) m = m a type ServerT (Get ctypes a) m = m a
@ -263,10 +250,7 @@ instance
route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-- '()' ==> 204 No Content -- '()' ==> 204 No Content
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Get ctypes ()) where HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m () type ServerT (Get ctypes ()) m = m ()
@ -274,10 +258,7 @@ instance
route Proxy = methodRouterEmpty methodGet route Proxy = methodRouterEmpty methodGet
-- Add response headers -- Add response headers
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v ( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Get ctypes (Headers h v)) where ) => HasServer (Get ctypes (Headers h v)) where
@ -329,10 +310,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
-- (returning a status code of 201). If there was no @Accept@ header or it -- (returning a status code of 201). If there was no @Accept@ header or it
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- was @*\/\*@, we return encode using the first @Content-Type@ type on the
-- list. -- list.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where ) => HasServer (Post ctypes a) where
@ -340,10 +318,7 @@ instance
route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Post ctypes ()) where HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m () type ServerT (Post ctypes ()) m = m ()
@ -351,10 +326,7 @@ instance
route Proxy = methodRouterEmpty methodPost route Proxy = methodRouterEmpty methodPost
-- Add response headers -- Add response headers
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v ( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Post ctypes (Headers h v)) where ) => HasServer (Post ctypes (Headers h v)) where
@ -375,20 +347,14 @@ instance
-- (returning a status code of 200). If there was no @Accept@ header or it -- (returning a status code of 200). If there was no @Accept@ header or it
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- was @*\/\*@, we return encode using the first @Content-Type@ type on the
-- list. -- list.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a) => HasServer (Put ctypes a) where ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
type ServerT (Put ctypes a) m = m a type ServerT (Put ctypes a) m = m a
route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Put ctypes ()) where HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m () type ServerT (Put ctypes ()) m = m ()
@ -396,10 +362,7 @@ instance
route Proxy = methodRouterEmpty methodPut route Proxy = methodRouterEmpty methodPut
-- Add response headers -- Add response headers
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v ( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Put ctypes (Headers h v)) where ) => HasServer (Put ctypes (Headers h v)) where
@ -418,20 +381,14 @@ instance
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 200 along the way. -- yielding status code 200 along the way.
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a) => HasServer (Patch ctypes a) where ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
type ServerT (Patch ctypes a) m = m a type ServerT (Patch ctypes a) m = m a
route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Patch ctypes ()) where HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m () type ServerT (Patch ctypes ()) m = m ()
@ -439,10 +396,7 @@ instance
route Proxy = methodRouterEmpty methodPatch route Proxy = methodRouterEmpty methodPatch
-- Add response headers -- Add response headers
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v ( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Patch ctypes (Headers h v)) where ) => HasServer (Patch ctypes (Headers h v)) where

View file

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

View file

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

View file

@ -81,6 +81,7 @@ library
, TypeSynonymInstances , TypeSynonymInstances
, UndecidableInstances , UndecidableInstances
ghc-options: -Wall ghc-options: -Wall
include-dirs: include
test-suite spec test-suite spec
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
@ -118,3 +119,4 @@ test-suite doctests
buildable: True buildable: True
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -threaded ghc-options: -threaded
include-dirs: include

View file

@ -12,11 +12,9 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
#include "overlapping-compat.h"
-- | This module provides facilities for adding headers to a response. -- | This module provides facilities for adding headers to a response.
-- --
-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int
@ -68,19 +66,12 @@ class BuildHeadersTo hs where
-- the values are interspersed with commas before deserialization (see -- the values are interspersed with commas before deserialization (see
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>) -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
instance instance OVERLAPPING_ BuildHeadersTo '[] where
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
BuildHeadersTo '[] where
buildHeadersTo _ = HNil buildHeadersTo _ = HNil
instance instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h
#if MIN_VERSION_base(4,8,0) , Contains h xs ~ 'False)
{-# OVERLAPPABLE #-} => BuildHeadersTo ((Header h v) ': xs) where
#endif
( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False
) => BuildHeadersTo ((Header h v) ': xs) where
buildHeadersTo headers = buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
@ -96,38 +87,22 @@ instance
class GetHeaders ls where class GetHeaders ls where
getHeaders :: ls -> [HTTP.Header] getHeaders :: ls -> [HTTP.Header]
instance instance OVERLAPPING_ GetHeaders (HList '[]) where
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
GetHeaders (HList '[]) where
getHeaders _ = [] getHeaders _ = []
instance instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
#if MIN_VERSION_base(4,8,0) => GetHeaders (HList (Header h x ': xs)) where
{-# OVERLAPPABLE #-}
#endif
( KnownSymbol h, ToByteString x, GetHeaders (HList xs)
) => GetHeaders (HList (Header h x ': xs)) where
getHeaders hdrs = case hdrs of getHeaders hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest
MissingHeader `HCons` rest -> getHeaders rest MissingHeader `HCons` rest -> getHeaders rest
where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
instance instance OVERLAPPING_ GetHeaders (Headers '[] a) where
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
GetHeaders (Headers '[] a) where
getHeaders _ = [] getHeaders _ = []
instance instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v)
#if MIN_VERSION_base(4,8,0) => GetHeaders (Headers (Header h v ': rest) a) where
{-# OVERLAPPABLE #-}
#endif
( KnownSymbol h, GetHeaders (HList rest), ToByteString v
) => GetHeaders (Headers (Header h v ': rest) a) where
getHeaders hs = getHeaders $ getHeadersHList hs getHeaders hs = getHeaders $ getHeadersHList hs
-- * Adding -- * Adding
@ -138,21 +113,13 @@ class AddHeader h v orig new
addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
instance instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False)
#if MIN_VERSION_base(4,8,0) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
{-# OVERLAPPING #-}
#endif
( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False
) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
instance instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v
#if MIN_VERSION_base(4,8,0) , new ~ (Headers '[Header h v] a))
{-# OVERLAPPABLE #-} => AddHeader h v a new where
#endif
( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a)
) => AddHeader h v a new where
addHeader a resp = Headers resp (HCons (Header a) HNil) addHeader a resp = Headers resp (HCons (Header a) HNil)
type family Contains x xs where type family Contains x xs where