{-# LANGUAGE CPP                       #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE ScopedTypeVariables       #-}

{-# OPTIONS_GHC -fno-warn-orphans            #-} -- because of Arbitrary (HashMap k v)
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- https://github.com/nick8325/quickcheck/issues/344

-- | Tests for "Data.HashMap.Lazy" and "Data.HashMap.Strict".  We test functions by
-- comparing them to @Map@ from @containers@. @Map@ is referred to as the /model/
-- for 'HashMap'

#if defined(STRICT)
#define MODULE_NAME Properties.HashMapStrict
#else
#define MODULE_NAME Properties.HashMapLazy
#endif

module MODULE_NAME (tests) where

import Control.Applicative         (Const (..))
import Data.Bifoldable
import Data.Function               (on)
import Data.Functor.Identity       (Identity (..))
import Data.Hashable               (Hashable (hashWithSalt))
import Data.HashMap.Internal.Debug (Validity (..), valid)
import Data.Ord                    (comparing)
import Test.QuickCheck             (Arbitrary (..), Fun, Property, pattern Fn,
                                    pattern Fn2, pattern Fn3, (===), (==>))
import Test.QuickCheck.Poly        (A, B, C)
import Test.Tasty                  (TestTree, testGroup)
import Test.Tasty.QuickCheck       (testProperty)
import Util.Key                    (Key, incKey, keyToInt)

import qualified Data.Foldable   as Foldable
import qualified Data.List       as List
import qualified Test.QuickCheck as QC

#if defined(STRICT)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict     as M
#else
import           Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HM
import qualified Data.Map.Lazy     as M
#endif

instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
  arbitrary = HM.fromList <$> arbitrary
  shrink = fmap HM.fromList . shrink . HM.toList

------------------------------------------------------------------------
-- Helpers

type HMK  = HashMap Key
type HMKI = HMK Int

sortByKey :: Ord k => [(k, v)] -> [(k, v)]
sortByKey = List.sortBy (compare `on` fst)

toOrdMap :: Ord k => HashMap k v -> M.Map k v
toOrdMap = M.fromList . HM.toList

isValid :: (Eq k, Hashable k, Show k) => HashMap k v -> Property
isValid m = valid m === Valid

-- The free magma is used to test that operations are applied in the
-- same order.
data Magma a
  = Leaf a
  | Op (Magma a) (Magma a)
  deriving (Show, Eq, Ord)

instance Hashable a => Hashable (Magma a) where
  hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a)
  hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n)

------------------------------------------------------------------------
-- Test list

tests :: TestTree
tests =
  testGroup
#if defined(STRICT)
    "Data.HashMap.Strict"
#else
    "Data.HashMap.Lazy"
