compact-sequences-0.2.0.0: test/Stack.hs

{-# language TemplateHaskell #-}
{-# language TypeApplications #-}
{-# language ScopedTypeVariables #-}
{-# language LambdaCase #-}
{-# language BangPatterns #-}
module Main (main) where

import Data.Foldable
import Test.QuickCheck
import Test.QuickCheck.Poly
import Test.Tasty
import Test.Tasty.QuickCheck

import Data.CompactSequence.Stack.Simple.Internal
import qualified Data.CompactSequence.Stack.Simple.Internal as S
import qualified Data.CompactSequence.Stack.Internal as SI
import qualified Data.CompactSequence.Internal.Array.Safe as A
import qualified Data.CompactSequence.Internal.Size as Sz
import Prelude as P

instance Arbitrary a => Arbitrary (Stack a) where
  -- Generate stacks whose size is at most on the same order
  -- of magnitude as the size parameter, with any shape.
  arbitrary = sized $ \sz0 -> do
    sz <- choose (0, sz0)
    Stack <$> go Sz.one sz
    where
      go :: Sz.Size n -> Int -> Gen (SI.Stack n a)
      go !_ars n
        | n <= 0 = pure SI.Empty
      go !ars n = choose (1,3 :: Int) >>= \case
        1 -> SI.One <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> go (Sz.twice ars) (n - Sz.getSize ars)
        2 -> SI.Two <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> go (Sz.twice ars) (n - 2 * Sz.getSize ars)
        3 -> SI.Three <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                      <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                      <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                      <*> go (Sz.twice ars) (n - 3 * Sz.getSize ars)

  -- We shrink by trimming the spine. Any other shrinks will
  -- be tricky.
  shrink (Stack stk) = [ Stack (takeSpine k stk) | k <- [0..depth stk]]
    where
      depth :: SI.Stack n a -> Int
      depth SI.Empty = 0
      depth (SI.One _ m) = 1 + depth m
      depth (SI.Two _ _ m) = 1 + depth m
      depth (SI.Three _ _ _ m) = 1 + depth m

      takeSpine :: Int -> SI.Stack n a -> SI.Stack n a
      takeSpine 0 !_ = SI.Empty
      takeSpine _ SI.Empty
        = SI.Empty
      takeSpine n (SI.One sa1 m)
        = SI.One sa1 $ takeSpine (n - 1) m
      takeSpine n (SI.Two sa1 sa2 m)
        = SI.Two sa1 sa2 $ takeSpine (n - 1) m
      takeSpine n (SI.Three sa1 sa2 sa3 m)
        = SI.Three sa1 sa2 sa3 $ takeSpine (n - 1) m


prop_identityA :: [A] -> Property
prop_identityA lst = toList (fromList lst) === lst

prop_identityB :: Stack A -> Property
prop_identityB stk = fromList (toList stk) === stk

prop_identityC :: [A] -> Property
prop_identityC lst = toList (fromListN (length lst) lst) === lst

prop_identityD :: Stack A -> Property
prop_identityD stk = fromListN (length stk) (toList stk) === stk

prop_cons :: A -> Stack A -> Property
prop_cons x xs = toList (x :< xs) === x : toList xs

prop_uncons :: Stack A -> Property
prop_uncons xs = case xs of
  Empty -> toList xs === []
  y :< ys -> toList xs === y : toList ys

prop_uncons_of_empty :: Property
prop_uncons_of_empty = uncons (Empty @(Stack A)) === Nothing

prop_uncons_of_cons :: A -> Stack A -> Property
prop_uncons_of_cons x xs = uncons (x :< xs) === Just (x, xs)

prop_append :: Stack A -> Stack A -> Property
prop_append xs ys = toList (xs <> ys) === toList xs ++ toList ys

prop_compareLength :: Int -> Stack () -> Property
prop_compareLength n s = compareLength n s === compare n (length s)

prop_take :: Int -> Stack A -> Property
prop_take n s = toList (S.take n s) === P.take n (toList s)

return [] -- This makes sure the above properties are seen by $allProperties
all_props :: TestTree
all_props = testProperties "properties" $allProperties

main :: IO ()
main = defaultMain all_props