fromSetA follow up changes

containers-tests/containers-tests.cabal

@@ -324,6 +324,7 @@ test-suite map-lazy-properties
 
   other-modules:
     Utils.ArbitrarySetMap
+    Utils.ArbitraryInstances
 
   ghc-options:      -O2
   other-extensions:
@@ -340,6 +341,7 @@ test-suite map-strict-properties
 
   other-modules:
     Utils.ArbitrarySetMap
+    Utils.ArbitraryInstances
 
   ghc-options:      -O2
   other-extensions:
@@ -366,6 +368,7 @@ test-suite set-properties
 
   other-modules:
     Utils.ArbitrarySetMap
+    Utils.ArbitraryInstances
 
   ghc-options:      -O2
   other-extensions:
@@ -405,7 +408,10 @@ test-suite intset-properties
   hs-source-dirs:   tests
   main-is:          intset-properties.hs
   type:             exitcode-stdio-1.0
-  other-modules:    IntSetValidity
+  other-modules:
+    IntSetValidity
+    Utils.ArbitraryInstances
+    Utils.ArbitrarySetMap
 
   ghc-options:      -O2
   other-extensions:

containers-tests/tests/Utils/ArbitraryInstances.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Utils.ArbitraryInstances () where
+
+import Data.IntSet as IS
+import Data.Set as S
+
+import Utils.ArbitrarySetMap
+
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Class
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+
+{--------------------------------------------------------------------
+  Arbitrary, reasonably balanced trees
+--------------------------------------------------------------------}
+instance Arbitrary IntSet where
+  arbitrary = IS.fromList <$> oneof [arbitrary, fmap (fmap getLarge) arbitrary]
+  shrink = fmap IS.fromList . shrink . IS.toAscList
+
+instance (Int ~ a) => Arbitrary (Set a) where
+  arbitrary = sized (\sz0 -> do
+        sz <- choose (0, sz0)
+        middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))
+        let shift = (sz * (gapRange) + 1) `quot` 2
+            start = middle - shift
+        t <- evalStateT (mkArbSet step sz) start
+        if valid t then pure t else error "Test generated invalid tree!")
+    where
+      step = do
+        i <- get
+        diff <- lift $ choose (1, gapRange)
+        let i' = i + diff
+        put i'
+        pure i'
+
+      -- How much the minimum value of an arbitrary set should vary
+      positionFactor :: Int
+      positionFactor = 1
+
+      -- How much the gap between consecutive elements in an arbitrary
+      -- set should vary
+      gapRange :: Int
+      gapRange = 5

containers-tests/tests/Utils/Strictness.hs

@@ -27,12 +27,6 @@ instance Arbitrary a => Arbitrary (Bot a) where
     , (4, Bot <$> arbitrary)
     ]
 
-instance CoArbitrary a => CoArbitrary (Bot a) where
-  coarbitrary (Bot x) = coarbitrary x
-
-instance Function a => Function (Bot a) where
-  function = functionMap (\(Bot x) -> x) Bot
-
 {--------------------------------------------------------------------
   Lazy functions
 --------------------------------------------------------------------}

containers-tests/tests/intmap-properties.hs

@@ -1701,16 +1701,24 @@ prop_keysSet keys =
 prop_fromSet :: [Int] -> Fun Int A -> Property
 prop_fromSet keys funF =
   let f = apply funF
-  in fromSet f (IntSet.fromList keys) === fromList (fmap (id &&& f) keys)
+      m = fromSet f (IntSet.fromList keys)
+  in
+    valid m .&&.
+    m === fromList (fmap (id &&& f) keys)
 
 prop_fromSetA_action_order :: [Int] -> Fun Int A -> Property
 prop_fromSetA_action_order keys funF =
-  let iSet = IntSet.fromList keys
+  let set = IntSet.fromList keys
+      setList = IntSet.toList set
       f = apply funF
       action = \k ->
         let v = f k
         in tell [v] $> v
-  in execWriter (fromSetA action iSet) === List.map f (IntSet.toList iSet)
+      (writtenMap, writtenOutput) = runWriter (fromSetA action set)
+  in
+    valid writtenMap .&&.
+    writtenOutput === List.map f setList .&&.
+    toList writtenMap === fmap (id &&& f) setList
 
 newtype Identity a = Identity a
     deriving (Eq, Show)

containers-tests/tests/intset-properties.hs

@@ -16,6 +16,7 @@ import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl', foldMap)
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck hiding ((.&.))
+import Utils.ArbitraryInstances ()
 
 main :: IO ()
 main = defaultMain $ testGroup "intset-properties"
@@ -146,13 +147,6 @@ test_compareSize = do
   compareSize (fromList [1]) minBound @?= GT
   compareSize (fromList [1]) maxBound @?= LT
 
