pomaps-0.2.0.1: tests/Data/POMap/Properties.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O0 -fno-warn-orphans #-}
module Data.POMap.Properties where
import Algebra.PartialOrd
import Control.Arrow (first, (&&&), (***))
import Control.Monad (guard)
import Data.Bifunctor (bimap)
import Data.Coerce
import qualified Data.Either as Either
import Data.Foldable hiding (foldl', foldr', toList)
import Data.Function (on)
import Data.Functor.Compose
import Data.Functor.Const
import Data.Functor.Identity
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import Data.Monoid (Dual (..), Endo (..), Sum (..))
import Data.POMap.Arbitrary ()
import Data.POMap.Divisibility
import Data.POMap.Lazy
import qualified Data.POSet as POSet
import Data.Traversable
import Prelude hiding (filter, lookup, map, max, null)
import Test.Tasty.Hspec
import Test.Tasty.QuickCheck
type DivMap v = POMap Divisibility v
instance {-# OVERLAPPING #-} Eq v => Eq (DivMap v) where
(==) = (==) `on` List.sortOn (unDiv . fst) . toList
div' :: Int -> DivMap Integer
div' = fromList . divisibility
div100 :: DivMap Integer
div100 = div' 100
div1000 :: DivMap Integer
div1000 = div' 1000
primes :: [Integer]
primes = 2 : [ p | p <- [3..], not . any (divides p) . takeWhile (\n -> n*n <= p) $ primes]
where
divides p n = p `mod` n == 0
primesUntil :: Integer -> [Integer]
primesUntil n = takeWhile (<= n) primes
makeEntries :: [Integer] -> [(Divisibility, Integer)]
makeEntries = fmap (Div &&& id)
shouldBeSameEntries :: (Eq v, Show v) => [(Divisibility, v)] -> [(Divisibility, v)] -> Expectation
shouldBeSameEntries = shouldBe `on` List.sortOn (unDiv . fst)
isAntichain :: PartialOrd k => [k] -> Bool
isAntichain [] = True
isAntichain (x:xs) = all (not . comparable x) xs && isAntichain xs
newtype OrdInt = OrdInt Int deriving (Eq, Show)
instance PartialOrd OrdInt where OrdInt sa `leq` OrdInt sb = sa <= sb
instance Arbitrary OrdInt where
arbitrary = OrdInt <$> arbitrary
spec :: Spec
spec =
describe "POMap" $ do
describe "empty" $ do
it "fromList []" $ fromList (divisibility 0) `shouldBe` empty
it "is null" $ null empty `shouldBe` True
it "has size 0" $ size empty `shouldBe` 0
describe "singleton" $ do
let m = singleton 1 1
it "fromList [(k, v)]" $ fromList (divisibility 1) `shouldBe` m
it "is not null" $ null m `shouldBe` False
it "has size 1" $ size m `shouldBe` 1
describe "width" $ do
it "width empty == 0" $ width empty `shouldBe` 0
it "width singleton == 1" $ width (singleton () ()) `shouldBe` 1
it "width div100 == 50" $ width div100 `shouldBe` 50
it "width div1000 == 500" $ width div1000 `shouldBe` 500
let prop100and1000 prop = do
it "100 divs" $ property (prop div100 (100 :: Integer))
it "1000 divs" $ property (prop div1000 (1000 :: Integer))
describe "member" $
prop100and1000 $ \m max (Positive n) ->
member (Div n) m == (n <= max)
describe "lookup" $
prop100and1000 $ \m max (Positive n) ->
lookup (Div n) m == (guard (n <= max) >> Just n)
let lookupXProps what lu p =
describe ("is " ++ what) $
prop100and1000 $ \m _ (Positive n) ->
all (p (Div n) . fst) (lu (Div n) m)
describe "lookupLT" $ do
it "nothing less than 1" $
lookupLT 1 div100 `shouldBe` []
it "1 is less than 2" $
lookupLT 2 div100 `shouldBe` makeEntries [1]
it "64 is less than 128" $
lookupLT 128 div100 `shouldBe` makeEntries [64]
it "[6, 10, 15] less than 30" $
lookupLT 30 div100 `shouldBeSameEntries` makeEntries [6, 10, 15]
lookupXProps "less than" lookupLT $ \a b ->
not (a `leq` b) && b `leq` a
describe "lookupLE" $ do
it "50 leq 50" $
lookupLE 50 div100 `shouldBe` makeEntries [50]
it "64 is less equal 128" $
lookupLE 128 div100 `shouldBe` makeEntries [64]
it "[30, 42, 70] leq 210" $
lookupLE 210 div100 `shouldBeSameEntries` makeEntries [30, 42, 70]
lookupXProps "less equal" lookupLE (flip leq)
describe "lookupGE" $ do
it "50 geq 50" $
lookupGE 50 div100 `shouldBe` makeEntries [50]
it "Nothing is geq 101" $
lookupGE 101 div100 `shouldBe` makeEntries []
describe "lookupGT" $ do
it "primes are gt 1" $
lookupGT 1 div100 `shouldBeSameEntries` makeEntries (primesUntil 100)
it "Nothing is gt 101" $
lookupGT 101 div100 `shouldBe` makeEntries []
it "[66, 99] gt 33" $
lookupGT 33 div100 `shouldBeSameEntries` makeEntries [66, 99]
lookupXProps "greater than" lookupGT $ \a b ->
a `leq` b && not (b `leq` a)
describe "insert" $
it "overwrites an entry" $
property $ \(m :: DivMap Int) k v ->
lookup k (insert k v m) `shouldBe` Just v
describe "insertWithKey" $ do
it "can access old value" $
insertWithKey (\_ _ old -> old) 1 2 div100 `shouldBe` div100
it "can access new value" $
lookup 1 (insertWithKey (\_ new _ -> new) 1 2 div100) `shouldBe` Just 2
it "can access key" $
lookup 1 (insertWithKey (\k _ _ -> unDiv k + 2) 1 2 div100) `shouldBe` Just 3
it "adds new values without consulting the function" $
lookup 1 (insertWithKey (\_ _ _ -> 3) (Div 1) 2 empty) `shouldBe` Just (2 :: Integer)
describe "insertLookupWithKey" $ do
let f k new old = unDiv k + new + old
it "lookup &&& insertWithKey" $
property $ \m k v ->
insertLookupWithKey f k v m `shouldBe` (lookup k m, insertWithKey f k v m)
describe "delete" $
it "deletes" $ property $ \(m :: DivMap Int) k ->
lookup k (delete k m) `shouldBe` Nothing
describe "deleteLookup" $
it "lookup &&& delete" $ property $ \(m :: DivMap Int) k ->
deleteLookup k m `shouldBe` (lookup k m, delete k m)
describe "adjust" $ do
let f old = old + 1
it "adjusts" $ property $ \(m :: DivMap Int) k ->
lookup k (adjust f k m) `shouldBe` (+1) <$> lookup k m
describe "adjustWithKey" $ do
let f k old = unDiv k + old + 1
it "passes the key" $ property $ \(m :: DivMap Integer) k ->
lookup k (adjustWithKey f k m) `shouldBe` (unDiv k + 1 +) <$> lookup k m
describe "adjustLookupWithKey" $ do
let f k old = unDiv k + old + 1
it "lookup &&& adjustWithKey" $ property $ \(m :: DivMap Integer) k ->
adjustLookupWithKey f k m `shouldBe` (lookup k m, adjustWithKey f k m)
describe "update" $ do
it "Nothing deletes" $ property $ \(m :: DivMap Int) k ->
lookup k (update (const Nothing) k m) `shouldBe` Nothing
let f old = old + 1
it "Just adjusts" $ property $ \(m :: DivMap Int) k ->
lookup k (update (Just . f) k m) `shouldBe` lookup k (adjust f k m)
describe "updateWithKey" $ do
let f k old = Just (unDiv k + old + 1)
it "passes the key" $ property $ \(m :: DivMap Integer) k ->
lookup k (updateWithKey f k m) `shouldBe` (unDiv k + 1 +) <$> lookup k m
describe "updateLookupWithKey" $ do
let f k old = Just (unDiv k + old + 1)
it "lookup &&& updateWithKey" $ property $ \(m :: DivMap Integer) k ->
updateLookupWithKey f k m `shouldBe` (lookup k m, updateWithKey f k m)
describe "alter" $ do
let fJust _ = Just 4
it "const Just inserts" $ property $ \(m :: DivMap Int) k ->
lookup k (alter fJust k m) `shouldBe` lookup k (insert k 4 m)
let f old = Just (old + 1)
it "(>>=) updates" $ property $ \(m :: DivMap Int) k ->
lookup k (alter (>>= f) k m) `shouldBe` lookup k (update f k m)
describe "alterWithKey" $ do
let f old = (+1) <$> old
it "const f alters" $ property $ \(m :: DivMap Int) k ->
lookup k (alterWithKey (const f) k m) `shouldBe` lookup k (alter f k m)
let g k old = Just (unDiv k + old + 1)
let g' k old = old >>= g k
it "(>>=) updates" $ property $ \(m :: DivMap Integer) k ->
lookup k (alterWithKey g' k m) `shouldBe` lookup k (updateWithKey g k m)
describe "alterLookupWithKey" $ do
let f k Nothing = Just (unDiv k + 1)
f _ (Just _) = Nothing
it "lookup &&& alterWithKey" $ property $ \(m :: DivMap Integer) k ->
alterLookupWithKey f k m `shouldBe` (lookup k m, alterWithKey f k m)
describe "alterF" $ do
it "Const looks up" $ property $ \(m :: DivMap Integer) k ->
getConst (alterF Const k m) `shouldBe` lookup k m
let f _ = Identity (Just 4)
it "Identity inserts" $ property $ \(m :: DivMap Integer) k ->
lookup k (runIdentity (alterF f k m)) `shouldBe` lookup k (insert k 4 m)
describe "union" $ do
it "domain" $ property $ \(m1 :: DivMap Integer) m2 k ->
(member k m1 || member k m2) === member k (union m1 m2)
it "left bias" $ property $ \(m1 :: DivMap Integer) m2 k ->
(member k m1 && member k m2) ==> lookup k (union m1 m2) === lookup k m1
describe "unionWith" $ do
let left l _ = l
it "union == unionWith left" $ property $ \(m1 :: DivMap Integer) m2 k ->
lookup k (union m1 m2) === lookup k (unionWith left m1 m2)
let right _ r = r
it "can have right bias" $ property $ \(m1 :: DivMap Integer) m2 k ->
(member k m1 && member k m2) ==> lookup k (unionWith right m1 m2) === lookup k m2
describe "unionWithKey" $ do
let left l _ = l
it "unionWith f == unionWithKey (const f)" $ property $ \(m1 :: DivMap Integer) m2 k ->
lookup k (unionWith left m1 m2) === lookup k (unionWithKey (const left) m1 m2)
let merge k l r = unDiv k + l + r
it "can access key" $ property $ \(m1 :: DivMap Integer) m2 k ->
(member k m1 && member k m2) ==>
lookup k (unionWithKey merge m1 m2) === (merge k <$> lookup k m1 <*> lookup k m2)
describe "unions" $ do
it "domain" $
forAll (vectorOf 10 arbitrary) $ \(ms :: [DivMap Integer]) k ->
any (member k) ms === member k (unions ms)
it "left bias" $
forAll (vectorOf 10 arbitrary) $ \(ms :: [DivMap Integer]) k ->
lookup k (unions ms) === (List.find (member k) ms >>= lookup k)
describe "unionsWith" $ do
let left l _ = l
it "unions = unionsWith left" $
forAll (vectorOf 5 arbitrary) $ \(ms :: [DivMap Integer]) k ->
any (member k) ms === member k (unionsWith left ms)
let right _ r = r
it "can have right bias" $
forAll (vectorOf 5 arbitrary) $ \(ms :: [DivMap Integer]) k ->
lookup k (unionsWith right ms) === (List.find (member k) (reverse ms) >>= lookup k)
describe "difference" $
it "domain" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k ->
(member k m1 && member k (difference m1 m2)) ==> not (member k m2)
describe "differenceWith" $ do
it "difference = differenceWith (\\_ _ -> Nothing)" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k ->
lookup k (difference m1 m2) === lookup k (differenceWith (\_ _ -> Nothing) m1 m2)
it "m = differenceWith (\\l _ -> Just l) m _" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k ->
lookup k m1 === lookup k (differenceWith (\l _ -> Just l) m1 m2)
describe "differenceWithKey" $ do
let f l r = Just (l + r)
it "differenceWith f = differenceWithKey (const f)" $ property $ \(m1 :: DivMap Int) (m2 :: DivMap Int) k ->
lookup k (differenceWith f m1 m2) === lookup k (differenceWithKey (const f) m1 m2)
describe "intersection" $
it "domain" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k ->
(member k m1 && member k m2) === member k (intersection m1 m2)
describe "intersectionWith" $ do
let left l _ = l
it "intersection = intersectionWith left" $ property $ \(m1 :: DivMap Integer) (m2 :: DivMap ()) k ->
lookup k (intersection m1 m2) === lookup k (intersectionWith left m1 m2)
describe "intersectionWithKey" $ do
let f = (+)
it "intersectionWith f = intersectionWithKey f" $ property $ \(m1 :: DivMap Int) (m2 :: DivMap Int) k ->
lookup k (intersectionWith f m1 m2) === lookup k (intersectionWithKey (const f) m1 m2)
let merge k l r = unDiv k + l + r
it "can access key" $ property $ \(m1 :: DivMap Integer) m2 k ->
(member k m1 && member k m2) ==>
lookup k (intersectionWithKey merge m1 m2) === (merge k <$> lookup k m1 <*> lookup k m2)
describe "map" $ do
let f = (+1)
it "map = fmap" $ property $ \(m :: DivMap Int) ->
map f m `shouldBe` fmap f m
describe "mapWithKey" $ do
let f = (+1)
it "mapWithKey (const f) = map f" $ property $ \(m :: DivMap Int) ->
mapWithKey (const f) m `shouldBe` map f m
let g k v = unDiv k + v
it "can access keys" $ property $ \(m :: DivMap Integer) k ->
lookup k (mapWithKey g m) `shouldBe` (unDiv k +) <$> lookup k m
describe "mapAccum" $ do
let f a b = a + b
let g b = b + 1
it "mapAccum (\\a b -> (f a b, g b)) acc = foldr f acc &&& map g" $ property $ \(m :: DivMap Integer) ->
mapAccum (\a b -> (f a b, g b)) 0 m `shouldBe` (foldr f 0 &&& map g) m
describe "mapAccumWithKey" $ do
let f a b = (a + b, b + 1)
it "mapAccumWithKey (\\a _ b -> f a b) acc = mapAccum f acc" $ property $ \(m :: DivMap Integer) ->
mapAccumWithKey (\a _ b -> f a b) 0 m `shouldBe` mapAccum f 0 m
describe "mapKeys" $ do
let f = Div . (+1) . unDiv
it "mapKeys f = fromList . fmap (first f) . toList" $ property $ \(m :: DivMap Integer) ->
mapKeys f m `shouldBe` fromList (fmap (first f) (toList m))
describe "mapKeysWith" $ do
let f = Div . (\k -> (k `div` 2) + 1) . unDiv
let c = (+)
it "mapKeysWith c f = fromListWith c . fmap (first f) . toList" $ property $ \(m :: DivMap Integer) ->
mapKeysWith c f m `shouldBe` fromListWith c (fmap (first f) (toList m))
describe "mapKeysMonotonic" $ do
let f = Div . (+1) . unDiv
it "mapKeysMonotonic = mapKeys" $ property $ \(m :: DivMap Integer) ->
mapKeysMonotonic f m `shouldBe` mapKeys f m
describe "traverseWithKey" $ do
let f old = Identity (old + 1)
it "traverseWithKey (const f) = traverse f" $ property $ \(m :: DivMap Int) ->
runIdentity (traverseWithKey (const f) m) `shouldBe` runIdentity (traverse f m)
describe "traverseMaybeWithKey" $ do
let f k old = Identity (unDiv k + old + 1)
it "traverseMaybeWithKey (\\k v -> Just <$> f k v) = traverseWithKey f" $ property $ \(m :: DivMap Integer) ->
runIdentity (traverseMaybeWithKey (\k v -> Just <$> f k v) m)
`shouldBe` runIdentity (traverseWithKey f m)
describe "foldrWithKey" $ do
it "foldrWithKey (const f) = foldr f" $ property $ \(m :: DivMap Int) ->
foldrWithKey (const (-)) 0 m `shouldBe` foldr (-) 0 m
let f k a b = unDiv k + a + b
it "foldrWithKey f z = foldr (uncurry f) z . mapWithKey (,)" $ property $ \(m :: DivMap Integer) ->
foldrWithKey f 0 m `shouldBe` foldr (uncurry f) 0 (mapWithKey (,) m)
describe "foldlWithKey" $ do
it "foldlWithKey (\a _ b -> f a b) = foldl f" $ property $ \(m :: DivMap Int) ->
foldlWithKey (\a _ b -> a - b) 0 m `shouldBe` foldl (-) 0 m
let f a k b = unDiv k + a + b
it "foldlWithKey f z = foldl (\a (k, b) -> f a k b) z . mapWithKey (,)" $ property $ \(m :: DivMap Integer) ->
foldlWithKey f 0 m `shouldBe` foldl (\a (k, b) -> f a k b) 0 (mapWithKey (,) m)
describe "foldMapWithKey" $
it "foldMapWithKey (const f) = foldMap f" $ property $ \(m :: DivMap Int) ->
foldMapWithKey (const Sum) m `shouldBe` foldMap Sum m
describe "foldr'" $
it "foldr' = foldr" $ property $ \(m :: DivMap Int) ->
foldr' (-) 0 m `shouldBe` foldr (-) 0 m
describe "foldrWithKey'" $ do
let f k a b = unDiv k + a + b
it "foldrWithKey' = foldrWithKey" $ property $ \(m :: DivMap Integer) ->
foldrWithKey' f 0 m `shouldBe` foldrWithKey f 0 m
describe "foldl'" $
it "foldl' = foldl" $ property $ \(m :: DivMap Int) ->
foldl' (-) 0 m `shouldBe` foldl (-) 0 m
describe "foldlWithKey'" $ do
let f a k b = unDiv k + a + b
it "foldlWithKey' = foldlWithKey" $ property $ \(m :: DivMap Integer) ->
foldlWithKey' f 0 m `shouldBe` foldlWithKey f 0 m
describe "keys" $ do
it "length . keys = size" $ property $ \(m :: DivMap Int) ->
length (keys m) `shouldBe` size m
it "all (\\k -> member k m) (keys m)" $ property $ \(m :: DivMap Int) ->
all (`member` m) (keys m) `shouldBe` True
describe "elems" $
it "foldMap Sum . elems = foldMap Sum" $ property $ \(m :: DivMap Int) ->
foldMap Sum (elems m) `shouldBe` foldMap Sum m
describe "assocs" $ do
it "length . assocs = size" $ property $ \(m :: DivMap Int) ->
length (assocs m) `shouldBe` size m
it "List.lookup k (assocs m) = lookup k m" $ property $ \(m :: DivMap Int) k ->
List.lookup k (assocs m) `shouldBe` lookup k m
describe "toList" $ do
it "length . toList = size" $ property $ \(m :: DivMap Int) ->
length (toList m) `shouldBe` size m
it "List.lookup k (toList m) = lookup k m" $ property $ \(m :: DivMap Int) k ->
List.lookup k (toList m) `shouldBe` lookup k m
describe "fromList" $
it "fromList = foldl (\\m (k,v) -> insert k v m) empty" $ property $ \(xs :: [(Divisibility, Int)]) ->
fromList xs `shouldBe` foldl (\m (k,v) -> insert k v m) empty xs
describe "fromListWith" $ do
it "fromListWith const = fromList" $ property $ \(xs :: [(Divisibility, Int)]) ->
fromListWith const xs `shouldBe` fromList xs
let f old new = old + new
it "fromListWith f = fromListWithKey (const f)" $ property $ \(xs :: [(Divisibility, Int)]) ->
fromListWith f xs `shouldBe` fromListWithKey (const f) xs
it "fromListWith f = foldl (\\m (k,v) -> insertWith f k v m) empty" $ property $ \(xs :: [(Divisibility, Int)]) ->
fromListWith f xs `shouldBe` foldl (\m (k,v) -> insertWith f k v m) empty xs
describe "fromListWithKey" $ do
let f k old new = unDiv k + old + new
it "fromListWithKey f = foldl (\\m (k,v) -> insertWithKey f k v m) empty" $ property $ \(xs :: [(Divisibility, Integer)]) ->
fromListWithKey f xs `shouldBe` foldl (\m (k,v) -> insertWithKey f k v m) empty xs
describe "toLinearisation" $ do
it "fromList . toLinearisation = id" $ property $ \(m :: DivMap Int) ->
fromList (toLinearisation m) `shouldBe` m
it "is a linearisation" $ property $ \(m :: DivMap Int) -> do
let lin = toLinearisation m
let greqs = zipWith (\(k1, _) (k2, _) -> (k2 `leq` k1) && k1 /= k2) lin (drop 1 lin)
or greqs `shouldBe` False
describe "fromLinearisation" $
it "fromLinearisation . toLinearisation = id" $ property $ \(m :: DivMap Int) ->
fromLinearisation (toLinearisation m) `shouldBe` m
describe "filter" $
it "filter p = fromList . filter (p . snd) . toList" $ property $ \(m :: DivMap Int) ->
filter odd m `shouldBe` fromList (List.filter (odd . snd) (toList m))
describe "filterWithKey" $ do
let p k v = odd (unDiv k + v)
it "filterWithKey p = fromList . filter (uncurry p) . toList" $ property $ \(m :: DivMap Integer) ->
filterWithKey p m `shouldBe` fromList (List.filter (uncurry p) (toList m))
describe "partition" $
it "partition p = filter p &&& filter even" $ property $ \(m :: DivMap Int) ->
partition odd m `shouldBe` (filter odd &&& filter even) m
describe "partitionWithKey" $ do
let p k v = odd (unDiv k + v)
it "partitionWithKey p = filterWithKey p &&& filterWithKey ((not .) . p)" $ property $ \(m :: DivMap Integer) ->
partitionWithKey p m `shouldBe` (filterWithKey p &&& filterWithKey ((not .) . p)) m
describe "takeWhileAntitone" $ do
let p k = unDiv k < 50
it "takeWhileAntitone p = filterWithKey (\\k _ -> p k)" $ property $ \(m :: DivMap Int) ->
takeWhileAntitone p m `shouldBe` filterWithKey (\k _ -> p k) m
describe "dropWhileAntitone" $ do
let p k = unDiv k < 50
it "dropWhileAntitone p = filterWithKey (\\k _ -> not (p k))" $ property $ \(m :: DivMap Int) ->
dropWhileAntitone p m `shouldBe` filterWithKey (\k _ -> not (p k)) m
describe "spanAntitone" $ do
let p k = unDiv k < 50
it "spanAntitone p = partitionWithKey (\\k _ -> p k)" $ property $ \(m :: DivMap Int) ->
spanAntitone p m `shouldBe` partitionWithKey (\k _ -> p k) m
describe "mapMaybe" $ do
let f v = if odd v then Just (v + 1) else Nothing
it "mapMaybe f = fromList . Maybe.mapMaybe (traverse f) . toList" $ property $ \(m :: DivMap Int) ->
mapMaybe f m `shouldBe` fromList (Maybe.mapMaybe (traverse f) (toList m))
describe "mapMaybeWithKey" $ do
let f k v = if odd (unDiv k + v) then Just (v + 1) else Nothing
it "mapMaybeWithKey f = fromList . Maybe.mapMaybe (sequenceA . (fst &&& uncurry f)) . toList" $ property $ \(m :: DivMap Integer) ->
mapMaybeWithKey f m `shouldBe` fromList (Maybe.mapMaybe (sequenceA . (fst &&& uncurry f)) (toList m))
describe "mapEither" $ do
let f v
| odd v = Left (v + 1)
| otherwise = Right (v - 1)
it "mapEither f = (fromList &&& fromList) . Either.partitionEithers . fmap (... f ...) . toList" $
property $ \(m :: DivMap Int) ->
mapEither f m `shouldBe`
((fromList *** fromList)
. Either.partitionEithers
. fmap (\(k, v) -> bimap (k,) (k,) (f v))
. toList)
m
describe "mapEitherWithKey" $ do
let f k v
| odd (unDiv k + v) = Left (v + 1)
| otherwise = Right (v - 1)
it "mapEitherWithKey f = (fromList &&& fromList) . Either.partitionEithers . fmap (... f ...) . toList" $
property $ \(m :: DivMap Integer) ->
mapEitherWithKey f m `shouldBe`
((fromList *** fromList)
. Either.partitionEithers
. fmap (\(k, v) -> bimap (k,) (k,) (f k v))
. toList)
m
describe "isSubmapOf" $ do
it "div100 is submap of div1000" $
div100 `isSubmapOf` div1000
it "div1000 is not submap of div100" $
not (div1000 `isSubmapOf` div100)
describe "isSubmapOfBy" $ do
it "isSubmapOfBy (<) not refl" $ property $ \(m :: DivMap Int) ->
size m > 0 ==> not (isSubmapOfBy (<) m m)
it "isSubmapOfBy (<) m (map (+1) m)" $ property $ \(m :: DivMap Int) ->
isSubmapOfBy (<) m (map (+1) m)
describe "isProperSubmapOf" $ do
it "submap with less size" $ property $ \(m1 :: DivMap Int) m2 ->
(m1 `isProperSubmapOf` m2) `shouldBe` (size m1 < size m2 && m1 `isSubmapOf` m2)
it "div100 is proper submap of div1000" $
div100 `isProperSubmapOf` div1000
it "div1000 is not proper submap of div100" $
not (div1000 `isSubmapOf` div100)
describe "isProperSubmapOfBy" $
it "not (isProperSubmapOfBy (<) m (map (+1) m))" $ property $ \(m :: DivMap Int) ->
not (isProperSubmapOfBy (<) m (map (+1) m))
describe "lookupMin" $ do
it "antichain" $ property $ \(m :: DivMap Int) ->
isAntichain (fmap fst (lookupMin m))
let less a b = a `leq` b && not (b `leq` a)
it "no element less" $ property $ \(m :: DivMap Int) ->
shouldSatisfy (fmap fst (lookupMin m)) $ \mins ->
all (\k -> not (any (`less` k) (keys m))) mins
describe "lookupMax" $ do
let greater a b = b `leq` a && not (a `leq` b)
it "antichain" $ property $ \(m :: DivMap Int) ->
isAntichain (fmap fst (lookupMax m))
it "no element greater" $ property $ \(m :: DivMap Int) ->
shouldSatisfy (fmap fst (lookupMax m)) $ \mins ->
all (\k -> not (any (`greater` k) (keys m))) mins
describe "type class instances" $ do
describe "Functor" $
describe "fmap" $ do
it "fmap id = id" $ property $ \(m :: DivMap Int) ->
fmap id m `shouldBe` m
let f = (+1)
let g = (*2)
it "fmap f . fmap g = fmap (f . g)" $ property $ \(m :: DivMap Int) ->
fmap f (fmap g m) `shouldBe` fmap (f . g) m
it "fmaps over all entries" $ property $ \(m :: DivMap Int) k ->
lookup k (fmap (+1) m) `shouldBe` (+1) <$> lookup k m
describe "Foldable" $ do
describe "foldMap" $ do
it "getSum (foldMap (const (Sum 1))) = size" $ property $ \(m :: DivMap Int) ->
getSum (foldMap (const (Sum 1)) m) `shouldBe` size m
it "foldMap f = fold . fmap f" $ property $ \(m :: DivMap Int) ->
foldMap Sum m `shouldBe` fold (fmap Sum m)
describe "foldr" $ do
let f = (-)
let z = 9000
it "foldr f z m = appEndo (foldMap (Endo . f) m ) z" $ property $ \(m :: DivMap Int) ->
foldr f z m `shouldBe` appEndo (foldMap (Endo . f) m ) z
describe "foldl" $ do
let f = (-)
let z = 9000
it "foldl f z m = appEndo (getDual (foldMap (Dual . Endo . flip f) m)) z" $ property $ \(m :: DivMap Int) ->
foldl f z m `shouldBe` appEndo (getDual (foldMap (Dual . Endo . flip f) m)) z
describe "fold" $
it "fold = foldMap id" $ property $ \(m :: DivMap Int) ->
let m' = coerce m :: DivMap (Sum Int)
in fold m' `shouldBe` foldMap id m'
describe "Traversable" $ do
describe "traverse" $ do
it "traverse (const (Const (Sum 1))) = size" $ property $ \(m :: DivMap Int) ->
getSum (getConst (traverse (const (Const (Sum 1))) m)) `shouldBe` size m
let f n = replicate (min 2 n) n
let g n = if odd n then Just n else Nothing
let t = Maybe.listToMaybe
it "naturality" $ property $ \(m :: DivMap Int) ->
t (traverse f m) `shouldBe` traverse (t . f) m
it "identity" $ property $ \(m :: DivMap Int) ->
traverse Identity m `shouldBe` Identity m
it "composition" $ property $ \(m :: DivMap Int) ->
traverse (Compose . fmap g . f) m `shouldBe` (Compose . fmap (traverse g) . traverse f) m
describe "sequenceA" $ do
let t = Maybe.listToMaybe
it "naturality" $ property $ \(m :: DivMap [Int]) ->
t (sequenceA m) `shouldBe` sequenceA (fmap t m)
it "identity" $ property $ \(m :: DivMap Int) ->
sequenceA (fmap Identity m) `shouldBe` Identity m
it "composition" $ property $ \(m :: DivMap (Maybe (Maybe Int))) ->
sequenceA (fmap Compose m) `shouldBe` (Compose . fmap sequenceA . sequenceA) m
it "fmap = fmapDefault" $ property $ \(m :: DivMap Int) ->
fmap (+1) m `shouldBe` fmapDefault (+1) m
it "foldMap = foldMapDefault" $ property $ \(m :: DivMap Int) ->
foldMap Sum m `shouldBe` foldMapDefault Sum m
describe "regression tests" $ do
describe "#3" $ do
it "example 1" $ do
let e = OrdInt 13
let s1 = POSet.delete e $
POSet.fromList [ OrdInt 0, OrdInt 32, e ]
let s2 = POSet.fromList [ OrdInt 0, OrdInt 32 ]
s1 `shouldBe` s2
length s1 `shouldBe` 2
it "example 2" $ do
let e = OrdInt 0
let s1 = POSet.delete e $
POSet.fromList [ e, OrdInt 1 ]
let s2 = POSet.fromList [ OrdInt 1 ]
s1 `shouldBe` s2
length s1 `shouldBe` 1