wip

hedgehog-example/src/Test/Example/List.hs

@@ -1,11 +1,16 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Test.Example.List where
 
 import           Control.Monad.Zip (mzip)
 import qualified Control.Monad.State.Lazy as Lazy
 import qualified Control.Monad.State.Class as State
+import qualified Control.Monad.Writer.Lazy as Lazy
+import qualified Control.Monad.Writer.Class as Writer
+import           Control.Monad.Morph (MFunctor(..))
 
 import           Data.Maybe (fromJust)
 import           Data.Foldable (toList)
@@ -24,11 +29,11 @@ import qualified Hedgehog.Internal.Tree as Tree
 
 genInt :: MonadGen m => m Int
 genInt =
-  Gen.int (Range.constant 0 1)
+  Gen.int (Range.constant 0 2)
 
 genList :: MonadGen m => m a -> m [a]
 genList =
-  Gen.list (Range.constant 0 3)
+  Gen.list (Range.constant 0 2)
 
 prop_list :: Property
 prop_list =
@@ -49,32 +54,79 @@ prop_list =
 
     assert (cond xs0)
 
-genStateInt :: (MonadGen m, State.MonadState (Sum Int) m) => m (Int, Int)
+newtype Index =
+  Index Int
+  deriving (Eq, Num, Show)
+
+genStateInt :: (MonadGen m, State.MonadState Index m) => m (Index, Int)
 genStateInt = do
   x <- genInt
   State.modify (+ 1)
-  n <- getSum <$> State.get
-  pure (x, n)
+  index <- State.get
+  pure (index, x)
 
 prop_state_list :: Property
 prop_state_list =
   property $ do
     let
-      cond :: [(Int, Int)] -> Bool
+      cond :: [(a, Int)] -> Bool
       cond xs =
-        all ((>= length xs) . fst) xs
+        all ((>= length xs) . snd) xs
 
-      renderTree :: Tree [(Int, Int)] -> String
+      renderTree :: Tree [(Index, Int)] -> String
       renderTree =
         Tree.render .
         fmap show .
         fmap (\xs -> (cond xs, xs))
 
-    ts <- forAllWith renderTree (Gen.tree $ flip Lazy.evalStateT 0 $ genList genStateInt)
+    ts <- forAllWith renderTree (Gen.tree $ hoist (`Lazy.evalStateT` 0) $ genList genStateInt)
     xs0 <- forAll (Gen.liftTree ts)
 
     assert (cond xs0)
 
+data Log =
+    List Int
+  | Int Int
+    deriving (Show)
+
+genWriterList :: (MonadGen m, Writer.MonadWriter [Log] m) => m a -> m [a]
+genWriterList gen = do
+  xs <- Gen.list (Range.constant 0 2) gen
+  Writer.tell [List (length xs)]
+  pure xs
+
+genWriterInt :: (MonadGen m, Writer.MonadWriter [Log] m) => m Int
+genWriterInt = do
+  x <- genInt
+  Writer.tell [Int x]
+  pure x
+
+renderLog :: [Log] -> String
+renderLog xs =
+  concat . flip fmap xs $ \case
+    List n ->
+      " L" ++ show n
+    Int n ->
+      show n
+
+prop_writer_list :: Property
+prop_writer_list =
+  property $ do
+    let
+      cond :: [Int] -> Bool
+      cond xs =
+        all ((>= length xs)) xs
+
+      renderTree =
+        Tree.render .
+        fmap (\(ns, ws) -> show (cond ns, ns) ++ " (" ++ renderLog ws ++ ")")
+
+    ts <- forAllWith renderTree (Gen.tree . Lazy.runWriterT $ genWriterList genWriterInt)
+    (xs0, _) <- forAll (Gen.liftTree ts)
+
+    assert (cond xs0)
+
+
 tests :: IO Bool
 tests =
   checkParallel $$(discover)

hedgehog/src/Hedgehog.hs

@@ -133,7 +133,7 @@ module Hedgehog (
   , Opaque(..)
 
   -- * Transformers
-  , distribute
+  , distributeT
 
   -- * Functors
   , HTraversable(..)
@@ -150,7 +150,7 @@ module Hedgehog (
 
 import           Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1)
 
-import           Hedgehog.Internal.Distributive (Distributive(..))
+import           Hedgehog.Internal.Distributive (distributeT)
 import           Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..))
 import           Hedgehog.Internal.HTraversable (HTraversable(..))
 import           Hedgehog.Internal.Opaque (Opaque(..))

hedgehog/src/Hedgehog/Internal/Distributive.hs

@@ -10,31 +10,27 @@ module Hedgehog.Internal.Distributive (
   , MonadTransJuggle(..)
   ) where
 
-import           Control.Applicative (Alternative(..))
-import           Control.Monad (MonadPlus(..), join)
+import           Control.Monad (join)
 import           Control.Monad.Morph (MFunctor(..))
 import           Control.Monad.Trans.Class (MonadTrans(..))
 import           Control.Monad.Trans.Control (MonadTransControl(..))
 import           Control.Monad.Trans.Identity (IdentityT(..))
 import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)
 import           Control.Monad.Trans.Maybe (MaybeT(..))
 import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
-import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS
 import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
-import qualified Control.Monad.Trans.RWS.Strict as StrictRWS
 import           Control.Monad.Trans.Reader (ReaderT(..))
 import qualified Control.Monad.Trans.State.Lazy as Lazy
 import qualified Control.Monad.Trans.State.Strict as Strict
 import qualified Control.Monad.Trans.Writer.Lazy as Lazy
 import qualified Control.Monad.Trans.Writer.Strict as Strict
 
-import           Data.Functor.Identity (Identity(..))
-import           Data.Functor.Const (Const(..))
 import           Data.Proxy (Proxy(..))
 import           Data.Bifunctor (Bifunctor(..))
 
 import           GHC.Exts (Constraint)
 
+-- NOTE: Replace use of Proxy with TypeApplications when we drop 7.10 support.
 
 ------------------------------------------------------------------------
 -- * MonadTransDistributive
@@ -210,7 +206,7 @@ juggleRWS _ _ _ s0 st0 =
   let
     (st, (s, w)) =
       juggleState @t @a Proxy Proxy (s0, mempty) $
-        mapStT @t @(a, s, w) @(a, (s, w)) Proxy Proxy unpack3 st0
+        mapStT @t @(a, s, w) Proxy Proxy unpack3 st0
   in
     (st, s, w)