compact-sequences-0.2.0.0: test/Queue.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.Queue.Simple.Internal
import qualified Data.CompactSequence.Queue.Simple.Internal as Q
import qualified Data.CompactSequence.Queue.Internal as QI
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 (Queue 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)
    Queue <$> go Sz.one sz
    where
      go :: Sz.Size n -> Int -> Gen (QI.Queue n a)
      go !_ars n
        | n <= 0 = pure QI.Empty
      go !ars n = do
        frontSize <- choose (1,3 :: Int)
        rearSize <- choose (0,2 :: Int)
        m <- go (Sz.twice ars) (n - (frontSize + rearSize) * Sz.getSize ars)
        QI.Node <$> pr ars frontSize <*> pure m <*> sf ars rearSize

      pr !ars = \case
        1 -> QI.FD1 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
        2 -> QI.FD2 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
        _ -> QI.FD3 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)

      sf !ars = \case
        0 -> pure QI.RD0
        1 -> QI.RD1 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
        _ -> QI.RD2 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)
                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)

  -- We shrink by trimming the spine. Any other shrinks will
  -- be tricky.
  shrink (Queue que) = [ Queue (takeSpine k que) | k <- [0..depth que]]
    where
      depth :: QI.Queue n a -> Int
      depth QI.Empty = 0
      depth (QI.Node _ m _) = 1 + depth m

      takeSpine :: Int -> QI.Queue n a -> QI.Queue n a
      takeSpine 0 !_ = QI.Empty
      takeSpine _ QI.Empty
        = QI.Empty
      takeSpine n (QI.Node pr m sf)
        = QI.Node pr (takeSpine (n - 1) m) sf

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

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

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

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

prop_identityE :: [A] -> Property
prop_identityE lst = toList (fromListNIncremental (length lst) lst) === lst

prop_snoc :: Queue A -> A -> Property
prop_snoc xs x = toList (xs |> x) === toList xs ++ [x]

prop_uncons :: Queue 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 @(Queue A)) === Nothing

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

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

prop_take :: Int -> Queue A -> Property
prop_take n s = toList (Q.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