Merge pull request #1078 from phadej/arbitrary-sourcet

Add Arbitrary (SourceT m a) and StepT m a instances
This commit is contained in:
Oleg Grenrus 2018-11-12 22:01:00 +02:00 committed by GitHub
commit d64c2322d8
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 54 additions and 5 deletions

View file

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

View file

@ -16,10 +16,12 @@ import Data.Functor.Classes
(Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith) (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)
import Data.Functor.Identity import Data.Functor.Identity
(Identity (..)) (Identity (..))
import Prelude hiding import Prelude ()
import Prelude.Compat hiding
(readFile) (readFile)
import System.IO import System.IO
(Handle, IOMode (..), withFile) (Handle, IOMode (..), withFile)
import qualified Test.QuickCheck as QC
-- $setup -- $setup
-- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedStrings
@ -28,6 +30,9 @@ import System.IO
-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8 -- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8
-- | This is CPSised ListT. -- | This is CPSised ListT.
--
-- @since 0.15
--
newtype SourceT m a = SourceT newtype SourceT m a = SourceT
{ unSourceT :: forall b. (StepT m a -> m b) -> m b { 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 #-} {-# INLINE mapStepT #-}
-- | @ListT@ with additional constructors. -- | @ListT@ with additional constructors.
--
-- @since 0.15
--
data StepT m a data StepT m a
= Stop = Stop
| Error String -- we can this argument configurable. | Error String -- we can this argument configurable.
@ -81,6 +89,20 @@ instance MFunctor SourceT where
hoist f (SourceT m) = SourceT $ \k -> k $ hoist f (SourceT m) = SourceT $ \k -> k $
Effect $ f $ fmap (hoist f) $ m return 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 -- StepT instances
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -128,6 +150,27 @@ instance MFunctor StepT where
go (Yield x s) = Yield x (go s) go (Yield x s) = Yield x (go s)
go (Effect ms) = Effect (f (fmap go ms)) 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 -- Operations
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -244,6 +287,7 @@ fromActionStep stop action = loop where
-- | Read file. -- | Read file.
-- --
-- >>> foreach fail BS.putStr (readFile "servant.cabal") -- >>> foreach fail BS.putStr (readFile "servant.cabal")
-- cabal-version: >=1.10
-- name: servant -- name: servant
-- ... -- ...
-- --