Merge pull request #227 from zerobuzz/tosample-for-tuples

ToSample instances for tuples.
This commit is contained in:
Julian Arni 2015-09-18 16:36:08 +02:00
commit 019fad973d
2 changed files with 180 additions and 1 deletions

View file

@ -919,3 +919,156 @@ instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where
instance HasDocs sublayout => HasDocs (Vault :> sublayout) where instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
docsFor Proxy ep = docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy sublayout) ep
-- polymorphic 'ToSample' instances
instance ( ToSample a a
, ToSample b b
) => ToSample (a, b) (a, b) where
toSample _ = (,)
<$> toSample (Proxy :: Proxy a)
<*> toSample (Proxy :: Proxy b)
toSamples _ = render
<$> toSamples (Proxy :: Proxy a)
<*> toSamples (Proxy :: Proxy b)
where render (ta, va) (tb, vb)
= ("(" <> ta <>
", " <> tb <>
")"
, (va, vb))
instance ( ToSample a a
, ToSample b b
, ToSample c c
) => ToSample (a, b, c) (a, b, c) where
toSample _ = (,,)
<$> toSample (Proxy :: Proxy a)
<*> toSample (Proxy :: Proxy b)
<*> toSample (Proxy :: Proxy c)
toSamples _ = render
<$> toSamples (Proxy :: Proxy a)
<*> toSamples (Proxy :: Proxy b)
<*> toSamples (Proxy :: Proxy c)
where render (ta, va) (tb, vb) (tc, vc)
= ("(" <> ta <>
", " <> tb <>
", " <> tc <>
")"
, (va, vb, vc))
instance ( ToSample a a
, ToSample b b
, ToSample c c
, ToSample d d
) => ToSample (a, b, c, d) (a, b, c, d) where
toSample _ = (,,,)
<$> toSample (Proxy :: Proxy a)
<*> toSample (Proxy :: Proxy b)
<*> toSample (Proxy :: Proxy c)
<*> toSample (Proxy :: Proxy d)
toSamples _ = render
<$> toSamples (Proxy :: Proxy a)
<*> toSamples (Proxy :: Proxy b)
<*> toSamples (Proxy :: Proxy c)
<*> toSamples (Proxy :: Proxy d)
where render (ta, va) (tb, vb) (tc, vc) (td, vd)
= ("(" <> ta <>
", " <> tb <>
", " <> tc <>
", " <> td <>
")"
, (va, vb, vc, vd))
instance ( ToSample a a
, ToSample b b
, ToSample c c
, ToSample d d
, ToSample e e
) => ToSample (a, b, c, d, e) (a, b, c, d, e) where
toSample _ = (,,,,)
<$> toSample (Proxy :: Proxy a)
<*> toSample (Proxy :: Proxy b)
<*> toSample (Proxy :: Proxy c)
<*> toSample (Proxy :: Proxy d)
<*> toSample (Proxy :: Proxy e)
toSamples _ = render
<$> toSamples (Proxy :: Proxy a)
<*> toSamples (Proxy :: Proxy b)
<*> toSamples (Proxy :: Proxy c)
<*> toSamples (Proxy :: Proxy d)
<*> toSamples (Proxy :: Proxy e)
where render (ta, va) (tb, vb) (tc, vc) (td, vd) (te, ve)
= ("(" <> ta <>
", " <> tb <>
", " <> tc <>
", " <> td <>
", " <> te <>
")"
, (va, vb, vc, vd, ve))
instance ( ToSample a a
, ToSample b b
, ToSample c c
, ToSample d d
, ToSample e e
, ToSample f f
) => ToSample (a, b, c, d, e, f) (a, b, c, d, e, f) where
toSample _ = (,,,,,)
<$> toSample (Proxy :: Proxy a)
<*> toSample (Proxy :: Proxy b)
<*> toSample (Proxy :: Proxy c)
<*> toSample (Proxy :: Proxy d)
<*> toSample (Proxy :: Proxy e)
<*> toSample (Proxy :: Proxy f)
toSamples _ = render
<$> toSamples (Proxy :: Proxy a)
<*> toSamples (Proxy :: Proxy b)
<*> toSamples (Proxy :: Proxy c)
<*> toSamples (Proxy :: Proxy d)
<*> toSamples (Proxy :: Proxy e)
<*> toSamples (Proxy :: Proxy f)
where render (ta, va) (tb, vb) (tc, vc) (td, vd) (te, ve) (tf, vf)
= ("(" <> ta <>
", " <> tb <>
", " <> tc <>
", " <> td <>
", " <> te <>
", " <> tf <>
")"
, (va, vb, vc, vd, ve, vf))
instance ( ToSample a a
, ToSample b b
, ToSample c c
, ToSample d d
, ToSample e e
, ToSample f f
, ToSample g g
) => ToSample (a, b, c, d, e, f, g) (a, b, c, d, e, f, g) where
toSample _ = (,,,,,,)
<$> toSample (Proxy :: Proxy a)
<*> toSample (Proxy :: Proxy b)
<*> toSample (Proxy :: Proxy c)
<*> toSample (Proxy :: Proxy d)
<*> toSample (Proxy :: Proxy e)
<*> toSample (Proxy :: Proxy f)
<*> toSample (Proxy :: Proxy g)
toSamples _ = render
<$> toSamples (Proxy :: Proxy a)
<*> toSamples (Proxy :: Proxy b)
<*> toSamples (Proxy :: Proxy c)
<*> toSamples (Proxy :: Proxy d)
<*> toSamples (Proxy :: Proxy e)
<*> toSamples (Proxy :: Proxy f)
<*> toSamples (Proxy :: Proxy g)
where render (ta, va) (tb, vb) (tc, vc) (td, vd) (te, ve) (tf, vf) (tg, vg)
= ("(" <> ta <>
", " <> tb <>
", " <> tc <>
", " <> td <>
", " <> te <>
", " <> tf <>
", " <> tg <>
")"
, (va, vb, vc, vd, ve, vf, vg))

View file

@ -1,7 +1,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
@ -42,6 +44,21 @@ spec = describe "Servant.Docs" $ do
md `shouldContain` "get an integer in Json or plain text" md `shouldContain` "get an integer in Json or plain text"
md `shouldContain` "Posts some Json data" md `shouldContain` "Posts some Json data"
describe "tuple samples" $ do
it "looks like expected" $ do
(toSample (Proxy :: Proxy (TT, UT))) `shouldBe` Just (TT1,UT1)
(toSample (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1)
(toSamples (Proxy :: Proxy (TT, UT))) `shouldBe`
[ ("(eins, yks)",(TT1,UT1)), ("(eins, kaks)",(TT1,UT2))
, ("(zwei, yks)",(TT2,UT1)), ("(zwei, kaks)",(TT2,UT2))
]
(toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe`
[ ("(eins, yks, yks)",(TT1,UT1,UT1)), ("(eins, yks, kaks)",(TT1,UT1,UT2))
, ("(eins, kaks, yks)",(TT1,UT2,UT1)), ("(eins, kaks, kaks)",(TT1,UT2,UT2))
, ("(zwei, yks, yks)",(TT2,UT1,UT1)), ("(zwei, yks, kaks)",(TT2,UT1,UT2))
, ("(zwei, kaks, yks)",(TT2,UT2,UT1)), ("(zwei, kaks, kaks)",(TT2,UT2,UT2))
]
where where
tests md = do tests md = do
it "mentions supported content-types" $ do it "mentions supported content-types" $ do
@ -81,7 +98,16 @@ instance ToSample Int Int where
instance MimeRender PlainText Int where instance MimeRender PlainText Int where
mimeRender _ = cs . show mimeRender _ = cs . show
type TestApi1 = Get '[JSON, PlainText] Int type TestApi1 = Get '[JSON, PlainText] Int
:<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
data TT = TT1 | TT2 deriving (Show, Eq)
data UT = UT1 | UT2 deriving (Show, Eq)
instance ToSample TT TT where
toSample _ = Just TT1
toSamples _ = [("eins", TT1), ("zwei", TT2)]
instance ToSample UT UT where
toSample _ = Just UT1
toSamples _ = [("yks", UT1), ("kaks", UT2)]