pinboard-0.9.6: tests/Instances.hs

module Instances where

import           Data.Text (Text, pack)
import           Data.Char (isSpace)
import           Data.List (sort)
import           Data.Time.Calendar (Day(..))
import           Data.Time.Clock (UTCTime(..), secondsToDiffTime)
import           Test.QuickCheck
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as Set

import ApproxEq
import Pinboard

instance Arbitrary Text where
  arbitrary = pack <$> arbitrary

instance Arbitrary Day where
  arbitrary = ModifiedJulianDay . (2000 +) <$> arbitrary
  shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay

instance Arbitrary UTCTime where
  arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose (0, 86401))

instance Arbitrary Note where
  arbitrary = Note <$> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary

instance Arbitrary NoteList where
  arbitrary = NoteList <$> arbitrary <*> resize 15 arbitrary

instance Arbitrary NoteListItem where
  arbitrary = NoteListItem <$> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary

instance Arbitrary Posts where
  arbitrary = Posts <$> arbitrary <*> arbitrary <*> resize 15 arbitrary

instance Arbitrary Post where
  arbitrary = Post <$> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitrary
                   <*> arbitraryTags

instance Arbitrary JsonTagMap where
  arbitrary = ToJsonTagMap <$> (HM.fromList <$> listOf ((,) <$> arbitraryTag <*> arbitrary))

arbitraryTags :: Gen [Tag]
arbitraryTags = listOf arbitraryTag

arbitraryTag :: Gen Tag
arbitraryTag = pack <$> listOf1 (arbitrary `suchThat` (\c -> (not . isSpace) c && (',' /= c)))

-- | Checks if a given list has no duplicates in _O(n log n)_.
hasNoDups :: (Ord a) => [a] -> Bool
hasNoDups = go Set.empty
  where
    go _ [] = True
    go s (x:xs)
      | s' <- Set.insert x s,
        Set.size s' > Set.size s
      = go s' xs
      | otherwise = False

instance Arbitrary PostDates where
  arbitrary = PostDates <$> arbitrary <*> arbitrary <*> (arbitrary `suchThat` isValidDateCount)
    where
      isValidDateCount xs = hasNoDups (fst <$> xs) && all (> 0) (snd <$> xs)

instance ApproxEq Day where (=~) = (==)
instance ApproxEq PostDates where
  (=~) a b =
    postDatesUser a =~ postDatesUser b
    && postDatesTag a =~ postDatesTag b
    && sort (postDatesCount a) =~ sort (postDatesCount b)

instance Arbitrary Suggested where
  arbitrary = arbitrary >>= \a -> elements [Popular a, Recommended a]