Merge pull request #1078 from phadej/arbitrary-sourcet

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

servant/servant.cabal

@@ -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
+copyright:           2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
-category:            Servant, Web
 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

servant/src/Servant/Types/SourceT.hs

@@ -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
 -- ...
 --