content: {-# LANGUAGE ApplicativeDo #-}
  {-# LANGUAGE LinearTypes #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# OPTIONS_GHC -Wno-name-shadowing #-}
  
  -- |
  -- Tests for mutable hashmaps
  --
  -- See the testing framework explained in Test.Data.Mutable.Set.
  --
  -- The combination of axioms and homomorphisms provided (for the most part)
  -- functionally specify the behavior of hashmaps. There are a few things
  -- we leave out and mention below.
  --
  -- Remarks:
  -- * We don't test trivial things like: empty, capacity
  -- * We don't test member since we test lookup
  -- * We don't test alter and hope insert and delete tests suffice
  -- * We don't test filterWithKey and hope the test for filter suffices
  -- * We don't test mapMaybe since mapMaybeWithKey is more general
  module Test.Data.Mutable.HashMap
    ( mutHMTests,
    )
  where
  
  import Data.Containers.ListUtils (nubOrdOn)
  import Data.Function ((&))
  import qualified Data.Functor.Linear as Linear
  import qualified Data.HashMap.Mutable.Linear as HashMap
  import Data.List (sort)
  import qualified Data.List as List
  import qualified Data.Map.Lazy as Map
  import Data.Maybe (mapMaybe)
  import Data.Unrestricted.Linear
  import Hedgehog
  import qualified Hedgehog.Gen as Gen
  import qualified Hedgehog.Range as Range
  import qualified Prelude.Linear as Linear
  import Test.Tasty
  import Test.Tasty.Hedgehog (testPropertyNamed)
  
  -- # Exported Tests
  --------------------------------------------------------------------------------
  
  mutHMTests :: TestTree
  mutHMTests = testGroup "Mutable hashmap tests" group
  
  group :: [TestTree]
  group =
    [ -- Axiomatic tests
      testPropertyNamed "∀ k,v,m. lookup k (insert m k v) = Just v" "lookupInsert1" lookupInsert1,
      testPropertyNamed
        "∀ k,v,m,k'/=k. lookup k'(insert m k v) = lookup k' m"
        "lookuInsert2"
        lookupInsert2,
      testPropertyNamed "∀ k,m. lookup k (delete m k) = Nothing" "lookupDelete1" lookupDelete1,
      testPropertyNamed
        "∀ k,m,k'/=k. lookup k' (delete m k) = lookup k' m"
        "lookupDelete2"
        lookupDelete2,
      testPropertyNamed "∀ k,v,m. member k (insert m k v) = True" "memberInsert" memberInsert,
      testPropertyNamed "∀ k,m. member k (delete m k) = False" "memberDelete" memberDelete,
      testPropertyNamed "∀ k,v,m. size (insert (m-k) k v) = 1+ size (m-k)" "sizeInsert" sizeInsert,
      testPropertyNamed "∀ k,m with k. size (delete m k) + 1 = size m" "deleteSize" deleteSize,
      -- Homorphism tests against a reference implementation
      testPropertyNamed "insert k v h = fromList (toList h ++ [(k,v)])" "refInsert" refInsert,
      testPropertyNamed "delete k h = fromList (filter (!= k . fst) (toList h))" "refDelete" refDelete,
      testPropertyNamed "fst . lookup k h = lookup k (toList h)" "refLookup" refLookup,
      testPropertyNamed "mapMaybe f h = fromList . mapMaybe (uncurry f) . toList" "refMap" refMap,
      testPropertyNamed "size = length . toList" "refSize" refSize,
      testPropertyNamed "toList . fromList = id" "refToListFromList" refToListFromList,
      testPropertyNamed "filter f (fromList xs) = fromList (filter f xs)" "refFilter" refFilter,
      testPropertyNamed "fromList xs <> fromList ys = fromList (xs <> ys)" "refMappend" refMappend,
      testPropertyNamed "unionWith reference" "refUnionWith" refUnionWith,
      testPropertyNamed "intersectionWith reference" "refIntersectionWith" refIntersectionWith,
      -- Misc
      testPropertyNamed "toList . shrinkToFit = toList" "shrinkToFitTest" shrinkToFitTest
    ]
  
  -- # Internal Library
  --------------------------------------------------------------------------------
  
  -- # Mini Testing Framework
  ----------------------------------------
  
  -- | All tests are on maps from int to string
  type HMap = HashMap.HashMap Int String
  
  -- | A test checks a boolean property on a hashmap and consumes it
  type HMTest = HMap %1 -> Ur Bool
  
  maxSize :: Int
  maxSize = 800
  
  -- HashMap's have lots of corner cases, so we try harder to find them.
  defProperty :: PropertyT IO () -> Property
  defProperty = withTests 1000 . property
  
  -- | Run a test on a random HashMap
  testOnAnyHM :: PropertyT IO HMTest -> Property
  testOnAnyHM propHmtest = defProperty $ do
    kvs <- forAll keyVals
    hmtest <- propHmtest
    assert $ unur Linear.$ HashMap.fromList kvs hmtest
  
  testKVPairExists :: (Int, String) -> HMTest
  testKVPairExists (k, v) hmap =
    fromLookup Linear.$ getFst Linear.$ HashMap.lookup k hmap
    where
      fromLookup :: Ur (Maybe String) %1 -> Ur Bool
      fromLookup (Ur Nothing) = Ur False
      fromLookup (Ur (Just v')) = Ur (v' == v)
  
  testKeyMember :: Int -> HMTest
  testKeyMember key hmap = getFst Linear.$ HashMap.member key hmap
  
  testKeyNotMember :: Int -> HMTest
  testKeyNotMember key hmap = Linear.fmap Linear.not (testKeyMember key hmap)
  
  -- | That is, test that lookup gives us `Nothing`
  testKeyMissing :: Int -> HMTest
  testKeyMissing key hmap =
    fromLookup Linear.$ getFst Linear.$ HashMap.lookup key hmap
    where
      fromLookup :: Ur (Maybe String) %1 -> Ur Bool
      fromLookup (Ur Nothing) = Ur True
      fromLookup (Ur _) = Ur False
  
  testLookupUnchanged :: (HMap %1 -> HMap) -> Int -> HMTest
  testLookupUnchanged f k hmap = fromLookup (HashMap.lookup k hmap)
    where
      fromLookup :: (Ur (Maybe String), HMap) %1 -> Ur Bool
      fromLookup (look1, hmap') =
        compareMaybes look1 (getFst Linear.$ HashMap.lookup k (f hmap'))
  
  insertPair :: (Int, String) -> HMap %1 -> HMap
  insertPair (k, v) hmap = HashMap.insert k v hmap
  
  -- XXX: This is a terrible name
  getFst :: (Consumable b) => (a, b) %1 -> a
  getFst (a, b) = lseq b a
  
  compareMaybes ::
    (Eq a) =>
    Ur (Maybe a) %1 ->
    Ur (Maybe a) %1 ->
    Ur Bool
  compareMaybes (Ur a) (Ur b) = Ur (a == b)
  
  -- # Random Generation
  ----------------------------------------
  
  -- | Key generator
  key :: Gen Int
  key = Gen.int $ Range.linearFrom 0 (-20) 20
  
  -- | Value generator
  val :: Gen String
  val = do
    let strSize = Range.singleton 3
    Gen.string strSize Gen.alpha
  
  -- | Random pairs with no duplicate keys
  keyVals :: Gen [(Int, String)]
  keyVals = do
    size <- Gen.int $ Range.linear 0 maxSize
    let sizeGen = Range.singleton size
    keys <- Gen.list sizeGen key
    vals <- Gen.list sizeGen val
    return $ zip keys vals
  
  -- # Tests
  --------------------------------------------------------------------------------
  
  lookupInsert1 :: Property
  lookupInsert1 = testOnAnyHM $ do
    k <- forAll key
    v <- forAll val
    let insertKV = insertPair (k, v)
    let checkKV = testKVPairExists (k, v)
    return (checkKV Linear.. insertKV)
  
  lookupInsert2 :: Property
  lookupInsert2 = testOnAnyHM $ do
    k <- forAll key
    k' <- forAll $ Gen.filter (/= k) key
    v <- forAll val
    let insertKV = insertPair (k, v)
    return (testLookupUnchanged insertKV k')
  
  lookupDelete1 :: Property
  lookupDelete1 = testOnAnyHM $ do
    k <- forAll key
    let checkNoKey = testKeyMissing k
    return (checkNoKey Linear.. HashMap.delete k)
  
  lookupDelete2 :: Property
  lookupDelete2 = testOnAnyHM $ do
    k <- forAll key
    k' <- forAll $ Gen.filter (/= k) key
    return (testLookupUnchanged (HashMap.delete k) k')
  
  memberInsert :: Property
  memberInsert = testOnAnyHM $ do
    k <- forAll key
    v <- forAll val
    let insertKV = insertPair (k, v)
    let isMemberK = testKeyMember k
    return (isMemberK Linear.. insertKV)
  
  memberDelete :: Property
  memberDelete = testOnAnyHM $ do
    k <- forAll key
    v <- forAll val
    let pair = (k, v)
    let insertKV = insertPair pair
    let checkNotMember = testKeyNotMember k
    return (checkNotMember Linear.. HashMap.delete k Linear.. insertKV)
  
  sizeInsert :: Property
  sizeInsert = testOnAnyHM $ do
    k <- forAll key
    v <- forAll val
    let pair = (k, v)
    let insertCheckSize = checkSizeAfterInsert pair
    return (insertCheckSize Linear.. HashMap.delete k)
  
  checkSizeAfterInsert :: (Int, String) -> HMTest
  checkSizeAfterInsert (k, v) hmap = withSize Linear.$ HashMap.size hmap
    where
      withSize :: (Ur Int, HMap) %1 -> Ur Bool
      withSize (oldSize, hmap) =
        checkSize oldSize Linear.$
          getFst Linear.$
            HashMap.size Linear.$
              HashMap.insert k v hmap
      checkSize :: Ur Int %1 -> Ur Int %1 -> Ur Bool
      checkSize (Ur old) (Ur new) =
        Ur ((old + 1) == new)
  
  deleteSize :: Property
  deleteSize = testOnAnyHM $ do
    k <- forAll key
    v <- forAll val
    let insertKV = insertPair (k, v)
    let checkSize = checkSizeAfterDelete k
    return (checkSize Linear.. insertKV)
  
  checkSizeAfterDelete :: Int -> HMTest
  checkSizeAfterDelete key hmap = fromSize (HashMap.size hmap)
    where
      fromSize :: (Ur Int, HMap) %1 -> Ur Bool
      fromSize (orgSize, hmap) =
        compSizes orgSize Linear.$
          getFst Linear.$
            HashMap.size (HashMap.delete key hmap)
      compSizes :: Ur Int %1 -> Ur Int %1 -> Ur Bool
      compSizes (Ur orgSize) (Ur newSize) =
        Ur ((newSize + 1) == orgSize)
  
  refInsert :: Property
  refInsert = defProperty $ do
    k <- forAll key
    v <- forAll val
    kvs <- forAll keyVals
    let listInsert = HashMap.fromList (kvs ++ [(k, v)]) HashMap.toList
    let hmInsert = HashMap.fromList kvs (HashMap.toList Linear.. HashMap.insert k v)
    sort (unur listInsert) === sort (unur hmInsert)
  
  refDelete :: Property
  refDelete = defProperty $ do
    k <- forAll key
    kvs <- forAll keyVals
    let kvs' = filter ((/= k) . fst) kvs
    let listInsert = HashMap.fromList kvs' HashMap.toList
    let hmInsert = HashMap.fromList kvs (HashMap.toList Linear.. HashMap.delete k)
    sort (unur listInsert) === sort (unur hmInsert)
  
  refLookup :: Property
  refLookup = defProperty $ do
    kvs <- forAll keyVals
    k <- forAll key
    let listLookup = List.lookup k (List.reverse kvs)
    let hmLookup = HashMap.fromList kvs (getFst Linear.. HashMap.lookup k)
    listLookup === unur hmLookup
  
  refMap :: Property
  refMap = defProperty $ do
    let f k v = if mod k 5 < 3 then Just (show k ++ v) else Nothing
    let f' (k, v) = fmap ((,) k) (f k v)
    kvs <- forAll keyVals
    let mappedList = mapMaybe f' (nubOrdOn fst (List.reverse kvs))
    let mappedHm = HashMap.fromList kvs (HashMap.toList Linear.. HashMap.mapMaybeWithKey f)
    sort mappedList === sort (unur mappedHm)
  
  refSize :: Property
  refSize = defProperty $ do
    kvs <- forAll keyVals
    length (nubOrdOn fst kvs) === unur (HashMap.fromList kvs (getFst Linear.. HashMap.size))
  
  refToListFromList :: Property
  refToListFromList = defProperty $ do
    xs <- forAll keyVals
  
    let expected =
          Map.fromList xs
            & Map.toList
  
        Ur actual = HashMap.fromList xs HashMap.toList
  
    sort expected === sort actual
  
  refFilter :: Property
  refFilter = defProperty $ do
    xs <- forAll keyVals
  
    let predicate "" = False
        predicate (i : _) = i < 'h'
  
        expected =
          Map.fromList xs
            & Map.filter predicate
            & Map.toList
  
        Ur actual =
          HashMap.fromList xs Linear.$
            HashMap.toList Linear.. HashMap.filter predicate
  
    sort expected === sort actual
  
  refMappend :: Property
  refMappend = defProperty $ do
    xs <- forAll keyVals
    ys <- forAll keyVals
  
    let Ur expected =
          HashMap.fromList (xs <> ys) Linear.$ HashMap.toList
  
        Ur actual =
          HashMap.fromList xs Linear.$ \hx ->
            HashMap.fromList ys Linear.$ \hy ->
              HashMap.toList (hx Linear.<> hy)
  
    sort expected === sort actual
  
  refUnionWith :: Property
  refUnionWith = defProperty $ do
    xs <- forAll keyVals
    ys <- forAll keyVals
  
    let combine a b = a ++ "," ++ b
  
        expected =
          Map.unionWith
            combine
            (Map.fromList xs)
            (Map.fromList ys)
            & Map.toList
  
        Ur actual =
          HashMap.fromList xs Linear.$ \hx ->
            HashMap.fromList ys Linear.$ \hy ->
              HashMap.unionWith combine hx hy
                Linear.& HashMap.toList
  
    sort expected === sort actual
  
  refIntersectionWith :: Property
  refIntersectionWith = defProperty $ do
    xs <- forAll keyVals
    ys <- forAll keyVals
  
    let expected =
          Map.intersectionWith
            (,)
            (Map.fromList xs)
            (Map.fromList ys)
            & Map.toList
  
        Ur actual =
          HashMap.fromList xs Linear.$ \hx ->
            HashMap.fromList ys Linear.$ \hy ->
              HashMap.intersectionWith (,) hx hy
                Linear.& HashMap.toList
  
    sort expected === sort actual
  
  shrinkToFitTest :: Property
  shrinkToFitTest = defProperty $ do
    kvs <- forAll keyVals
    let shrunk = (HashMap.fromList kvs (HashMap.toList Linear.. HashMap.shrinkToFit))
    sort (nubOrdOn fst (List.reverse kvs)) === sort (unur shrunk)
  