-{--------------------------------------------------------------------
-  Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary IntSet where
-  arbitrary = fromList <$> oneof [arbitrary, fmap (fmap getLarge) arbitrary]
-  shrink = fmap fromList . shrink . toAscList
-
 {--------------------------------------------------------------------
   Valid IntMaps
 --------------------------------------------------------------------}

containers-tests/tests/map-properties.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
 
 #ifdef STRICT
 import Data.Map.Strict as Data.Map
@@ -313,46 +315,7 @@ main = defaultMain $ testGroup "map-properties"
          , testProperty "mapAccumRWithKey"     prop_mapAccumRWithKey
          ]
 
-{--------------------------------------------------------------------
-  Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-
--- | The IsInt class lets us constrain a type variable to be Int in an entirely
--- standard way. The constraint @ IsInt a @ is essentially equivalent to the
--- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention
--- to use. If ~ is ever standardized, we should certainly use it instead.
--- Earlier versions used an Enum constraint, but this is confusing because
--- not all Enum instances will work properly for the Arbitrary instance here.
-class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where
-  fromIntF :: f Int -> f a
-
-instance IsInt Int where
-  fromIntF = id
-
--- | Convert an Int to any instance of IsInt
-fromInt :: IsInt a => Int -> a
-fromInt = runIdentity . fromIntF . Identity
-
-{- We don't actually need this, but we can add it if we ever do
-toIntF :: IsInt a => g a -> g Int
-toIntF = unf . fromIntF . F $ id
-
-newtype F g a b = F {unf :: g b -> a}
-
-toInt :: IsInt a => a -> Int
-toInt = runIdentity . toIntF . Identity -}
-
-
--- How much the minimum key of an arbitrary map should vary
-positionFactor :: Int
-positionFactor = 1
-
--- How much the gap between consecutive keys in an arbitrary
--- map should vary
-gapRange :: Int
-gapRange = 5
-
-instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where
+instance (Int ~ k, Arbitrary v) => Arbitrary (Map k v) where
   arbitrary = sized (\sz0 -> do
         sz <- choose (0, sz0)
         middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))
@@ -366,7 +329,16 @@ instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where
         diff <- lift $ choose (1, gapRange)
         let i' = i + diff
         put i'
-        pure (fromInt i')
+        pure i'
+
+      -- How much the minimum key of an arbitrary map should vary
+      positionFactor :: Int
+      positionFactor = 1
+
+      -- How much the gap between consecutive keys in an arbitrary
+      -- map should vary
+      gapRange :: Int
+      gapRange = 5
 
 -- A type with a peculiar Eq instance designed to make sure keys
 -- come from where they're supposed to.
@@ -1723,16 +1695,24 @@ prop_argSet xs =
 prop_fromSet :: [OrdA] -> Fun OrdA B -> Property
 prop_fromSet keys funF =
   let f = apply funF
-  in fromSet f (Set.fromList keys) === fromList (fmap (id &&& f) keys)
+      m = fromSet f (Set.fromList keys)
+  in
+    valid m .&&.
+    m === fromList (fmap (id &&& f) keys)
 
 prop_fromSetA_action_order :: [OrdA] -> Fun OrdA B -> Property
 prop_fromSetA_action_order keys funF =
-  let iSet = Set.fromList keys
+  let set = Set.fromList keys
+      setList = Set.toList set
       f = apply funF
       action = \k ->
         let v = f k
         in tell [v] $> v
-  in execWriter (fromSetA action iSet) === List.map f (Set.toList iSet)
+      (writtenMap, writtenOutput) = runWriter (fromSetA action set)
+  in
+    valid writtenMap .&&.
+    writtenOutput === List.map f setList .&&.
+    toList writtenMap === fmap (id &&& f) setList
 
 prop_fromArgSet :: [(OrdA, B)] -> Property
 prop_fromArgSet ys =

containers-tests/tests/set-properties.hs

@@ -21,6 +21,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NE
 
 import Utils.ArbitrarySetMap (mkArbSet, setFromList)
+import Utils.ArbitraryInstances ()
 
 main :: IO ()
 main = defaultMain $ testGroup "set-properties"
@@ -192,94 +193,34 @@ test_deleteAt = do
   Arbitrary, reasonably balanced trees
 --------------------------------------------------------------------}
 
