Add DocOptions with maxSamples field

With DocOptions one can limit maximum number of samples. This is useful for Generic-based instances for recursive data types (e.g. `[]`). Default options set maxSamples to 5.
2015-09-21 13:36:57 +03:00 · 2015-09-21 13:36:57 +03:00 · 42f5795fcc
commit 42f5795fcc
parent f96915e85e
4 changed files with 49 additions and 28 deletions
--- a/servant-docs/example/greet.hs
+++ b/servant-docs/example/greet.hs
@ -112,7 +112,7 @@ extra =
 --
 -- > docs testAPI :: API
 docsGreet :: API
-docsGreet = docsWith [intro1, intro2] extra testApi
+docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi

 main :: IO ()
 main = putStrLn $ markdown docsGreet
--- a/servant-docs/src/Servant/Docs.hs
+++ b/servant-docs/src/Servant/Docs.hs
@ -144,7 +144,9 @@ module Servant.Docs
  ( -- * 'HasDocs' class and key functions
    HasDocs(..), docs, markdown
    -- * 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
    ToSample(..)
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@ -9,6 +9,7 @@
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE RecordWildCards        #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TemplateHaskell        #-}
 {-# LANGUAGE TupleSections          #-}
@ -176,6 +177,16 @@ instance Monoid (ExtraInfo a) where
    ExtraInfo a `mappend` ExtraInfo 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:
 --
 -- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
@ -280,6 +291,7 @@ single :: Endpoint -> Action -> API
 single e a = API mempty (HM.singleton e a)

 -- gimme some lenses
+makeLenses ''DocOptions
 makeLenses ''API
 makeLenses ''Endpoint
 makeLenses ''DocCapture
@ -291,8 +303,14 @@ makeLenses ''Action

 -- | Generate the docs for a given API that implements 'HasDocs'. This is the
 -- default way to create documentation.
+--
+-- prop> docs == docsWithOptions defaultDocOptions
 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.

@ -319,7 +337,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
 extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
          => Proxy endpoint -> Action -> ExtraInfo layout
 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
    -- point at one endpoint.
    in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
@ -336,21 +354,22 @@ extraInfo p action =
 -- 'extraInfo'.
 --
 -- If you only want to add an introduction, use 'docsWithIntros'.
-docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
-docsWith intros (ExtraInfo endpoints) p =
-    docs p & apiIntros <>~ intros
-           & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
+docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
+docsWith opts intros (ExtraInfo endpoints) p =
+    docsWithOptions p opts
+      & apiIntros <>~ intros
+      & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints


 -- | Generate the docs for a given API that implements 'HasDocs' with with any
 -- number of introduction(s)
 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
 --   on documentation generation.
 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
 -- content-types when generating documentation for endpoints that either:
@ -709,11 +728,11 @@ instance
 #endif
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
    => HasDocs (Delete cts a) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    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
          t = Proxy :: Proxy cts
          p = Proxy :: Proxy a
@ -725,12 +744,12 @@ instance
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
         , AllHeaderSamples ls , GetHeaders (HList ls) )
    => HasDocs (Delete cts (Headers ls a)) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
          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.respHeaders .~ hdrs
          t = Proxy :: Proxy cts
@ -742,11 +761,11 @@ instance
 #endif
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
    => HasDocs (Get cts a) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    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
          t = Proxy :: Proxy cts
          p = Proxy :: Proxy a
@ -758,12 +777,12 @@ instance
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
         , AllHeaderSamples ls , GetHeaders (HList ls) )
    => HasDocs (Get cts (Headers ls a)) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
          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.respHeaders .~ hdrs
          t = Proxy :: Proxy cts
@ -784,11 +803,11 @@ instance
 #endif
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
    => HasDocs (Post cts a) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    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.respStatus .~ 201
          t = Proxy :: Proxy cts
@ -801,12 +820,12 @@ instance
         (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
         , AllHeaderSamples ls , GetHeaders (HList ls) )
    => HasDocs (Post cts (Headers ls a)) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
          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.respStatus .~ 201
                           & response.respHeaders .~ hdrs
@ -819,11 +838,11 @@ instance
 #endif
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
    => HasDocs (Put cts a) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    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.respStatus .~ 200
          t = Proxy :: Proxy cts
@ -836,12 +855,12 @@ instance
        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
         , AllHeaderSamples ls , GetHeaders (HList ls) )
    => HasDocs (Put cts (Headers ls a)) where
-  docsFor Proxy (endpoint, action) =
+  docsFor Proxy (endpoint, action) DocOptions{..} =
    single endpoint' action'

    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
          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.respStatus .~ 200
                           & response.respHeaders .~ hdrs
@ -923,7 +942,7 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
          symP = Proxy :: Proxy sym

 instance HasDocs Raw where
-  docsFor _proxy (endpoint, action) =
+  docsFor _proxy (endpoint, action) _ =
    single endpoint action

 -- TODO: We use 'AllMimeRender' here because we need to be able to show the
--- a/servant-docs/test/Servant/DocsSpec.hs
+++ b/servant-docs/test/Servant/DocsSpec.hs
@ -36,7 +36,7 @@ spec = describe "Servant.Docs" $ do
              extraInfo
              (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
              (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
    it "contains the extra info provided" $ do
      md `shouldContain` "Get an Integer"