#endif
    [
    -- Instances
      testGroup "instances"
      [ testGroup "Eq"
        [ testProperty "==" $
          \(x :: HMKI) y -> (x == y) === (toOrdMap x == toOrdMap y)
        , testProperty "/=" $
          \(x :: HMKI) y -> (x == y) === (toOrdMap x == toOrdMap y)
        ]
      , testGroup "Ord"
        [ testProperty "compare reflexive" $
          \(m :: HMKI) -> compare m m === EQ
        , testProperty "compare transitive" $
          \(x :: HMKI) y z -> case (compare x y, compare y z) of
            (EQ, o)  -> compare x z === o
            (o,  EQ) -> compare x z === o
            (LT, LT) -> compare x z === LT
            (GT, GT) -> compare x z === GT
            (LT, GT) -> QC.property True -- ys greater than xs and zs.
            (GT, LT) -> QC.property True
        , testProperty "compare antisymmetric" $
          \(x :: HMKI) y -> case (compare x y, compare y x) of
            (EQ, EQ) -> True
            (LT, GT) -> True
            (GT, LT) -> True
            _        -> False
        , testProperty "Ord => Eq" $
          \(x :: HMKI) y -> case (compare x y, x == y) of
            (EQ, True)  -> True
            (LT, False) -> True
            (GT, False) -> True
            _           -> False
        ]
      , testProperty "Read/Show" $
        \(x :: HMKI) -> x === read (show x)
      , testProperty "Functor" $
        \(x :: HMKI) (Fn f :: Fun Int Int) ->
          toOrdMap (fmap f x) === fmap f (toOrdMap x)
      , testProperty "Foldable" $
        \(x :: HMKI) ->
          let f = List.sort . Foldable.foldr (:) []
          in  f x === f (toOrdMap x)
      , testGroup "Bifoldable"
        [ testProperty "bifoldMap" $
          \(m :: HMK Key) ->
            bifoldMap (:[]) (:[]) m === concatMap (\(k, v) -> [k, v]) (HM.toList m)
        , testProperty "bifoldr" $
          \(m :: HMK Key) ->
            bifoldr (:) (:) [] m === concatMap (\(k, v) -> [k, v]) (HM.toList m)
        , testProperty "bifoldl" $
          \(m :: HMK Key) ->
            bifoldl (flip (:)) (flip (:)) [] m
            ===
            reverse (concatMap (\(k, v) -> [k, v]) (HM.toList m))
        ]
      , testProperty "Hashable" $
        \(xs :: [(Key, Int)]) is salt ->
          let xs' = List.nubBy (\(k,_) (k',_) -> k == k') xs
              -- Shuffle the list using indexes in the second
              shuffle :: [Int] -> [a] -> [a]
              shuffle idxs = List.map snd
                           . List.sortBy (comparing fst)
                           . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])
              ys = shuffle is xs'
              x = HM.fromList xs'
              y = HM.fromList ys
          in  x == y ==> hashWithSalt salt x === hashWithSalt salt y
      ]
    -- Construction
    , testGroup "empty"
      [ testProperty "valid" $ QC.once $
        isValid (HM.empty :: HMKI)
      ]
    , testGroup "singleton"
      [ testProperty "valid" $
        \(k :: Key) (v :: A) -> isValid (HM.singleton k v)
      ]
    -- Basic interface
    , testProperty "size" $
      \(x :: HMKI) -> HM.size x === M.size (toOrdMap x)
    , testProperty "member" $
      \(k :: Key) (m :: HMKI) -> HM.member k m === M.member k (toOrdMap m)
    , testProperty "lookup" $
      \(k :: Key) (m :: HMKI) -> HM.lookup k m === M.lookup k (toOrdMap m)
    , testProperty "!?" $
      \(k :: Key) (m :: HMKI) -> m HM.!? k === M.lookup k (toOrdMap m)
    , testGroup "insert"
      [ testProperty "model" $
        \(k :: Key) (v :: Int) x ->
          let y = HM.insert k v x
          in  toOrdMap y === M.insert k v (toOrdMap x)
      , testProperty "valid" $
        \(k :: Key) (v :: Int) x -> isValid (HM.insert k v x)
      ]
    , testGroup "insertWith"
      [ testProperty "insertWith" $
        \(Fn2 f) k v (x :: HMKI) ->
          toOrdMap (HM.insertWith f k v x) === M.insertWith f k v (toOrdMap x)
      , testProperty "valid" $
        \(Fn2 f) k v (x :: HMKI) -> isValid (HM.insertWith f k v x)
      ]
    , testGroup "delete"
      [ testProperty "model" $
        \(k :: Key) (x :: HMKI) ->
          let y = HM.delete k x
          in  toOrdMap y === M.delete k (toOrdMap x)
      , testProperty "valid" $
        \(k :: Key) (x :: HMKI) -> isValid (HM.delete k x)
      ]
    , testGroup "adjust" 
      [ testProperty "model" $
        \(Fn f) k (x :: HMKI) ->
          toOrdMap (HM.adjust f k x) === M.adjust f k (toOrdMap x)
      , testProperty "valid" $
        \(Fn f) k (x :: HMKI) -> isValid (HM.adjust f k x)
      ]
    , testGroup "update" 
      [ testProperty "model" $
        \(Fn f) k (x :: HMKI) ->
          toOrdMap (HM.update f k x) === M.update f k (toOrdMap x)
      , testProperty "valid" $
        \(Fn f) k (x :: HMKI) -> isValid (HM.update f k x)
      ]
    , testGroup "alter"
      [ testProperty "model" $
        \(Fn f) k (x :: HMKI) ->
          toOrdMap (HM.alter f k x) === M.alter f k (toOrdMap x)
      , testProperty "valid" $
        \(Fn f) k (x :: HMKI) -> isValid (HM.alter f k x)
      ]
    , testGroup "alterF"
      [ testGroup "model"
        [ -- We choose the list functor here because we don't fuss with
          -- it in alterF rules and because it has a sufficiently interesting
          -- structure to have a good chance of breaking if something is wrong.
          testProperty "[]" $
          \(Fn f :: Fun (Maybe A) [Maybe A]) k (x :: HMK A) ->
            map toOrdMap (HM.alterF f k x) === M.alterF f k (toOrdMap x)
        , testProperty "adjust" $
          \(Fn f) k (x :: HMKI) ->
            let g = Identity . fmap f
            in  fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)
        , testProperty "insert" $
          \v k (x :: HMKI) ->
            let g = const . Identity . Just $ v
            in  fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)
        , testProperty "insertWith" $
          \(Fn f) k v (x :: HMKI) ->
            let g = Identity . Just . maybe v f
            in  fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)
        , testProperty "delete" $
          \k (x :: HMKI) ->
            let f = const (Identity Nothing)
            in  fmap toOrdMap (HM.alterF f k x) === M.alterF f k (toOrdMap x)
        , testProperty "lookup" $
          \(Fn f :: Fun (Maybe A) B) k (x :: HMK A) ->
            let g = Const . f
            in  fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)
        ]
      , testProperty "valid" $
        \(Fn f :: Fun (Maybe A) [Maybe A]) k (x :: HMK A) ->
          let ys = HM.alterF f k x
          in  map valid ys === (Valid <$ ys)
      ]
    , testGroup "isSubmapOf"
      [ testProperty "model" $
        \(x :: HMKI) y -> HM.isSubmapOf x y === M.isSubmapOf (toOrdMap x) (toOrdMap y)
      , testProperty "m ⊆ m" $
        \(x :: HMKI) -> HM.isSubmapOf x x
      , testProperty "m1 ⊆ m1 ∪ m2" $
        \(x :: HMKI) y -> HM.isSubmapOf x (HM.union x y)
      , testProperty "m1 ⊈ m2  ⇒  m1 ∪ m2 ⊈ m1" $
        \(m1 :: HMKI) m2 -> not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2)
      , testProperty "m1\\m2 ⊆ m1" $
        \(m1 :: HMKI) (m2 :: HMKI) -> HM.isSubmapOf (HM.difference m1 m2) m1
      , testProperty "m1 ∩ m2 ≠ ∅  ⇒  m1 ⊈ m1\\m2 " $
        \(m1 :: HMKI) (m2 :: HMKI) ->
          not (HM.null (HM.intersection m1 m2)) ==>
          not (HM.isSubmapOf m1 (HM.difference m1 m2))
      , testProperty "delete k m ⊆ m" $
        \(m :: HMKI) ->
          not (HM.null m) ==>
          QC.forAll (QC.elements (HM.keys m)) $ \k ->
          HM.isSubmapOf (HM.delete k m) m
      , testProperty "m ⊈ delete k m " $
        \(m :: HMKI) ->
          not (HM.null m) ==>
          QC.forAll (QC.elements (HM.keys m)) $ \k ->
          not (HM.isSubmapOf m (HM.delete k m))
      , testProperty "k ∉ m  ⇒  m ⊆ insert k v m" $
        \k v (m :: HMKI) -> not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m)
      , testProperty "k ∉ m  ⇒  insert k v m ⊈ m" $
        \k v (m :: HMKI) -> not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m)
      ]
    -- Combine
    , testGroup "union"
      [ testProperty "model" $
        \(x :: HMKI) y ->
          let z = HM.union x y
          in  toOrdMap z === M.union (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(x :: HMKI) y -> isValid (HM.union x y)
      ]
    , testGroup "unionWith"
      [ testProperty "model" $
        \(Fn2 f) (x :: HMKI) y ->
          toOrdMap (HM.unionWith f x y) === M.unionWith f (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(Fn2 f) (x :: HMKI) y -> isValid (HM.unionWith f x y)
      ]
    , testGroup "unionWithKey"
      [ testProperty "model" $
        \(Fn3 f) (x :: HMKI) y ->
          toOrdMap (HM.unionWithKey f x y) === M.unionWithKey f (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(Fn3 f) (x :: HMKI) y -> isValid (HM.unionWithKey f x y)
      ]
    , testGroup "unions"
      [ testProperty "model" $
        \(ms :: [HMKI]) -> toOrdMap (HM.unions ms) === M.unions (map toOrdMap ms)
      , testProperty "valid" $
        \(ms :: [HMKI]) -> isValid (HM.unions ms)
      ]
    , testGroup "difference"
      [ testProperty "model" $
        \(x :: HMKI) (y :: HMKI) ->
          toOrdMap (HM.difference x y) === M.difference (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(x :: HMKI) (y :: HMKI) -> isValid (HM.difference x y)
      ]
    , testGroup "differenceWith"
      [ testProperty "model" $
        \(Fn2 f) (x :: HMK A) (y :: HMK B) ->
          toOrdMap (HM.differenceWith f x y) === M.differenceWith f (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(Fn2 f) (x :: HMK A) (y :: HMK B) -> isValid (HM.differenceWith f x y)
      ]
    , testGroup "intersection"
      [ testProperty "model" $
        \(x :: HMKI) (y :: HMKI) ->
          toOrdMap (HM.intersection x y) === M.intersection (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(x :: HMKI) (y :: HMKI) ->
          isValid (HM.intersection x y)
      ]
    , testGroup "intersectionWith"
      [ testProperty "model" $
        \(Fn2 f :: Fun (A, B) C) (x :: HMK A) (y :: HMK B) ->
          toOrdMap (HM.intersectionWith f x y) === M.intersectionWith f (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(Fn2 f :: Fun (A, B) C) (x :: HMK A) (y :: HMK B) ->
          isValid (HM.intersectionWith f x y)
      ]
    , testGroup "intersectionWithKey"
      [ testProperty "model" $
        \(Fn3 f :: Fun (Key, A, B) C) (x :: HMK A) (y :: HMK B) ->
          toOrdMap (HM.intersectionWithKey f x y)
          ===
          M.intersectionWithKey f (toOrdMap x) (toOrdMap y)
      , testProperty "valid" $
        \(Fn3 f :: Fun (Key, A, B) C) (x :: HMK A) (y :: HMK B) ->
          isValid (HM.intersectionWithKey f x y)
      ]
    , testGroup "compose"
      [ testProperty "valid" $
        \(x :: HMK Int) (y :: HMK Key) -> isValid (HM.compose x y)
      ]
    -- Transformations
    , testGroup "map"
      [ testProperty "model" $
        \(Fn f :: Fun A B) (m :: HMK A) -> toOrdMap (HM.map f m) === M.map f (toOrdMap m)
      , testProperty "valid" $
        \(Fn f :: Fun A B) (m :: HMK A) -> isValid (HM.map f m)
      ]
    , testGroup "traverseWithKey"
      [ testProperty "model" $ QC.mapSize (\s -> s `div` 8) $
        \(x :: HMKI) ->
          let f k v = [keyToInt k + v + 1, keyToInt k + v + 2]
              ys = HM.traverseWithKey f x
          in  List.sort (fmap toOrdMap ys) === List.sort (M.traverseWithKey f (toOrdMap x))
      , testProperty "valid" $ QC.mapSize (\s -> s `div` 8) $
        \(x :: HMKI) ->
          let f k v = [keyToInt k + v + 1, keyToInt k + v + 2]
              ys = HM.traverseWithKey f x
          in  fmap valid ys === (Valid <$ ys)
      ]
    , testGroup "mapKeys"
      [ testProperty "model" $
        \(m :: HMKI) -> toOrdMap (HM.mapKeys incKey m) === M.mapKeys incKey (toOrdMap m)
      , testProperty "valid" $
        \(Fn f :: Fun Key Key) (m :: HMKI) -> isValid (HM.mapKeys f m)
      ]
    -- Folds
    , testProperty "foldr" $
      \(m :: HMKI) -> List.sort (HM.foldr (:) [] m) === List.sort (M.foldr (:) [] (toOrdMap m))
    , testProperty "foldl" $
      \(m :: HMKI) ->
        List.sort (HM.foldl (flip (:)) [] m) === List.sort (M.foldl (flip (:)) [] (toOrdMap m))
    , testProperty "foldrWithKey" $
      \(m :: HMKI) ->
        let f k v z = (k, v) : z
        in  sortByKey (HM.foldrWithKey f [] m) === sortByKey (M.foldrWithKey f [] (toOrdMap m))
    , testProperty "foldlWithKey" $
      \(m :: HMKI) ->
        let f z k v = (k, v) : z
        in  sortByKey (HM.foldlWithKey f [] m) === sortByKey (M.foldlWithKey f [] (toOrdMap m))
    , testProperty "foldrWithKey'" $
      \(m :: HMKI) ->
        let f k v z = (k, v) : z
        in  sortByKey (HM.foldrWithKey' f [] m) === sortByKey (M.foldrWithKey' f [] (toOrdMap m))
    , testProperty "foldlWithKey'" $
      \(m :: HMKI) ->
        let f z k v = (k, v) : z
        in  sortByKey (HM.foldlWithKey' f [] m) === sortByKey (M.foldlWithKey' f [] (toOrdMap m))
    , testProperty "foldl'" $
      \(m :: HMKI) ->
        List.sort (HM.foldl' (flip (:)) [] m) === List.sort (M.foldl' (flip (:)) [] (toOrdMap m))
    , testProperty "foldr'" $
      \(m :: HMKI) -> List.sort (HM.foldr' (:) [] m) === List.sort (M.foldr' (:) [] (toOrdMap m))
    , testProperty "foldMapWithKey" $
      \(m :: HMKI) ->
        let f k v = [(k, v)]
        in  sortByKey (HM.foldMapWithKey f m) === sortByKey (M.foldMapWithKey f (toOrdMap m))
    -- Filter
    , testGroup "filter"
      [ testProperty "model" $
        \(Fn p) (m :: HMKI) -> toOrdMap (HM.filter p m) === M.filter p (toOrdMap m)
      , testProperty "valid" $
        \(Fn p) (m :: HMKI) -> isValid (HM.filter p m)
      ]
    , testGroup "filterWithKey"
      [ testProperty "model" $
        \(Fn2 p) (m :: HMKI) ->
          toOrdMap (HM.filterWithKey p m) === M.filterWithKey p (toOrdMap m)
      , testProperty "valid" $
        \(Fn2 p) (m :: HMKI) -> isValid (HM.filterWithKey p m)
      ]
    , testGroup "mapMaybe"
      [ testProperty "model" $
        \(Fn f :: Fun A (Maybe B)) (m :: HMK A) ->
          toOrdMap (HM.mapMaybe f m) === M.mapMaybe f (toOrdMap m)
      , testProperty "valid" $
        \(Fn f :: Fun A (Maybe B)) (m :: HMK A) -> isValid (HM.mapMaybe f m)
      ]
    , testGroup "mapMaybeWithKey"
      [ testProperty "model" $
        \(Fn2 f :: Fun (Key, A) (Maybe B)) (m :: HMK A) ->
          toOrdMap (HM.mapMaybeWithKey f m) === M.mapMaybeWithKey f (toOrdMap m)
      , testProperty "valid" $
        \(Fn2 f :: Fun (Key, A) (Maybe B)) (m :: HMK A) ->
          isValid (HM.mapMaybeWithKey f m)
      ]
    -- Conversions
    , testProperty "elems" $
      \(m :: HMKI) -> List.sort (HM.elems m) === List.sort (M.elems (toOrdMap m))
    , testProperty "keys" $
      \(m :: HMKI) -> List.sort (HM.keys m) === List.sort (M.keys (toOrdMap m))
    , testGroup "fromList"
      [ testProperty "model" $
        \(kvs :: [(Key, Int)]) -> toOrdMap (HM.fromList kvs) === M.fromList kvs
      , testProperty "valid" $
        \(kvs :: [(Key, Int)]) -> isValid (HM.fromList kvs)
      ]
    , testGroup "fromListWith"
      [ testProperty "model" $
        \(kvs :: [(Key, Int)]) ->
          let kvsM = map (fmap Leaf) kvs
          in  toOrdMap (HM.fromListWith Op kvsM) === M.fromListWith Op kvsM
      , testProperty "valid" $
        \(Fn2 f) (kvs :: [(Key, A)]) -> isValid (HM.fromListWith f kvs)
      ]
    , testGroup "fromListWithKey"
      [ testProperty "model" $
        \(kvs :: [(Key, Int)]) ->
          let kvsM = fmap (\(k,v) -> (Leaf (keyToInt k), Leaf v)) kvs
              combine k v1 v2 = Op k (Op v1 v2)
          in  toOrdMap (HM.fromListWithKey combine kvsM) === M.fromListWithKey combine kvsM
      , testProperty "valid" $
        \(Fn3 f) (kvs :: [(Key, A)]) -> isValid (HM.fromListWithKey f kvs)
      ]
    , testProperty "toList" $
      \(m :: HMKI) -> List.sort (HM.toList m) === List.sort (M.toList (toOrdMap m))
    ]