git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1078 from phadej/arbitrary-sourcet

Add Arbitrary (SourceT m a) and StepT m a instances

commitd64c2322d8c427f6d8c48b80455d8ea62a0d4d9f authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 12 Nov 2018, 22:01 (8 years ago) parentce83e4b4961cc2
2 files changed+54−5
compare with master
unifiedsplit
servant/servant.cabal+9−4 servant/src/Servant/Types/SourceT.hs+45−1
servant/servant.cabal+9−4
@@ -1,27 +1,31 @@
1+cabal-version: >=1.10
12name: servant
23version: 0.15
4+
35synopsis: A family of combinators for defining webservices APIs
6+category: Servant, Web
47description:
58 A family of combinators for defining webservices APIs and serving them
69 .
710 You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
811 .
912 <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>
13+
1014homepage: http://haskell-servant.readthedocs.org/
11−Bug-reports: http://github.com/haskell-servant/servant/issues
15+bug-reports: http://github.com/haskell-servant/servant/issues
1216license: BSD3
1317license-file: LICENSE
1418author: Servant Contributors
1519maintainer: haskell-servant-maintainers@googlegroups.com
16−copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
17−category: Servant, Web
20+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
1821build-type: Custom
19−cabal-version: >=1.10
22+
2023tested-with:
2124 GHC==8.0.2
2225 GHC==8.2.2
2326 GHC==8.4.4
2427 GHC==8.6.2
28+
2529extra-source-files:
2630 CHANGELOG.md
2731
@@ -103,6 +107,7 @@ library
103107 , http-types >= 0.12.2 && < 0.13
104108 , mmorph >= 1.1.2 && < 1.2
105109 , network-uri >= 2.6.1.0 && < 2.7
110+ , QuickCheck >= 2.12.6.1 && <2.13
106111 , singleton-bool >= 0.1.4 && < 0.2
107112 , string-conversions >= 0.4.0.1 && < 0.5
108113 , tagged >= 0.8.6 && < 0.9
servant/src/Servant/Types/SourceT.hs+45−1
@@ -16,10 +16,12 @@ import Data.Functor.Classes
1616 (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)
1717import Data.Functor.Identity
1818 (Identity (..))
19−import Prelude hiding
19+import Prelude ()
20+import Prelude.Compat hiding
2021 (readFile)
2122import System.IO
2223 (Handle, IOMode (..), withFile)
24+import qualified Test.QuickCheck as QC
2325
2426-- $setup
2527-- >>> :set -XOverloadedStrings
@@ -28,6 +30,9 @@ import System.IO
2830-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8
2931
3032-- | This is CPSised ListT.
33+--
34+-- @since 0.15
35+--
3136newtype SourceT m a = SourceT
3237 { unSourceT :: forall b. (StepT m a -> m b) -> m b
3338 }
@@ -37,6 +42,9 @@ mapStepT f (SourceT m) = SourceT $ \k -> m (k . f)
3742{-# INLINE mapStepT #-}
3843
3944-- | @ListT@ with additional constructors.
45+--
46+-- @since 0.15
47+--
4048data StepT m a
4149 = Stop
4250 | Error String -- we can this argument configurable.
@@ -81,6 +89,20 @@ instance MFunctor SourceT where
8189 hoist f (SourceT m) = SourceT $ \k -> k $
8290 Effect $ f $ fmap (hoist f) $ m return
8391
92+-- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink.
93+instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where
94+ arbitrary = fromStepT <$> QC.arbitrary
95+
96+-- An example of above instance. Not doctested because it's volatile.
97+--
98+-- >>> import Test.QuickCheck as QC
99+-- >>> import Test.QuickCheck.Gen as QC
100+-- >>> import Test.QuickCheck.Random as QC
101+-- >>> let generate (QC.MkGen g) = g (QC.mkQCGen 44) 10
102+--
103+-- >>> generate (arbitrary :: QC.Gen (SourceT Identity Int))
104+-- fromStepT (Effect (Identity (Yield (-10) (Yield 3 (Skip (Yield 1 Stop))))))
105+
84106-------------------------------------------------------------------------------
85107-- StepT instances
86108-------------------------------------------------------------------------------
@@ -128,6 +150,27 @@ instance MFunctor StepT where
128150 go (Yield x s) = Yield x (go s)
129151 go (Effect ms) = Effect (f (fmap go ms))
130152
153+-- | Doesn't generate 'Error' constructors.
154+instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where
155+ arbitrary = QC.sized arb where
156+ arb n | n <= 0 = pure Stop
157+ | otherwise = QC.frequency
158+ [ (1, pure Stop)
159+ , (1, Skip <$> arb')
160+ , (1, Effect . return <$> arb')
161+ , (8, Yield <$> QC.arbitrary <*> arb')
162+ ]
163+ where
164+ arb' = arb (n - 1)
165+
166+ shrink Stop = []
167+ shrink (Error _) = [Stop]
168+ shrink (Skip s) = [s]
169+ shrink (Effect _) = []
170+ shrink (Yield x s) =
171+ [ Yield x' s | x' <- QC.shrink x ] ++
172+ [ Yield x s' | s' <- QC.shrink s ]
173+
131174-------------------------------------------------------------------------------
132175-- Operations
133176-------------------------------------------------------------------------------
@@ -244,6 +287,7 @@ fromActionStep stop action = loop where
244287-- | Read file.
245288--
246289-- >>> foreach fail BS.putStr (readFile "servant.cabal")
290+-- cabal-version: >=1.10
247291-- name: servant
248292-- ...
249293--