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

Merge pull request #228 from fizruk/generic-to-sample-#151

Browse source 
Generic ToSample
This commit is contained in:
Julian Arni 2015-09-21 14:30:35 +02:00
commit d1496c9668
9 changed files with 164 additions and 208 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
servant-docs/CHANGELOG.md
View file

@ -2,6 +2,11 @@ HEAD
---- ----
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`)
* Add Generic-based default implementation for `ToSample` class
* Add more `ToSamples` instances: `Bool`, `Ordering`, tuples (up to 7), `[]`, `Maybe`, `Either`, `Const`, `ZipList` and some monoids
* Move `toSample` out of `ToSample` class
* Add a few helper functions to define `toSamples`
0.4 0.4
--- ---

9
servant-docs/example/greet.hs
View file

@ -53,19 +53,14 @@ instance ToParam (MatrixParam "lang" String) where
"Get the greeting message selected language. Default is en." "Get the greeting message selected language. Default is en."
Normal Normal
instance ToSample () () where
toSample _ = Just ()
instance ToSample Greet Greet where instance ToSample Greet Greet where
toSample _ = Just $ Greet "Hello, haskeller!"
toSamples _ = toSamples _ =
[ ("If you use ?capital=true", Greet "HELLO, HASKELLER") [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
, ("If you use ?capital=false", Greet "Hello, haskeller") , ("If you use ?capital=false", Greet "Hello, haskeller")
] ]
instance ToSample Int Int where instance ToSample Int Int where
toSample _ = Just 1729 toSamples _ = singleSample 1729
-- We define some introductory sections, these will appear at the top of the -- We define some introductory sections, these will appear at the top of the
-- documentation. -- documentation.
@ -117,7 +112,7 @@ extra =
-- --
-- > docs testAPI :: API -- > docs testAPI :: API
docsGreet :: API docsGreet :: API
docsGreet = docsWith [intro1, intro2] extra testApi docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
main :: IO () main :: IO ()
main = putStrLn $ markdown docsGreet main = putStrLn $ markdown docsGreet

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

@ -42,6 +42,7 @@ library
, string-conversions , string-conversions
, text , text
, unordered-containers , unordered-containers
, control-monad-omega == 0.3.*
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

8
servant-docs/src/Servant/Docs.hs
View file

@ -144,10 +144,16 @@ module Servant.Docs
( -- * 'HasDocs' class and key functions ( -- * 'HasDocs' class and key functions
HasDocs(..), docs, markdown HasDocs(..), docs, markdown
-- * Generating docs with extra information -- * Generating docs with extra information
, ExtraInfo(..), docsWith, docsWithIntros, extraInfo , docsWith, docsWithIntros, docsWithOptions
, ExtraInfo(..), extraInfo
, DocOptions(..) , defaultDocOptions, maxSamples
, -- * Classes you need to implement for your types , -- * Classes you need to implement for your types
ToSample(..) ToSample(..)
, toSample
, noSamples
, singleSample
, samples
, sampleByteString , sampleByteString
, sampleByteStrings , sampleByteStrings
, ToParam(..) , ToParam(..)

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

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@ -8,6 +9,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
@ -19,10 +21,10 @@
#endif #endif
module Servant.Docs.Internal where module Servant.Docs.Internal where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative import Control.Applicative
#endif import Control.Arrow (second)
import Control.Lens hiding (List) import Control.Lens hiding (List, to, from)
import qualified Control.Monad.Omega as Omega
import Data.ByteString.Conversion (ToByteString, toByteString) import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -175,6 +177,16 @@ instance Monoid (ExtraInfo a) where
ExtraInfo a `mappend` ExtraInfo b = ExtraInfo a `mappend` ExtraInfo b =
ExtraInfo $ HM.unionWith combineAction a b ExtraInfo $ HM.unionWith combineAction a b
-- | Documentation options.
data DocOptions = DocOptions
{ _maxSamples :: Int -- ^ Maximum samples allowed.
} deriving (Show)
-- | Default documentation options.
defaultDocOptions :: DocOptions
defaultDocOptions = DocOptions
{ _maxSamples = 5 }
-- | Type of GET parameter: -- | Type of GET parameter:
-- --
-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter -- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
@ -279,6 +291,7 @@ single :: Endpoint -> Action -> API
single e a = API mempty (HM.singleton e a) single e a = API mempty (HM.singleton e a)
-- gimme some lenses -- gimme some lenses
makeLenses ''DocOptions
makeLenses ''API makeLenses ''API
makeLenses ''Endpoint makeLenses ''Endpoint
makeLenses ''DocCapture makeLenses ''DocCapture
@ -290,8 +303,14 @@ makeLenses ''Action
-- | Generate the docs for a given API that implements 'HasDocs'. This is the -- | Generate the docs for a given API that implements 'HasDocs'. This is the
-- default way to create documentation. -- default way to create documentation.
--
-- prop> docs == docsWithOptions defaultDocOptions
docs :: HasDocs layout => Proxy layout -> API docs :: HasDocs layout => Proxy layout -> API
docs p = docsFor p (defEndpoint, defAction) docs p = docsWithOptions p defaultDocOptions
-- | Generate the docs for a given API that implements 'HasDocs'.
docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API
docsWithOptions p = docsFor p (defEndpoint, defAction)
-- | Closed type family, check if endpoint is exactly within API. -- | Closed type family, check if endpoint is exactly within API.
@ -318,7 +337,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout => Proxy endpoint -> Action -> ExtraInfo layout
extraInfo p action = extraInfo p action =
let api = docsFor p (defEndpoint, defAction) let api = docsFor p (defEndpoint, defAction) defaultDocOptions
-- Assume one endpoint, HasLink constraint means that we should only ever -- Assume one endpoint, HasLink constraint means that we should only ever
-- point at one endpoint. -- point at one endpoint.
in ExtraInfo $ api ^. apiEndpoints & traversed .~ action in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
@ -335,21 +354,22 @@ extraInfo p action =
-- 'extraInfo'. -- 'extraInfo'.
-- --
-- If you only want to add an introduction, use 'docsWithIntros'. -- If you only want to add an introduction, use 'docsWithIntros'.
docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
docsWith intros (ExtraInfo endpoints) p = docsWith opts intros (ExtraInfo endpoints) p =
docs p & apiIntros <>~ intros docsWithOptions p opts
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints & apiIntros <>~ intros
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
-- | Generate the docs for a given API that implements 'HasDocs' with with any -- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s) -- number of introduction(s)
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros intros = docsWith intros mempty docsWithIntros intros = docsWith defaultDocOptions intros mempty
-- | The class that abstracts away the impact of API combinators -- | The class that abstracts away the impact of API combinators
-- on documentation generation. -- on documentation generation.
class HasDocs layout where class HasDocs layout where
docsFor :: Proxy layout -> (Endpoint, Action) -> API docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API
-- | The class that lets us display a sample input or output in the supported -- | The class that lets us display a sample input or output in the supported
-- content-types when generating documentation for endpoints that either: -- content-types when generating documentation for endpoints that either:
@ -373,7 +393,7 @@ class HasDocs layout where
-- > instance ToJSON Greet -- > instance ToJSON Greet
-- > -- >
-- > instance ToSample Greet Greet where -- > instance ToSample Greet Greet where
-- > toSample _ = Just g -- > toSamples _ = singleSample g
-- > -- >
-- > where g = Greet "Hello, haskeller!" -- > where g = Greet "Hello, haskeller!"
-- --
@ -382,17 +402,64 @@ class HasDocs layout where
-- some context (as 'Text') that explains when you're supposed to -- some context (as 'Text') that explains when you're supposed to
-- get the corresponding response. -- get the corresponding response.
class ToSample a b | a -> b where class ToSample a b | a -> b where
{-# MINIMAL (toSample | toSamples) #-}
toSample :: Proxy a -> Maybe b
toSample _ = snd <$> listToMaybe samples
where samples = toSamples (Proxy :: Proxy a)
toSamples :: Proxy a -> [(Text, b)] toSamples :: Proxy a -> [(Text, b)]
toSamples _ = maybe [] (return . ("",)) s default toSamples :: (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
where s = toSample (Proxy :: Proxy a) toSamples = defaultSamples
-- | Sample input or output (if there is at least one).
toSample :: forall a b. ToSample a b => Proxy a -> Maybe b
toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a))
-- | No samples.
noSamples :: [(Text, a)]
noSamples = empty
-- | Single sample without description.
singleSample :: a -> [(Text, a)]
singleSample x = [("", x)]
-- | Samples without documentation.
samples :: [a] -> [(Text, a)]
samples = map ("",)
-- | Default sample Generic-based inputs/outputs.
defaultSamples :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
-- | @'ToSample'@ for Generics.
--
-- The use of @'Omega'@ allows for more productive sample generation.
class GToSample t s where
gtoSamples :: proxy t -> Omega.Omega (Text, s x)
instance GToSample U1 U1 where
gtoSamples _ = Omega.each (singleSample U1)
instance GToSample V1 V1 where
gtoSamples _ = empty
instance (GToSample p p', GToSample q q') => GToSample (p :*: q) (p' :*: q') where
gtoSamples _ = render <$> ps <*> qs
where
ps = gtoSamples (Proxy :: Proxy p)
qs = gtoSamples (Proxy :: Proxy q)
render (ta, a) (tb, b)
| T.null ta || T.null tb = (ta <> tb, a :*: b)
| otherwise = (ta <> ", " <> tb, a :*: b)
instance (GToSample p p', GToSample q q') => GToSample (p :+: q) (p' :+: q') where
gtoSamples _ = lefts <|> rights
where
lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
instance ToSample a b => GToSample (K1 i a) (K1 i b) where
gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
instance (GToSample f g) => GToSample (M1 i a f) (M1 i a g) where
gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
instance ToSample a b => ToSample (Headers ls a) b where instance ToSample a b => ToSample (Headers ls a) b where
toSample _ = toSample (Proxy :: Proxy a)
toSamples _ = toSamples (Proxy :: Proxy a) toSamples _ = toSamples (Proxy :: Proxy a)
@ -661,11 +728,11 @@ instance
#endif #endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Delete cts a) where => HasDocs (Delete cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocDELETE where endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -677,12 +744,12 @@ instance
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Delete cts (Headers ls a)) where => HasDocs (Delete cts (Headers ls a)) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocDELETE endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
@ -694,11 +761,11 @@ instance
#endif #endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Get cts a) where => HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocGET where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -710,12 +777,12 @@ instance
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Get cts (Headers ls a)) where => HasDocs (Get cts (Headers ls a)) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocGET endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
@ -736,11 +803,11 @@ instance
#endif #endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Post cts a) where => HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
& response.respStatus .~ 201 & response.respStatus .~ 201
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
@ -753,12 +820,12 @@ instance
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Post cts (Headers ls a)) where => HasDocs (Post cts (Headers ls a)) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPOST endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
& response.respStatus .~ 201 & response.respStatus .~ 201
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
@ -771,11 +838,11 @@ instance
#endif #endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Put cts a) where => HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
& response.respStatus .~ 200 & response.respStatus .~ 200
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
@ -788,12 +855,12 @@ instance
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Put cts (Headers ls a)) where => HasDocs (Put cts (Headers ls a)) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPUT endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings t p action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ supportedTypes t
& response.respStatus .~ 200 & response.respStatus .~ 200
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
@ -875,7 +942,7 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
symP = Proxy :: Proxy sym symP = Proxy :: Proxy sym
instance HasDocs Raw where instance HasDocs Raw where
docsFor _proxy (endpoint, action) = docsFor _proxy (endpoint, action) _ =
single endpoint action single endpoint action
-- TODO: We use 'AllMimeRender' here because we need to be able to show the -- TODO: We use 'AllMimeRender' here because we need to be able to show the
@ -920,155 +987,33 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
docsFor Proxy ep = docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy sublayout) ep
-- ToSample instances for simple types
instance ToSample () ()
instance ToSample Bool Bool
instance ToSample Ordering Ordering
-- polymorphic 'ToSample' instances -- polymorphic ToSample instances
instance (ToSample a a, ToSample b b) => ToSample (a, b) (a, b)
instance (ToSample a a, ToSample b b, ToSample c c) => ToSample (a, b, c) (a, b, c)
instance (ToSample a a, ToSample b b, ToSample c c, ToSample d d) => ToSample (a, b, c, d) (a, b, c, d)
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)
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)
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)
instance ( ToSample a a instance ToSample a a => ToSample (Maybe a) (Maybe a)
, ToSample b b instance (ToSample a a, ToSample b b) => ToSample (Either a b) (Either a b)
) => ToSample (a, b) (a, b) where instance ToSample a a => ToSample [a] [a]
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 instances for Control.Applicative types
, ToSample b b instance ToSample a a => ToSample (Const a b) (Const a b)
, ToSample c c instance ToSample a a => ToSample (ZipList a) (ZipList a)
) => 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 instances for Data.Monoid newtypes
, ToSample b b instance ToSample All All
, ToSample c c instance ToSample Any Any
, ToSample d d instance ToSample a a => ToSample (Sum a) (Sum a)
) => ToSample (a, b, c, d) (a, b, c, d) where instance ToSample a a => ToSample (Product a) (Product a)
toSample _ = (,,,) instance ToSample a a => ToSample (First a) (First a)
<$> toSample (Proxy :: Proxy a) instance ToSample a a => ToSample (Last a) (Last a)
<*> toSample (Proxy :: Proxy b) instance ToSample a a => ToSample (Dual a) (Dual a)
<*> 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))

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

@ -36,7 +36,7 @@ spec = describe "Servant.Docs" $ do
extraInfo extraInfo
(Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
(defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
md = markdown (docsWith [] extra (Proxy :: Proxy TestApi1)) md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
tests md tests md
it "contains the extra info provided" $ do it "contains the extra info provided" $ do
md `shouldContain` "Get an Integer" md `shouldContain` "Get an Integer"
@ -49,14 +49,18 @@ spec = describe "Servant.Docs" $ do
(toSample (Proxy :: Proxy (TT, UT))) `shouldBe` Just (TT1,UT1) (toSample (Proxy :: Proxy (TT, UT))) `shouldBe` Just (TT1,UT1)
(toSample (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1) (toSample (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1)
(toSamples (Proxy :: Proxy (TT, UT))) `shouldBe` (toSamples (Proxy :: Proxy (TT, UT))) `shouldBe`
[ ("(eins, yks)",(TT1,UT1)), ("(eins, kaks)",(TT1,UT2)) [ ("eins, yks",(TT1,UT1)), ("eins, kaks",(TT1,UT2))
, ("(zwei, yks)",(TT2,UT1)), ("(zwei, kaks)",(TT2,UT2)) , ("zwei, yks",(TT2,UT1)), ("zwei, kaks",(TT2,UT2))
] ]
(toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe` (toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe`
[ ("(eins, yks, yks)",(TT1,UT1,UT1)), ("(eins, yks, kaks)",(TT1,UT1,UT2)) [ ("eins, yks, yks",(TT1,UT1,UT1))
, ("(eins, kaks, yks)",(TT1,UT2,UT1)), ("(eins, kaks, kaks)",(TT1,UT2,UT2)) , ("eins, yks, kaks",(TT1,UT1,UT2))
, ("(zwei, yks, yks)",(TT2,UT1,UT1)), ("(zwei, yks, kaks)",(TT2,UT1,UT2)) , ("zwei, yks, yks",(TT2,UT1,UT1))
, ("(zwei, kaks, yks)",(TT2,UT2,UT1)), ("(zwei, kaks, kaks)",(TT2,UT2,UT2)) , ("eins, kaks, yks",(TT1,UT2,UT1))
, ("zwei, yks, kaks",(TT2,UT1,UT2))
, ("eins, kaks, kaks",(TT1,UT2,UT2))
, ("zwei, kaks, yks",(TT2,UT2,UT1))
, ("zwei, kaks, kaks",(TT2,UT2,UT2))
] ]
where where
@ -87,13 +91,13 @@ data Datatype1 = Datatype1 { dt1field1 :: String
instance ToJSON Datatype1 instance ToJSON Datatype1
instance ToSample Datatype1 Datatype1 where instance ToSample Datatype1 Datatype1 where
toSample _ = Just $ Datatype1 "field 1" 13 toSamples _ = singleSample $ Datatype1 "field 1" 13
instance ToSample String String where instance ToSample Char Char where
toSample _ = Just "a string" toSamples _ = samples ['a'..'z']
instance ToSample Int Int where instance ToSample Int Int where
toSample _ = Just 17 toSamples _ = singleSample 17
instance MimeRender PlainText Int where instance MimeRender PlainText Int where
mimeRender _ = cs . show mimeRender _ = cs . show
@ -105,9 +109,7 @@ data TT = TT1 | TT2 deriving (Show, Eq)
data UT = UT1 | UT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq)
instance ToSample TT TT where instance ToSample TT TT where
toSample _ = Just TT1
toSamples _ = [("eins", TT1), ("zwei", TT2)] toSamples _ = [("eins", TT1), ("zwei", TT2)]
instance ToSample UT UT where instance ToSample UT UT where
toSample _ = Just UT1
toSamples _ = [("yks", UT1), ("kaks", UT2)] toSamples _ = [("yks", UT1), ("kaks", UT2)]

6
servant-examples/tutorial/T10.hs
View file

@ -24,7 +24,7 @@ instance ToCapture (Capture "y" Int) where
toCapture _ = DocCapture "y" "(integer) position on the y axis" toCapture _ = DocCapture "y" "(integer) position on the y axis"
instance ToSample T3.Position T3.Position where instance ToSample T3.Position T3.Position where
toSample _ = Just (T3.Position 3 14) toSamples _ = singleSample (T3.Position 3 14)
instance ToParam (QueryParam "name" String) where instance ToParam (QueryParam "name" String) where
toParam _ = toParam _ =
@ -43,10 +43,10 @@ ci :: T3.ClientInfo
ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
instance ToSample T3.ClientInfo T3.ClientInfo where instance ToSample T3.ClientInfo T3.ClientInfo where
toSample _ = Just ci toSamples _ = singleSample ci
instance ToSample T3.Email T3.Email where instance ToSample T3.Email T3.Email where
toSample _ = Just (T3.emailForClient ci) toSamples _ = singleSample (T3.emailForClient ci)
api :: Proxy DocsAPI api :: Proxy DocsAPI
api = Proxy api = Proxy

1
stack-ghc-7.8.4.yaml
View file

@ -19,4 +19,5 @@ extra-deps:
- engine-io-wai-1.0.3 - engine-io-wai-1.0.3
- socket-io-1.3.3 - socket-io-1.3.3
- stm-delay-0.1.1.1 - stm-delay-0.1.1.1
- control-monad-omega-0.3.1
resolver: lts-2.22 resolver: lts-2.22

1
stack.yaml
View file

@ -14,4 +14,5 @@ packages:
- servant-server/ - servant-server/
extra-deps: extra-deps:
- engine-io-wai-1.0.2 - engine-io-wai-1.0.2
- control-monad-omega-0.3.1
resolver: nightly-2015-09-10 resolver: nightly-2015-09-10