d64c232 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #1078 from phadej/arbitrary-sourcet

d64c232Oleg Grenrus8 years ago

servant/servant.cabal+9−4

compare with master

unifiedsplit

@@ -1,27 +1,31 @@

1+cabal-version: >=1.10

1name: servant

2name: servant

2version: 0.15

3version: 0.15

3synopsis: A family of combinators for defining webservices APIs

5synopsis: A family of combinators for defining webservices APIs

6+category: Servant, Web

4description:

7description:

5 A family of combinators for defining webservices APIs and serving them

8 A family of combinators for defining webservices APIs and serving them

6 .

9 .

7 You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.

10 You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.

8 .

11 .

9 <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>

12 <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>

13+

10homepage: http://haskell-servant.readthedocs.org/

14homepage: 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

12license: BSD3

16license: BSD3

13license-file: LICENSE

17license-file: LICENSE

14author: Servant Contributors

18author: Servant Contributors

15maintainer: haskell-servant-maintainers@googlegroups.com

19maintainer: haskell-servant-maintainers@googlegroups.com

16−copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors

20+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

17−category: Servant, Web

18build-type: Custom

21build-type: Custom

19−cabal-version: >=1.10

22+

20tested-with:

23tested-with:

21 GHC==8.0.2

24 GHC==8.0.2

22 GHC==8.2.2

25 GHC==8.2.2

23 GHC==8.4.4

26 GHC==8.4.4

24 GHC==8.6.2

27 GHC==8.6.2

28+

25extra-source-files:

29extra-source-files:

26 CHANGELOG.md

30 CHANGELOG.md

@@ -103,6 +107,7 @@ library

103 , http-types >= 0.12.2 && < 0.13

107 , http-types >= 0.12.2 && < 0.13

104 , mmorph >= 1.1.2 && < 1.2

108 , mmorph >= 1.1.2 && < 1.2

105 , network-uri >= 2.6.1.0 && < 2.7

109 , network-uri >= 2.6.1.0 && < 2.7

110+ , QuickCheck >= 2.12.6.1 && <2.13

106 , singleton-bool >= 0.1.4 && < 0.2

111 , singleton-bool >= 0.1.4 && < 0.2

107 , string-conversions >= 0.4.0.1 && < 0.5

112 , string-conversions >= 0.4.0.1 && < 0.5

108 , tagged >= 0.8.6 && < 0.9

113 , tagged >= 0.8.6 && < 0.9

servant/src/Servant/Types/SourceT.hs+45−1

@@ -16,10 +16,12 @@ import Data.Functor.Classes

16 (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)

17import Data.Functor.Identity

18 (Identity (..))

19−import Prelude hiding

19+import Prelude ()

20+import Prelude.Compat hiding

20 (readFile)

21 (readFile)

21import System.IO

22import System.IO

22 (Handle, IOMode (..), withFile)

23 (Handle, IOMode (..), withFile)

24+import qualified Test.QuickCheck as QC

24-- $setup

26-- $setup

25-- >>> :set -XOverloadedStrings

27-- >>> :set -XOverloadedStrings

@@ -28,6 +30,9 @@ import System.IO

28-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8

30-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8

30-- | This is CPSised ListT.

32-- | This is CPSised ListT.

33+--

34+-- @since 0.15

35+--

31newtype SourceT m a = SourceT

36newtype SourceT m a = SourceT

32 { unSourceT :: forall b. (StepT m a -> m b) -> m b

37 { unSourceT :: forall b. (StepT m a -> m b) -> m b

33 }

38 }

@@ -37,6 +42,9 @@ mapStepT f (SourceT m) = SourceT $ \k -> m (k . f)

37{-# INLINE mapStepT #-}

42{-# INLINE mapStepT #-}

39-- | @ListT@ with additional constructors.

44-- | @ListT@ with additional constructors.

45+--

46+-- @since 0.15

47+--

40data StepT m a

48data StepT m a

41 = Stop

49 = Stop

42 | Error String -- we can this argument configurable.

50 | Error String -- we can this argument configurable.

@@ -81,6 +89,20 @@ instance MFunctor SourceT where

81 hoist f (SourceT m) = SourceT $ \k -> k $

89 hoist f (SourceT m) = SourceT $ \k -> k $

82 Effect $ f $ fmap (hoist f) $ m return

90 Effect $ f $ fmap (hoist f) $ m return

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+

84-------------------------------------------------------------------------------

106-------------------------------------------------------------------------------

85-- StepT instances

107-- StepT instances

86-------------------------------------------------------------------------------

108-------------------------------------------------------------------------------

@@ -128,6 +150,27 @@ instance MFunctor StepT where

128 go (Yield x s) = Yield x (go s)

150 go (Yield x s) = Yield x (go s)

129 go (Effect ms) = Effect (f (fmap go ms))

151 go (Effect ms) = Effect (f (fmap go ms))

130

152

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+

131-------------------------------------------------------------------------------

174-------------------------------------------------------------------------------

132-- Operations

175-- Operations

133-------------------------------------------------------------------------------

176-------------------------------------------------------------------------------

@@ -244,6 +287,7 @@ fromActionStep stop action = loop where

244-- | Read file.

287-- | Read file.

245--

288--

246-- >>> foreach fail BS.putStr (readFile "servant.cabal")

289-- >>> foreach fail BS.putStr (readFile "servant.cabal")

290+-- cabal-version: >=1.10

247-- name: servant

291-- name: servant

248-- ...

292-- ...

249--

293--