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

The generated instances are pure-ish; errorless.
This commit is contained in:
Oleg Grenrus 2018-11-09 23:22:27 +02:00
parent ce83e4b404
commit 4961cc2f3a
2 changed files with 54 additions and 5 deletions

View file

@ -1,27 +1,31 @@
cabal-version: >=1.10
name: servant
version: 0.15
synopsis: A family of combinators for defining webservices APIs
category: Servant, Web
description:
A family of combinators for defining webservices APIs and serving them
.
You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
.
<https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
bug-reports: http://github.com/haskell-servant/servant/issues
license: BSD3
license-file: LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Servant, Web
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
build-type: Custom
cabal-version: >=1.10
tested-with:
GHC==8.0.2
GHC==8.2.2
GHC==8.4.4
GHC==8.6.2
extra-source-files:
CHANGELOG.md
@ -103,6 +107,7 @@ library
, http-types >= 0.12.2 && < 0.13
, mmorph >= 1.1.2 && < 1.2
, network-uri >= 2.6.1.0 && < 2.7
, QuickCheck >= 2.12.6.1 && <2.13
, singleton-bool >= 0.1.4 && < 0.2
, string-conversions >= 0.4.0.1 && < 0.5
, tagged >= 0.8.6 && < 0.9

View file

@ -16,10 +16,12 @@ import Data.Functor.Classes
(Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)
import Data.Functor.Identity
(Identity (..))
import Prelude hiding
import Prelude ()
import Prelude.Compat hiding
(readFile)
import System.IO
(Handle, IOMode (..), withFile)
import qualified Test.QuickCheck as QC
-- $setup
-- >>> :set -XOverloadedStrings
@ -28,6 +30,9 @@ import System.IO
-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8
-- | This is CPSised ListT.
--
-- @since 0.15
--
newtype SourceT m a = SourceT
{ unSourceT :: forall b. (StepT m a -> m b) -> m b
}
@ -37,6 +42,9 @@ mapStepT f (SourceT m) = SourceT $ \k -> m (k . f)
{-# INLINE mapStepT #-}
-- | @ListT@ with additional constructors.
--
-- @since 0.15
--
data StepT m a
= Stop
| Error String -- we can this argument configurable.
@ -81,6 +89,20 @@ instance MFunctor SourceT where
hoist f (SourceT m) = SourceT $ \k -> k $
Effect $ f $ fmap (hoist f) $ m return
-- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink.
instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where
arbitrary = fromStepT <$> QC.arbitrary
-- An example of above instance. Not doctested because it's volatile.
--
-- >>> import Test.QuickCheck as QC
-- >>> import Test.QuickCheck.Gen as QC
-- >>> import Test.QuickCheck.Random as QC
-- >>> let generate (QC.MkGen g) = g (QC.mkQCGen 44) 10
--
-- >>> generate (arbitrary :: QC.Gen (SourceT Identity Int))
-- fromStepT (Effect (Identity (Yield (-10) (Yield 3 (Skip (Yield 1 Stop))))))
-------------------------------------------------------------------------------
-- StepT instances
-------------------------------------------------------------------------------
@ -128,6 +150,27 @@ instance MFunctor StepT where
go (Yield x s) = Yield x (go s)
go (Effect ms) = Effect (f (fmap go ms))
-- | Doesn't generate 'Error' constructors.
instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where
arbitrary = QC.sized arb where
arb n | n <= 0 = pure Stop
| otherwise = QC.frequency
[ (1, pure Stop)
, (1, Skip <$> arb')
, (1, Effect . return <$> arb')
, (8, Yield <$> QC.arbitrary <*> arb')
]
where
arb' = arb (n - 1)
shrink Stop = []
shrink (Error _) = [Stop]
shrink (Skip s) = [s]
shrink (Effect _) = []
shrink (Yield x s) =
[ Yield x' s | x' <- QC.shrink x ] ++
[ Yield x s' | s' <- QC.shrink s ]
-------------------------------------------------------------------------------
-- Operations
-------------------------------------------------------------------------------
@ -244,6 +287,7 @@ fromActionStep stop action = loop where
-- | Read file.
--
-- >>> foreach fail BS.putStr (readFile "servant.cabal")
-- cabal-version: >=1.10
-- name: servant
-- ...
--