content: {-# LANGUAGE ScopedTypeVariables #-}
  module Main (main) where
  
  import Data.Complex (Complex)
  import Data.Int (Int8, Int16, Int32, Int64)
  import Data.List.NonEmpty (NonEmpty)
  import Data.Proxy (Proxy (..))
  import Data.Typeable (Typeable, typeRep)
  import Data.Word (Word8, Word16, Word32, Word64)
  import Numeric.Natural (Natural)
  import Test.QuickCheck (Arbitrary (..), Property, counterexample, label, (===),
                          sized, chooseInt, vectorOf)
  import Test.QuickCheck.Instances ()
  import Test.Tasty (defaultMain, testGroup, TestTree)
  import Test.Tasty.QuickCheck (testProperty)
  
  import qualified Data.List as L
  
  import Data.Discrimination
  import Utils
  
  main :: IO ()
  main = defaultMain $ testGroup "discrimination"
    [ testGroup "examples"
      [ testGroup "nub"
        [ testProperty "List.nub" $
          let prop :: [Word64] -> Property
              prop xs = L.nub xs === nub xs
          in prop
  
        , testProperty "ordNub" $
          let prop :: [Word64] -> Property
              prop xs = ordNub xs === nub xs
          in prop
  
        , testProperty "hashNub" $
          let prop :: [Word64] -> Property
              prop xs = hashNub xs === nub xs
          in prop
        ]
  
      , testGroup "sort"
        [ testProperty "List.sort" $
          let prop :: [Word64] -> Property
              prop xs = L.sort xs === sort xs
          in prop
  
        , testProperty "introsort" $
          -- for Word64 unstable sort works too
          let prop :: [Word64] -> Property
              prop xs = introsort xs === sort xs
          in prop
  
        , testProperty "mergesort" $
          let prop :: [Word64] -> Property
              prop xs = mergesort xs === sort xs
          in prop
        ]
      ]
  
    , testGroup "Grouping"
      [ testGrouping (Proxy :: Proxy ())
      , testGrouping (Proxy :: Proxy Int)
      , testGrouping (Proxy :: Proxy Int8)
      , testGrouping (Proxy :: Proxy Int16)
      , testGrouping (Proxy :: Proxy Int32)
      , testGrouping (Proxy :: Proxy Int64)
      , testGrouping (Proxy :: Proxy Word)
      , testGrouping (Proxy :: Proxy Word8)
      , testGrouping (Proxy :: Proxy Word16)
      , testGrouping (Proxy :: Proxy Word32)
      , testGrouping (Proxy :: Proxy Word64)
      , testGrouping (Proxy :: Proxy Bool)
      , testGrouping (Proxy :: Proxy Ordering)
      , testGrouping (Proxy :: Proxy (Word8,Word8))
      , testGrouping (Proxy :: Proxy (Word8,Word8,Word8))
      , testGrouping (Proxy :: Proxy (Word8,Word8,Word8,Word8))
      , testGrouping (Proxy :: Proxy Rational)
      , testGrouping (Proxy :: Proxy (Complex Word8))
      , testGrouping (Proxy :: Proxy (Maybe Word8))
      , testGrouping (Proxy :: Proxy (Either Word8 Word8))
      , testGrouping (Proxy :: Proxy Char)
      , testGrouping (Proxy :: Proxy String)
      , testGrouping (Proxy :: Proxy (NonEmpty Int))
      , testGrouping (Proxy :: Proxy Natural)
      , testGrouping (Proxy :: Proxy Integer)
  
      , testGrouping' listToNatural
      , testGrouping' listToInteger
      ]
  
    , testGroup "Sorting"
      [ testSorting (Proxy :: Proxy ())
      , testSorting (Proxy :: Proxy Int)
      , testSorting (Proxy :: Proxy Int8)
      , testSorting (Proxy :: Proxy Int16)
      , testSorting (Proxy :: Proxy Int32)
      , testSorting (Proxy :: Proxy Int64)
      , testSorting (Proxy :: Proxy Word)
      , testSorting (Proxy :: Proxy Word8)
      , testSorting (Proxy :: Proxy Word16)
      , testSorting (Proxy :: Proxy Word32)
      , testSorting (Proxy :: Proxy Word64)
      , testSorting (Proxy :: Proxy Bool)
      , testSorting (Proxy :: Proxy Ordering)
      , testSorting (Proxy :: Proxy (Word8,Word8))
      , testSorting (Proxy :: Proxy (Word8,Word8,Word8))
      , testSorting (Proxy :: Proxy (Word8,Word8,Word8,Word8))
      , testSorting (Proxy :: Proxy (Maybe Word8))
      , testSorting (Proxy :: Proxy (Either Word8 Word8))
      , testSorting (Proxy :: Proxy Char)
      , testSorting (Proxy :: Proxy String)
      , testSorting (Proxy :: Proxy (NonEmpty Int))
      , testSorting (Proxy :: Proxy Natural)
      , testSorting (Proxy :: Proxy Integer)
  
      , testSorting' listToNatural
      , testSorting' listToInteger
      ]
    ]
  
  listToNatural :: SmallList Word64 -> Natural
  listToNatural = L.foldl' (\x y -> x * 2 ^ (64 :: Int) + fromIntegral y) 0 . getSmallList
  
  listToInteger :: SmallList Int64 -> Integer
  listToInteger = L.foldl' (\x y -> x * 2 ^ (64 :: Int) + fromIntegral y) 0 . getSmallList
  
  newtype SmallList a = SmallList { getSmallList :: [a] } deriving (Eq, Show)
  
  instance Arbitrary a => Arbitrary (SmallList a) where
      arbitrary = sized $ \n -> do
          m <- chooseInt (0, min 10 n)
          SmallList <$> vectorOf m arbitrary
  
      shrink = fmap SmallList . shrink . getSmallList
  
  testGrouping
    :: forall a. (Grouping a, Typeable a, Arbitrary a, Eq a, Show a)
    => Proxy a
    -> TestTree
  testGrouping _ = testGrouping' (id :: a -> a)
  
  testGrouping'
    :: forall a b. (Grouping b, Typeable a, Typeable b, Arbitrary a, Eq b, Show a, Show b)
    => (a -> b)
    -> TestTree
  testGrouping' f = testGroup name
      [ testProperty "groupingEq" prop_eq
      , testProperty "nub"        prop_nub
      ]
    where
      tra = typeRep (Proxy :: Proxy a)
      trb = typeRep (Proxy :: Proxy b)
      name = if tra == trb then show tra else show trb ++ " from " ++ show tra
  
      prop_eq :: a -> a -> Property
      prop_eq x' y' =
          counterexample (show (x,y)) $
          label (show lhs) $
          lhs === groupingEq x y
        where
          x = f x'
          y = f y'
          lhs = x == y
  
      prop_nub :: [a] -> Property
      prop_nub xs' = L.nub xs === nub xs
        where
          xs = take 100 (map f xs')
  
  testSorting
    :: forall a. (Sorting a, Typeable a, Arbitrary a, Ord a, Show a)
    => Proxy a
    -> TestTree
  testSorting _ = testSorting' (id :: a -> a)
  
  testSorting'
    :: forall a b. (Sorting b, Typeable a, Typeable b, Arbitrary a, Ord b, Show a, Show b)
    => (a -> b)
    -> TestTree
  testSorting' f = testGroup name
      [ testProperty "sortingCompare" prop_cmp
      , testProperty "sort"           prop_sort
      ]
    where
      tra = typeRep (Proxy :: Proxy a)
      trb = typeRep (Proxy :: Proxy b)
      name = if tra == trb then show tra else show trb ++ " from " ++ show tra
  
      prop_cmp :: a -> a -> Property
      prop_cmp x' y' =
          counterexample (show (x,y)) $
          label (show lhs) $
          lhs === sortingCompare x y
        where
          x = f x'
          y = f y'
          lhs = compare x y
  
      prop_sort :: [a] -> Property
      prop_sort xs' = L.sort xs === sort xs
        where
          xs = map f xs'
  