Make default ToSample instances productive
The default Generics-based ToSample instance now uses Omega type to productively produce distinct samples. The previous version was based on lists and hence left-recursive. This means that with previous versions the default toSamples for [Bool] would return an infinite list like this: [[],[False],[False,False],[False,False,False],... As you can see it would never produce a list with True in it. Omega handles this and produces a more diverse output: [[],[False],[False,False],[True],... This is still not the best possible case, but to do better we need to use Omega not only in GToSample, but in ToSample as well since GToSample uses ToSample instances recursively.
This commit is contained in:
parent
c769800adb
commit
401b44ac1b
3 changed files with 7 additions and 4 deletions
|
@ -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
|
||||||
|
|
|
@ -23,6 +23,7 @@ module Servant.Docs.Internal where
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Arrow (second)
|
import Control.Arrow (second)
|
||||||
import Control.Lens hiding (List, to, from)
|
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
|
||||||
|
@ -394,12 +395,12 @@ defaultSample :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) =
|
||||||
defaultSample _ = to <$> gtoSample (Proxy :: Proxy (Rep a))
|
defaultSample _ = to <$> gtoSample (Proxy :: Proxy (Rep a))
|
||||||
|
|
||||||
defaultSamples :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
|
defaultSamples :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
|
||||||
defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a))
|
defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
|
||||||
|
|
||||||
class GToSample t s where
|
class GToSample t s where
|
||||||
gtoSample :: proxy t -> Maybe (s x)
|
gtoSample :: proxy t -> Maybe (s x)
|
||||||
gtoSample _ = snd <$> listToMaybe (gtoSamples (Proxy :: Proxy t))
|
gtoSample _ = snd <$> listToMaybe (Omega.runOmega (gtoSamples (Proxy :: Proxy t)))
|
||||||
gtoSamples :: proxy t -> [(Text, s x)]
|
gtoSamples :: proxy t -> Omega.Omega (Text, s x)
|
||||||
gtoSamples _ = maybe empty (pure . ("",)) (gtoSample (Proxy :: Proxy t))
|
gtoSamples _ = maybe empty (pure . ("",)) (gtoSample (Proxy :: Proxy t))
|
||||||
|
|
||||||
instance GToSample U1 U1 where
|
instance GToSample U1 U1 where
|
||||||
|
@ -426,7 +427,7 @@ instance (GToSample p p', GToSample q q') => GToSample (p :+: q) (p' :+: q') whe
|
||||||
|
|
||||||
instance ToSample a b => GToSample (K1 i a) (K1 i b) where
|
instance ToSample a b => GToSample (K1 i a) (K1 i b) where
|
||||||
gtoSample _ = K1 <$> toSample (Proxy :: Proxy a)
|
gtoSample _ = K1 <$> toSample (Proxy :: Proxy a)
|
||||||
gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)
|
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 g) => GToSample (M1 i a f) (M1 i a g) where
|
||||||
gtoSample _ = M1 <$> gtoSample (Proxy :: Proxy f)
|
gtoSample _ = M1 <$> gtoSample (Proxy :: Proxy f)
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue