{-# LANGUAGE ScopedTypeVariables #-}
module Main (main) where

import Data.BimapMany.Strict
import Test.Tasty
import Test.Tasty.QuickCheck as QC


instance (Ord a, Ord b, Arbitrary a, Arbitrary b, Arbitrary c) =>
         Arbitrary (BimapMany a b c) where
  arbitrary = fromList <$> arbitrary
  shrink = shrinkMap fromList toList

type BMInt = BimapMany Int Int Int

data Op = Op { unOp :: BMInt -> BMInt, showOp :: String }

instance Show Op where
  show = showOp

allOps :: [Gen Op]
allOps =
  [ (\a b c -> Op
      (insert a b c)
      ("insert " ++ show a ++ " " ++ show b ++ " " ++ show c))
    <$> arbitrary <*> arbitrary <*> arbitrary
  , (\a b -> Op
      (delete a b)
      ("delete " ++ show a ++ " " ++ show b))
    <$> arbitrary <*> arbitrary
  , (\a -> Op
      (deleteL a)
      ("deleteL " ++ show a))
    <$> arbitrary
  , (\b -> Op
      (deleteR b)
      ("deleteR " ++ show b))
    <$> arbitrary
  , (\m -> Op
      (m <>)
      ("union " ++ show m))
    <$> arbitrary
  , (\m -> Op
      (<> m)
      ("flip union " ++ show m))
    <$> arbitrary
  , pure $ Op (fromList . toList) "fromList . toList"
  , pure $ Op (fromMap . toMap) "fromMap . toMap"
  ]

instance Arbitrary Op where
  arbitrary = oneof allOps

main :: IO ()
main = defaultMain properties

properties :: TestTree
properties = testGroup "property tests"
  [ QC.testProperty "arbitrary maps are valid"
      (valid :: BMInt -> Bool)
  , QC.testProperty "insert is commutative with different keys" $
      \a b c a' b' c' (m :: BMInt) ->
        (a, b) == (a', b') ||
        insert a b c (insert a' b' c' m) == insert a' b' c' (insert a b c m)
  , QC.testProperty "delete is commutative" $
      \a b a' b' (m :: BMInt) -> delete a b (delete a' b' m) == delete a' b' (delete a b m)
  , monoidLaws
  , QC.testProperty "arbitrary operations are valid" $
      \(ops :: [Op]) m -> valid $ foldr ($) m $ unOp <$> ops
  ]

monoidLaws :: TestTree
monoidLaws = testGroup "monoid laws"
  [ QC.testProperty "right identity" $
      \(x :: BMInt) -> x <> mempty == x
  , QC.testProperty "left identity" $
      \(x :: BMInt) -> mempty <> x == x
  , QC.testProperty "associativity" $
      \(x :: BMInt) y z -> x <> (y <> z) == (x <> y) <> z
  , QC.testProperty "concatenation" $
      \(xs :: [BMInt]) -> mconcat xs == foldr (<>) mempty xs
  ]