@@ -1,6 +1,7 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
45{-# LANGUAGE DeriveGeneric #-}
56{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE FlexibleInstances #-}
@@ -8,6 +9,7 @@
89{-# LANGUAGE MultiParamTypeClasses #-}
910{-# LANGUAGE OverloadedStrings #-}
1011{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RecordWildCards #-}
1113{-# LANGUAGE ScopedTypeVariables #-}
1214{-# LANGUAGE TemplateHaskell #-}
1315{-# LANGUAGE TupleSections #-}
@@ -19,10 +21,10 @@
1921#endif
2022module Servant.Docs.Internal where
2123
22−#if !MIN_VERSION_base(4,8,0)
2324import Control.Applicative
24−#endif
25−import Control.Lens hiding (List)
25+import Control.Arrow (second)
26+import Control.Lens hiding (List, to, from)
27+import qualified Control.Monad.Omega as Omega
2628import Data.ByteString.Conversion (ToByteString, toByteString)
2729import Data.ByteString.Lazy.Char8 (ByteString)
2830import qualified Data.CaseInsensitive as CI
@@ -175,6 +177,16 @@ instance Monoid (ExtraInfo a) where
175177 ExtraInfo a `mappend` ExtraInfo b =
176178 ExtraInfo $ HM.unionWith combineAction a b
177179
180+-- | Documentation options.
181+data DocOptions = DocOptions
182+ { _maxSamples :: Int -- ^ Maximum samples allowed.
183+ } deriving (Show)
184+
185+-- | Default documentation options.
186+defaultDocOptions :: DocOptions
187+defaultDocOptions = DocOptions
188+ { _maxSamples = 5 }
189+
178190-- | Type of GET parameter:
179191--
180192-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
@@ -279,6 +291,7 @@ single :: Endpoint -> Action -> API
279291single e a = API mempty (HM.singleton e a)
280292
281293-- gimme some lenses
294+makeLenses ''DocOptions
282295makeLenses ''API
283296makeLenses ''Endpoint
284297makeLenses ''DocCapture
@@ -290,8 +303,14 @@ makeLenses ''Action
290303
291304-- | Generate the docs for a given API that implements 'HasDocs'. This is the
292305-- default way to create documentation.
306+--
307+-- prop> docs == docsWithOptions defaultDocOptions
293308docs :: HasDocs layout => Proxy layout -> API
294−docs p = docsFor p (defEndpoint, defAction)
309+docs p = docsWithOptions p defaultDocOptions
310+
311+-- | Generate the docs for a given API that implements 'HasDocs'.
312+docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API
313+docsWithOptions p = docsFor p (defEndpoint, defAction)
295314
296315-- | Closed type family, check if endpoint is exactly within API.
297316
@@ -318,7 +337,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
318337extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
319338 => Proxy endpoint -> Action -> ExtraInfo layout
320339extraInfo p action =
321− let api = docsFor p (defEndpoint, defAction)
340+ let api = docsFor p (defEndpoint, defAction) defaultDocOptions
322341 -- Assume one endpoint, HasLink constraint means that we should only ever
323342 -- point at one endpoint.
324343 in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
@@ -335,21 +354,22 @@ extraInfo p action =
335354-- 'extraInfo'.
336355--
337356-- If you only want to add an introduction, use 'docsWithIntros'.
338−docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
339−docsWith intros (ExtraInfo endpoints) p =
340− docs p & apiIntros <>~ intros
341− & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
357+docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
358+docsWith opts intros (ExtraInfo endpoints) p =
359+ docsWithOptions p opts
360+ & apiIntros <>~ intros
361+ & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
342362
343363
344364-- | Generate the docs for a given API that implements 'HasDocs' with with any
345365-- number of introduction(s)
346366docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
347−docsWithIntros intros = docsWith intros mempty
367+docsWithIntros intros = docsWith defaultDocOptions intros mempty
348368
349369-- | The class that abstracts away the impact of API combinators
350370-- on documentation generation.
351371class HasDocs layout where
352− docsFor :: Proxy layout -> (Endpoint, Action) -> API
372+ docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API
353373
354374-- | The class that lets us display a sample input or output in the supported
355375-- content-types when generating documentation for endpoints that either:
@@ -373,7 +393,7 @@ class HasDocs layout where
373393-- > instance ToJSON Greet
374394-- >
375395-- > instance ToSample Greet Greet where
376−-- > toSample _ = Just g
396+-- > toSamples _ = singleSample g
377397-- >
378398-- > where g = Greet "Hello, haskeller!"
379399--
@@ -382,17 +402,64 @@ class HasDocs layout where
382402-- some context (as 'Text') that explains when you're supposed to
383403-- get the corresponding response.
384404class ToSample a b | a -> b where
385− {-# MINIMAL (toSample | toSamples) #-}
386− toSample :: Proxy a -> Maybe b
387− toSample _ = snd <$> listToMaybe samples
388− where samples = toSamples (Proxy :: Proxy a)
389−
390405 toSamples :: Proxy a -> [(Text, b)]
391− toSamples _ = maybe [] (return . ("",)) s
392− where s = toSample (Proxy :: Proxy a)
406+ default toSamples :: (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
407+ toSamples = defaultSamples
408+
409+-- | Sample input or output (if there is at least one).
410+toSample :: forall a b. ToSample a b => Proxy a -> Maybe b
411+toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a))
412+
413+-- | No samples.
414+noSamples :: [(Text, a)]
415+noSamples = empty
416+
417+-- | Single sample without description.
418+singleSample :: a -> [(Text, a)]
419+singleSample x = [("", x)]
420+
421+-- | Samples without documentation.
422+samples :: [a] -> [(Text, a)]
423+samples = map ("",)
424+
425+-- | Default sample Generic-based inputs/outputs.
426+defaultSamples :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
427+defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
428+
429+-- | @'ToSample'@ for Generics.
430+--
431+-- The use of @'Omega'@ allows for more productive sample generation.
432+class GToSample t s where
433+ gtoSamples :: proxy t -> Omega.Omega (Text, s x)
434+
435+instance GToSample U1 U1 where
436+ gtoSamples _ = Omega.each (singleSample U1)
437+
438+instance GToSample V1 V1 where
439+ gtoSamples _ = empty
440+
441+instance (GToSample p p', GToSample q q') => GToSample (p :*: q) (p' :*: q') where
442+ gtoSamples _ = render <$> ps <*> qs
443+ where
444+ ps = gtoSamples (Proxy :: Proxy p)
445+ qs = gtoSamples (Proxy :: Proxy q)
446+ render (ta, a) (tb, b)
447+ | T.null ta || T.null tb = (ta <> tb, a :*: b)
448+ | otherwise = (ta <> ", " <> tb, a :*: b)
449+
450+instance (GToSample p p', GToSample q q') => GToSample (p :+: q) (p' :+: q') where
451+ gtoSamples _ = lefts <|> rights
452+ where
453+ lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
454+ rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
455+
456+instance ToSample a b => GToSample (K1 i a) (K1 i b) where
457+ gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
458+
459+instance (GToSample f g) => GToSample (M1 i a f) (M1 i a g) where
460+ gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
393461
394462instance ToSample a b => ToSample (Headers ls a) b where
395− toSample _ = toSample (Proxy :: Proxy a)
396463 toSamples _ = toSamples (Proxy :: Proxy a)
397464
398465
@@ -661,11 +728,11 @@ instance
661728#endif
662729 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
663730 => HasDocs (Delete cts a) where
664− docsFor Proxy (endpoint, action) =
731+ docsFor Proxy (endpoint, action) DocOptions{..} =
665732 single endpoint' action'
666733
667734 where endpoint' = endpoint & method .~ DocDELETE
668− action' = action & response.respBody .~ sampleByteStrings t p
735+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
669736 & response.respTypes .~ supportedTypes t
670737 t = Proxy :: Proxy cts
671738 p = Proxy :: Proxy a
@@ -677,12 +744,12 @@ instance
677744 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
678745 , AllHeaderSamples ls , GetHeaders (HList ls) )
679746 => HasDocs (Delete cts (Headers ls a)) where
680− docsFor Proxy (endpoint, action) =
747+ docsFor Proxy (endpoint, action) DocOptions{..} =
681748 single endpoint' action'
682749
683750 where hdrs = allHeaderToSample (Proxy :: Proxy ls)
684751 endpoint' = endpoint & method .~ DocDELETE
685− action' = action & response.respBody .~ sampleByteStrings t p
752+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
686753 & response.respTypes .~ supportedTypes t
687754 & response.respHeaders .~ hdrs
688755 t = Proxy :: Proxy cts
@@ -694,11 +761,11 @@ instance
694761#endif
695762 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
696763 => HasDocs (Get cts a) where
697− docsFor Proxy (endpoint, action) =
764+ docsFor Proxy (endpoint, action) DocOptions{..} =
698765 single endpoint' action'
699766
700767 where endpoint' = endpoint & method .~ DocGET
701− action' = action & response.respBody .~ sampleByteStrings t p
768+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
702769 & response.respTypes .~ supportedTypes t
703770 t = Proxy :: Proxy cts
704771 p = Proxy :: Proxy a
@@ -710,12 +777,12 @@ instance
710777 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
711778 , AllHeaderSamples ls , GetHeaders (HList ls) )
712779 => HasDocs (Get cts (Headers ls a)) where
713− docsFor Proxy (endpoint, action) =
780+ docsFor Proxy (endpoint, action) DocOptions{..} =
714781 single endpoint' action'
715782
716783 where hdrs = allHeaderToSample (Proxy :: Proxy ls)
717784 endpoint' = endpoint & method .~ DocGET
718− action' = action & response.respBody .~ sampleByteStrings t p
785+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
719786 & response.respTypes .~ supportedTypes t
720787 & response.respHeaders .~ hdrs
721788 t = Proxy :: Proxy cts
@@ -736,11 +803,11 @@ instance
736803#endif
737804 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
738805 => HasDocs (Post cts a) where
739− docsFor Proxy (endpoint, action) =
806+ docsFor Proxy (endpoint, action) DocOptions{..} =
740807 single endpoint' action'
741808
742809 where endpoint' = endpoint & method .~ DocPOST
743− action' = action & response.respBody .~ sampleByteStrings t p
810+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
744811 & response.respTypes .~ supportedTypes t
745812 & response.respStatus .~ 201
746813 t = Proxy :: Proxy cts
@@ -753,12 +820,12 @@ instance
753820 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
754821 , AllHeaderSamples ls , GetHeaders (HList ls) )
755822 => HasDocs (Post cts (Headers ls a)) where
756− docsFor Proxy (endpoint, action) =
823+ docsFor Proxy (endpoint, action) DocOptions{..} =
757824 single endpoint' action'
758825
759826 where hdrs = allHeaderToSample (Proxy :: Proxy ls)
760827 endpoint' = endpoint & method .~ DocPOST
761− action' = action & response.respBody .~ sampleByteStrings t p
828+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
762829 & response.respTypes .~ supportedTypes t
763830 & response.respStatus .~ 201
764831 & response.respHeaders .~ hdrs
@@ -771,11 +838,11 @@ instance
771838#endif
772839 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
773840 => HasDocs (Put cts a) where
774− docsFor Proxy (endpoint, action) =
841+ docsFor Proxy (endpoint, action) DocOptions{..} =
775842 single endpoint' action'
776843
777844 where endpoint' = endpoint & method .~ DocPUT
778− action' = action & response.respBody .~ sampleByteStrings t p
845+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
779846 & response.respTypes .~ supportedTypes t
780847 & response.respStatus .~ 200
781848 t = Proxy :: Proxy cts
@@ -788,12 +855,12 @@ instance
788855 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
789856 , AllHeaderSamples ls , GetHeaders (HList ls) )
790857 => HasDocs (Put cts (Headers ls a)) where
791− docsFor Proxy (endpoint, action) =
858+ docsFor Proxy (endpoint, action) DocOptions{..} =
792859 single endpoint' action'
793860
794861 where hdrs = allHeaderToSample (Proxy :: Proxy ls)
795862 endpoint' = endpoint & method .~ DocPUT
796− action' = action & response.respBody .~ sampleByteStrings t p
863+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
797864 & response.respTypes .~ supportedTypes t
798865 & response.respStatus .~ 200
799866 & response.respHeaders .~ hdrs
@@ -875,7 +942,7 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
875942 symP = Proxy :: Proxy sym
876943
877944instance HasDocs Raw where
878− docsFor _proxy (endpoint, action) =
945+ docsFor _proxy (endpoint, action) _ =
879946 single endpoint action
880947
881948-- 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
920987 docsFor Proxy ep =
921988 docsFor (Proxy :: Proxy sublayout) ep
922989
990+-- ToSample instances for simple types
991+instance ToSample () ()
992+instance ToSample Bool Bool
993+instance ToSample Ordering Ordering
994+
995+-- polymorphic ToSample instances
996+instance (ToSample a a, ToSample b b) => ToSample (a, b) (a, b)
997+instance (ToSample a a, ToSample b b, ToSample c c) => ToSample (a, b, c) (a, b, c)
998+instance (ToSample a a, ToSample b b, ToSample c c, ToSample d d) => ToSample (a, b, c, d) (a, b, c, d)
999+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)
1000+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)
1001+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)
1002+
1003+instance ToSample a a => ToSample (Maybe a) (Maybe a)
1004+instance (ToSample a a, ToSample b b) => ToSample (Either a b) (Either a b)
1005+instance ToSample a a => ToSample [a] [a]
1006+
1007+-- ToSample instances for Control.Applicative types
1008+instance ToSample a a => ToSample (Const a b) (Const a b)
1009+instance ToSample a a => ToSample (ZipList a) (ZipList a)
1010+
1011+-- ToSample instances for Data.Monoid newtypes
1012+instance ToSample All All
1013+instance ToSample Any Any
1014+instance ToSample a a => ToSample (Sum a) (Sum a)
1015+instance ToSample a a => ToSample (Product a) (Product a)
1016+instance ToSample a a => ToSample (First a) (First a)
1017+instance ToSample a a => ToSample (Last a) (Last a)
1018+instance ToSample a a => ToSample (Dual a) (Dual a)
9231019
924−-- polymorphic 'ToSample' instances
925−
926−instance ( ToSample a a
927− , ToSample b b
928− ) => ToSample (a, b) (a, b) where
929− toSample _ = (,)
930− <$> toSample (Proxy :: Proxy a)
931− <*> toSample (Proxy :: Proxy b)
932− toSamples _ = render
933− <$> toSamples (Proxy :: Proxy a)
934− <*> toSamples (Proxy :: Proxy b)
935− where render (ta, va) (tb, vb)
936− = ("(" <> ta <>
937− ", " <> tb <>
938− ")"
939− , (va, vb))
940−
941−instance ( ToSample a a
942− , ToSample b b
943− , ToSample c c
944− ) => ToSample (a, b, c) (a, b, c) where
945− toSample _ = (,,)
946− <$> toSample (Proxy :: Proxy a)
947− <*> toSample (Proxy :: Proxy b)
948− <*> toSample (Proxy :: Proxy c)
949− toSamples _ = render
950− <$> toSamples (Proxy :: Proxy a)
951− <*> toSamples (Proxy :: Proxy b)
952− <*> toSamples (Proxy :: Proxy c)
953− where render (ta, va) (tb, vb) (tc, vc)
954− = ("(" <> ta <>
955− ", " <> tb <>
956− ", " <> tc <>
957− ")"
958− , (va, vb, vc))
959−
960−instance ( ToSample a a
961− , ToSample b b
962− , ToSample c c
963− , ToSample d d
964− ) => ToSample (a, b, c, d) (a, b, c, d) where
965− toSample _ = (,,,)
966− <$> toSample (Proxy :: Proxy a)
967− <*> toSample (Proxy :: Proxy b)
968− <*> toSample (Proxy :: Proxy c)
969− <*> toSample (Proxy :: Proxy d)
970− toSamples _ = render
971− <$> toSamples (Proxy :: Proxy a)
972− <*> toSamples (Proxy :: Proxy b)
973− <*> toSamples (Proxy :: Proxy c)
974− <*> toSamples (Proxy :: Proxy d)
975− where render (ta, va) (tb, vb) (tc, vc) (td, vd)
976− = ("(" <> ta <>
977− ", " <> tb <>
978− ", " <> tc <>
979− ", " <> td <>
980− ")"
981− , (va, vb, vc, vd))
982−
983−instance ( ToSample a a
984− , ToSample b b
985− , ToSample c c
986− , ToSample d d
987− , ToSample e e
988− ) => ToSample (a, b, c, d, e) (a, b, c, d, e) where
989− toSample _ = (,,,,)
990− <$> toSample (Proxy :: Proxy a)
991− <*> toSample (Proxy :: Proxy b)
992− <*> toSample (Proxy :: Proxy c)
993− <*> toSample (Proxy :: Proxy d)
994− <*> toSample (Proxy :: Proxy e)
995− toSamples _ = render
996− <$> toSamples (Proxy :: Proxy a)
997− <*> toSamples (Proxy :: Proxy b)
998− <*> toSamples (Proxy :: Proxy c)
999− <*> toSamples (Proxy :: Proxy d)
1000− <*> toSamples (Proxy :: Proxy e)
1001− where render (ta, va) (tb, vb) (tc, vc) (td, vd) (te, ve)
1002− = ("(" <> ta <>
1003− ", " <> tb <>
1004− ", " <> tc <>
1005− ", " <> td <>
1006− ", " <> te <>
1007− ")"
1008− , (va, vb, vc, vd, ve))
1009−
1010−instance ( ToSample a a
1011− , ToSample b b
1012− , ToSample c c
1013− , ToSample d d
1014− , ToSample e e
1015− , ToSample f f
1016− ) => ToSample (a, b, c, d, e, f) (a, b, c, d, e, f) where
1017− toSample _ = (,,,,,)
1018− <$> toSample (Proxy :: Proxy a)
1019− <*> toSample (Proxy :: Proxy b)
1020− <*> toSample (Proxy :: Proxy c)
1021− <*> toSample (Proxy :: Proxy d)
1022− <*> toSample (Proxy :: Proxy e)
1023− <*> toSample (Proxy :: Proxy f)
1024− toSamples _ = render
1025− <$> toSamples (Proxy :: Proxy a)
1026− <*> toSamples (Proxy :: Proxy b)
1027− <*> toSamples (Proxy :: Proxy c)
1028− <*> toSamples (Proxy :: Proxy d)
1029− <*> toSamples (Proxy :: Proxy e)
1030− <*> toSamples (Proxy :: Proxy f)
1031− where render (ta, va) (tb, vb) (tc, vc) (td, vd) (te, ve) (tf, vf)
1032− = ("(" <> ta <>
1033− ", " <> tb <>
1034− ", " <> tc <>
1035− ", " <> td <>
1036− ", " <> te <>
1037− ", " <> tf <>
1038− ")"
1039− , (va, vb, vc, vd, ve, vf))
1040−
1041−instance ( ToSample a a
1042− , ToSample b b
1043− , ToSample c c
1044− , ToSample d d
1045− , ToSample e e
1046− , ToSample f f
1047− , ToSample g g
1048− ) => ToSample (a, b, c, d, e, f, g) (a, b, c, d, e, f, g) where
1049− toSample _ = (,,,,,,)
1050− <$> toSample (Proxy :: Proxy a)
1051− <*> toSample (Proxy :: Proxy b)
1052− <*> toSample (Proxy :: Proxy c)
1053− <*> toSample (Proxy :: Proxy d)
1054− <*> toSample (Proxy :: Proxy e)
1055− <*> toSample (Proxy :: Proxy f)
1056− <*> toSample (Proxy :: Proxy g)
1057− toSamples _ = render
1058− <$> toSamples (Proxy :: Proxy a)
1059− <*> toSamples (Proxy :: Proxy b)
1060− <*> toSamples (Proxy :: Proxy c)
1061− <*> toSamples (Proxy :: Proxy d)
1062− <*> toSamples (Proxy :: Proxy e)
1063− <*> toSamples (Proxy :: Proxy f)
1064− <*> toSamples (Proxy :: Proxy g)
1065− where render (ta, va) (tb, vb) (tc, vc) (td, vd) (te, ve) (tf, vf) (tg, vg)
1066− = ("(" <> ta <>
1067− ", " <> tb <>
1068− ", " <> tc <>
1069− ", " <> td <>
1070− ", " <> te <>
1071− ", " <> tf <>
1072− ", " <> tg <>
1073− ")"
1074− , (va, vb, vc, vd, ve, vf, vg))