--- | The IsInt class lets us constrain a type variable to be Int in an entirely
--- standard way. The constraint @ IsInt a @ is essentially equivalent to the
--- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention
--- to use. If ~ is ever standardized, we should certainly use it instead.
--- Earlier versions used an Enum constraint, but this is confusing because
--- not all Enum instances will work properly for the Arbitrary instance here.
-class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where
-  fromIntF :: f Int -> f a
-
-instance IsInt Int where
-  fromIntF = id
-
--- | Convert an Int to any instance of IsInt
-fromInt :: IsInt a => Int -> a
-fromInt = runIdentity . fromIntF . Identity
-
-{- We don't actually need this, but we can add it if we ever do
-toIntF :: IsInt a => g a -> g Int
-toIntF = unf . fromIntF . F $ id
-
-newtype F g a b = F {unf :: g b -> a}
-
-toInt :: IsInt a => a -> Int
-toInt = runIdentity . toIntF . Identity -}
-
-
--- How much the minimum value of an arbitrary set should vary
-positionFactor :: Int
-positionFactor = 1
-
--- How much the gap between consecutive elements in an arbitrary
--- set should vary
-gapRange :: Int
-gapRange = 5
-
-instance IsInt a => Arbitrary (Set a) where
-  arbitrary = sized (\sz0 -> do
-        sz <- choose (0, sz0)
-        middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))
-        let shift = (sz * (gapRange) + 1) `quot` 2
-            start = middle - shift
-        t <- evalStateT (mkArbSet step sz) start
-        if valid t then pure t else error "Test generated invalid tree!")
-    where
-      step = do
-        i <- get
-        diff <- lift $ choose (1, gapRange)
-        let i' = i + diff
-        put i'
-        pure (fromInt i')
-
 data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show)
 
-data TwoLists a = TwoLists [a] [a]
-
-data Options2 = One2 | Two2 | Both2 deriving (Bounded, Enum)
-instance Arbitrary Options2 where
-  arbitrary = arbitraryBoundedEnum
-
 -- We produce two lists from a simple "universe". This instance
 -- is intended to give good results when the two lists are then
 -- combined with each other; if other elements are used with them,
 -- they may or may not behave particularly well.
-instance IsInt a => Arbitrary (TwoLists a) where
-  arbitrary = sized $ \sz0 -> do
-    sz <- choose (0, sz0)
-    let universe = [0,3..3*(fromInt sz - 1)]
-    divide2Gen universe
-
 instance Arbitrary TwoSets where
   arbitrary = do
-    TwoLists l r <- arbitrary
+    (l, r) <- sized $ \sz0 -> do
+      sz <- choose (0, sz0)
+      let universe = [0,3..3*(sz - 1)]
+      divide2Gen universe
     TwoSets <$> setFromList l <*> setFromList r
-
-divide2Gen :: [a] -> Gen (TwoLists a)
-divide2Gen [] = pure (TwoLists [] [])
-divide2Gen (x : xs) = do
-  way <- arbitrary
-  TwoLists ls rs <- divide2Gen xs
-  case way of
-    One2 -> pure (TwoLists (x : ls) rs)
-    Two2 -> pure (TwoLists ls (x : rs))
-    Both2 -> pure (TwoLists (x : ls) (x : rs))
+    where
+    divide2Gen :: [a] -> Gen ([a], [a])
+    divide2Gen [] = pure ([], [])
+    divide2Gen (x : xs) = do
+      mIsFirst <- arbitrary
+      (ls, rs) <- divide2Gen xs
+      pure $ case mIsFirst of
+        Just True -> ((x : ls), rs)
+        Just False -> (ls, (x : rs))
+        Nothing -> ((x : ls), (x : rs))
 
 {--------------------------------------------------------------------
   Valid trees
 --------------------------------------------------------------------}
-forValid :: (IsInt a,Testable b) => (Set a -> b) -> Property
+forValid :: (Testable b) => (Set Int -> b) -> Property
 forValid f = forAll arbitrary $ \t ->
     classify (size t == 0) "empty" $
     classify (size t > 0  && size t <= 10) "small" $

containers/src/Data/Map/Internal.hs

@@ -3551,10 +3551,7 @@ fromSet f = runIdentity . fromSetA (pure . f)
 fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a)
 fromSetA _ Set.Tip = pure Tip
 fromSetA f (Set.Bin sz x l r) =
-  flip (Bin sz x)
-    <$> fromSetA f l
-    <*> f x
-    <*> fromSetA f r
+  liftA3 (flip (Bin sz x)) (fromSetA f l) (f x) (fromSetA f r)
 #if __GLASGOW_HASKELL__
 {-# INLINABLE fromSetA #-}
 #else

containers/src/Data/Map/Strict/Internal.hs

@@ -1482,10 +1482,8 @@ fromSet f = runIdentity . fromSetA (pure . f)
 fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a)
 fromSetA _ Set.Tip = pure Tip
 fromSetA f (Set.Bin sz x l r) = 
-  flip (Bin sz x $!)
-    <$> fromSetA f l
-    <*> f x
-    <*> fromSetA f r
+  liftA3 (flip (Bin sz x $!)) (fromSetA f l) (f x) (fromSetA f r)
+
 #if __GLASGOW_HASKELL__
 {-# INLINABLE fromSetA #-}
 #else