From 0082d2bd2f92c606da1d02ffad2bdfe956ac8d51 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Sep 2015 14:00:39 +0300 Subject: [PATCH 1/4] Remove redundant second argument of ToSample class --- servant-docs/example/greet.hs | 4 +- servant-docs/src/Servant/Docs/Internal.hs | 95 +++++++++++------------ servant-examples/tutorial/T10.hs | 8 +- 3 files changed, 52 insertions(+), 55 deletions(-) diff --git a/servant-docs/example/greet.hs b/servant-docs/example/greet.hs index 3fd25a0f..50051258 100644 --- a/servant-docs/example/greet.hs +++ b/servant-docs/example/greet.hs @@ -53,13 +53,13 @@ instance ToParam (MatrixParam "lang" String) where "Get the greeting message selected language. Default is en." Normal -instance ToSample Greet Greet where +instance ToSample Greet where toSamples _ = [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") , ("If you use ?capital=false", Greet "Hello, haskeller") ] -instance ToSample Int Int where +instance ToSample Int where toSamples _ = singleSample 1729 -- We define some introductory sections, these will appear at the top of the diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 619084dd..8cb9a2db 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -403,13 +403,13 @@ class HasDocs layout where -- 'toSample': it lets you specify different responses along with -- some context (as 'Text') that explains when you're supposed to -- get the corresponding response. -class ToSample a b | a -> b where - toSamples :: Proxy a -> [(Text, b)] - default toSamples :: (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)] +class ToSample a where + toSamples :: Proxy a -> [(Text, a)] + default toSamples :: (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, 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 :: forall a. ToSample a => Proxy a -> Maybe a toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a)) -- | No samples. @@ -425,22 +425,22 @@ 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 :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)] 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) +class GToSample t where + gtoSamples :: proxy t -> Omega.Omega (Text, t x) -instance GToSample U1 U1 where +instance GToSample U1 where gtoSamples _ = Omega.each (singleSample U1) -instance GToSample V1 V1 where +instance GToSample V1 where gtoSamples _ = empty -instance (GToSample p p', GToSample q q') => GToSample (p :*: q) (p' :*: q') where +instance (GToSample p, GToSample q) => GToSample (p :*: q) where gtoSamples _ = render <$> ps <*> qs where ps = gtoSamples (Proxy :: Proxy p) @@ -449,21 +449,18 @@ instance (GToSample p p', GToSample q q') => GToSample (p :*: q) (p' :*: q') whe | 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 +instance (GToSample p, GToSample q) => GToSample (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 +instance ToSample a => GToSample (K1 i a) where gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a)) -instance (GToSample f g) => GToSample (M1 i a f) (M1 i a g) where +instance (GToSample f) => GToSample (M1 i a f) where gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f) -instance ToSample a b => ToSample (Headers ls a) b where - toSamples _ = toSamples (Proxy :: Proxy a) - class AllHeaderSamples ls where allHeaderToSample :: Proxy ls -> [HTTP.Header] @@ -471,7 +468,7 @@ class AllHeaderSamples ls where instance AllHeaderSamples '[] where allHeaderToSample _ = [] -instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h) +instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) => AllHeaderSamples (Header h l ': ls) where allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) : allHeaderToSample (Proxy :: Proxy ls) @@ -481,7 +478,7 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h) -- | Synthesise a sample value of a type, encoded in the specified media types. sampleByteString - :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b) + :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) => Proxy ctypes -> Proxy a -> [(M.MediaType, ByteString)] @@ -491,7 +488,7 @@ sampleByteString ctypes@Proxy Proxy = -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. sampleByteStrings - :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b) + :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) => Proxy ctypes -> Proxy a -> [(Text, M.MediaType, ByteString)] @@ -728,7 +725,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPABLe #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) => HasDocs (Delete cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -743,7 +740,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Delete cts (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -761,7 +758,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPABLe #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) => HasDocs (Get cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -776,7 +773,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Get cts (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -803,7 +800,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPABLE #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) => HasDocs (Post cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -819,7 +816,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Post cts (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -838,7 +835,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPABLE #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts) + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) => HasDocs (Put cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -854,7 +851,7 @@ instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts + (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Put cts (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -951,7 +948,7 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout +instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout , SupportedTypes cts) => HasDocs (ReqBody cts a :> sublayout) where @@ -990,32 +987,32 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where docsFor (Proxy :: Proxy sublayout) ep -- ToSample instances for simple types -instance ToSample () () -instance ToSample Bool Bool -instance ToSample Ordering Ordering +instance ToSample () +instance ToSample Bool +instance ToSample Ordering -- 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, ToSample b) => ToSample (a, b) +instance (ToSample a, ToSample b, ToSample c) => ToSample (a, b, c) +instance (ToSample a, ToSample b, ToSample c, ToSample d) => ToSample (a, b, c, d) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e) => ToSample (a, b, c, d, e) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f) => ToSample (a, b, c, d, e, f) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f, ToSample g) => ToSample (a, b, c, d, e, f, g) -instance ToSample a a => ToSample (Maybe a) (Maybe a) -instance (ToSample a a, ToSample b b) => ToSample (Either a b) (Either a b) -instance ToSample a a => ToSample [a] [a] +instance ToSample a => ToSample (Maybe a) +instance (ToSample a, ToSample b) => ToSample (Either a b) +instance ToSample a => ToSample [a] -- ToSample instances for Control.Applicative types -instance ToSample a a => ToSample (Const a b) (Const a b) -instance ToSample a a => ToSample (ZipList a) (ZipList a) +instance ToSample a => ToSample (Const a b) +instance ToSample a => ToSample (ZipList a) -- ToSample instances for Data.Monoid newtypes -instance ToSample All All -instance ToSample Any Any -instance ToSample a a => ToSample (Sum a) (Sum a) -instance ToSample a a => ToSample (Product a) (Product a) -instance ToSample a a => ToSample (First a) (First a) -instance ToSample a a => ToSample (Last a) (Last a) -instance ToSample a a => ToSample (Dual a) (Dual a) +instance ToSample All +instance ToSample Any +instance ToSample a => ToSample (Sum a) +instance ToSample a => ToSample (Product a) +instance ToSample a => ToSample (First a) +instance ToSample a => ToSample (Last a) +instance ToSample a => ToSample (Dual a) diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs index 32e24728..be5da4cf 100644 --- a/servant-examples/tutorial/T10.hs +++ b/servant-examples/tutorial/T10.hs @@ -23,7 +23,7 @@ instance ToCapture (Capture "x" Int) where instance ToCapture (Capture "y" Int) where toCapture _ = DocCapture "y" "(integer) position on the y axis" -instance ToSample T3.Position T3.Position where +instance ToSample T3.Position where toSamples _ = singleSample (T3.Position 3 14) instance ToParam (QueryParam "name" String) where @@ -33,7 +33,7 @@ instance ToParam (QueryParam "name" String) where "Name of the person to say hello to." Normal -instance ToSample T3.HelloMessage T3.HelloMessage where +instance ToSample T3.HelloMessage where toSamples _ = [ ("When a value is provided for 'name'", T3.HelloMessage "Hello, Alp") , ("When 'name' is not specified", T3.HelloMessage "Hello, anonymous coward") @@ -42,10 +42,10 @@ instance ToSample T3.HelloMessage T3.HelloMessage where ci :: T3.ClientInfo ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] -instance ToSample T3.ClientInfo T3.ClientInfo where +instance ToSample T3.ClientInfo where toSamples _ = singleSample ci -instance ToSample T3.Email T3.Email where +instance ToSample T3.Email where toSamples _ = singleSample (T3.emailForClient ci) api :: Proxy DocsAPI From 5aa0e2e73390d98714fd13ebbfdee3ab16c7995f Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Sep 2015 14:02:21 +0300 Subject: [PATCH 2/4] Fix servant-docs test suite and add Headers to TestApi --- servant-docs/test/Servant/DocsSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index a294c3b1..5375b0c3 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -30,7 +30,7 @@ spec = describe "Servant.Docs" $ do describe "markdown with extra info" $ do let extra = extraInfo - (Proxy :: Proxy (Get '[JSON, PlainText] Int)) + (Proxy :: Proxy (Get '[JSON, PlainText] (Headers '[Header "Location" String] Int))) (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]]) <> extraInfo @@ -90,26 +90,26 @@ data Datatype1 = Datatype1 { dt1field1 :: String instance ToJSON Datatype1 -instance ToSample Datatype1 Datatype1 where +instance ToSample Datatype1 where toSamples _ = singleSample $ Datatype1 "field 1" 13 -instance ToSample Char Char where +instance ToSample Char where toSamples _ = samples ['a'..'z'] -instance ToSample Int Int where +instance ToSample Int where toSamples _ = singleSample 17 instance MimeRender PlainText Int where mimeRender _ = cs . show -type TestApi1 = Get '[JSON, PlainText] Int +type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> 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 +instance ToSample TT where toSamples _ = [("eins", TT1), ("zwei", TT2)] -instance ToSample UT UT where +instance ToSample UT where toSamples _ = [("yks", UT1), ("kaks", UT2)] From 479290affd4023d8e27e930f54275cb1dcd3913d Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Sep 2015 14:29:27 +0300 Subject: [PATCH 3/4] Update changelog --- servant-docs/CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index dcf0bf38..d42daed7 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -3,6 +3,7 @@ HEAD * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`) +* Remove redundant second parameter of ToSample * 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 From f0c2284c30cdf67aae59120d45d45baf002611dc Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Sep 2015 15:25:58 +0300 Subject: [PATCH 4/4] Fix docs for ToSamples --- servant-docs/src/Servant/Docs.hs | 2 +- servant-docs/src/Servant/Docs/Internal.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index 5fe2c1ed..ac908c96 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -78,7 +78,7 @@ -- > "Get the greeting message selected language. Default is en." -- > Normal -- > --- > instance ToSample Greet Greet where +-- > instance ToSample Greet where -- > toSample _ = Just $ Greet "Hello, haskeller!" -- > -- > toSamples _ = diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 8cb9a2db..f02d8ac5 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -394,7 +394,7 @@ class HasDocs layout where -- > instance FromJSON Greet -- > instance ToJSON Greet -- > --- > instance ToSample Greet Greet where +-- > instance ToSample Greet where -- > toSamples _ = singleSample g -- > -- > where g = Greet "Hello, haskeller!"