content: module Test.Stack (tests) where
  
  
  
  import Data.Foldable
  import GHC.Exts      (fromList)
  
  import Data.Stack
  
  import Test.Orphans          ()
  import Test.Tasty
  import Test.Tasty.QuickCheck as QC
  
  
  
  tests :: TestTree
  tests = testGroup "Stack" [test_popN, fromToList, test_mappend]
  
  test_popN :: TestTree
  test_popN = testGroup "forEachPop"
      [ againstReference
      , roundtrip ]
    where
      againstReference = QC.testProperty
          "Agrees with naive implementation"
          (\xs stack ->
              let _ = stack :: Stack Int
                  _ = xs :: [()]
              in xs `forEachPop` stack === xs `naive` stack )
        where
          naive :: [x] -> Stack a -> Maybe ([a], Stack a)
          naive xs stack
              | length xs > length stack = Nothing
              | otherwise =
                  let (before, rest) = splitAt (length xs) (toList stack)
                  in Just (before, fromList rest)
  
      roundtrip = QC.testProperty
          "pop-then-push"
          (\xs stack ->
              let popped = xs `forEachPop` stack
                  _ = stack :: Stack Int
                  _ = xs :: [Int]
              in case popped of
                  Just (a,b) -> a <>> b === stack
                  Nothing -> classify True "overpopped"
                      (length xs > length stack) )
  
  fromToList :: TestTree
  fromToList = testGroup "List conversion"
      [ QC.testProperty
          "toList . fromList = id"
          (\xs -> let _ = xs :: [Int]
                  in fromStack (toStack xs) === xs )
      , QC.testProperty
          "fromList . toList = id"
          (\xs -> let _ = xs :: [Int]
                  in fromStack (toStack xs) === xs )]
    where
      toStack = fromList :: [Int] -> Stack Int
      fromStack = toList :: Stack Int -> [Int]
  
  test_mappend :: TestTree
  test_mappend = QC.testProperty
      "mappend = mappend for lists"
      (\xs ys -> let _ = xs :: Stack Int
                 in xs <> ys === fromList (toList xs <> toList ys) )
  