fromSetA follow up changes (#1165)

* remove unneeded Bot instances
* check maps are well constructed in fromSetA action order props
* use liftA3 instead of other applicative operations
* add validity to `fromSet` testing

Author: L0neGamer

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/map-properties.hs

@@ -1723,16 +1723,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/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