xnobar-1.0.0.2: test/Main.hs

module Main where

import Control.Monad (unless, join, replicateM)
import Data.List (nubBy)
import Data.Function (on, (&))
import Data.Word (Word32)
import System.Exit (exitFailure)
import Test.QuickCheck

import XNobar.Internal.Notification
import XNobar.Internal.Positive32
import XNobar.Internal.Scroller
import Data.Maybe (isNothing, isJust, fromJust)
import Data.Tuple.Extra (snd3)
import Data.Semigroup (Max(..))

main :: IO ()
main = do

  result <- mapM quickCheckResult [
      tAppendExisting
    , tAppendNew
    ]

  unless (all isSuccess result) exitFailure

  result <- quickCheckResult tRemove
  unless (isSuccess result) exitFailure

  result <- quickCheckResult tRemoveCurrent
  unless (isSuccess result) exitFailure

  result <- quickCheckResult tCombine
  unless (isSuccess result) exitFailure

  result <- mapM quickCheckResult [
      tScrollPeriod
    , tExactScrolls
    ]
  unless (all isSuccess result) exitFailure

instance Arbitrary Positive32 where
  arbitrary = positive32 <$> elements [1..10]

tAppendExisting :: Word32 -> [(Id, ())] -> Bool
tAppendExisting _ [] = True
tAppendExisting i ns
  | i > 100 = True
  | otherwise = let ns'nodups = nubBy ((==) `on` theId) ns
                    n = cycle ns'nodups !! read (show i)
                    ns' = ns'nodups `append` n
                in theId (last ns') == theId n
                && length ns'nodups == length ns'

tAppendNew :: Word32 -> [(Id, ())] -> Bool
tAppendNew _ [] = True
tAppendNew i ns
  | i > 100 = True
  | otherwise = let (n:ns'nodups) = nubBy ((==) `on` theId) ns
                    ns' = ns'nodups `append` n
                in theId (last ns') == theId n
                && length ns'nodups + 1 == length ns'

instance {-# Overlapping #-} (Foldable f, Num o, Enum o, Arbitrary (f c), Arbitrary o)
                          => Arbitrary (Maybe (Id, o, [(Id, f c)])) where
  arbitrary = do
    size <- elements [1..9]
    indexedNotifs <- zip <$> shuffle (map makeId [1..(fromIntegral size)])
                         <*> replicateM size arbitrary
    (currId, notif) <- elements indexedNotifs
    currOffset <- elements $ take (length notif) [0..]
    elements [Nothing,
              Just (currId, currOffset, indexedNotifs)]

tRemove ::  (Id, Maybe (Id, Int, [(Id, String)])) -> Bool
tRemove = uncurry removeImpl

-- TODO: fix this test
removeImpl ::  Id -> Maybe (Id, Int, [(Id, String)]) -> Bool
removeImpl _ Nothing = True
removeImpl _ (Just (_, _, [])) = error "This should not happen"
removeImpl i p@(Just (_, _, [(i', _)])) = (i /= i') || null (remove i p)
removeImpl i p@(Just (i', _, l))
  | i == i' = tRemoveCurrent p
  | otherwise = case remove i p of
                  Nothing -> error "This should not happen"
                  Just (_, _, l') -> length l' == length l - 1

-- TODO: String seems unnecessary
tRemoveCurrent :: Maybe (Id, Int, [(Id, String)]) -> Bool
tRemoveCurrent Nothing = True
tRemoveCurrent (Just (_, _, [])) = error "This should not happen"
tRemoveCurrent ns@(Just (curr, o, _)) = case remove curr ns of
                                          Nothing -> True
                                          Just (curr', _, _) -> curr' /= curr

instance {-# Overlapping #-} Arbitrary [Id] where
  arbitrary = do
    size <- elements [1..10]
    shuffle $ map makeId [1..size]

tCombine :: [Id] -> [Id] -> Bool
tCombine olds news = let olds' = map (, "old") olds
                         news' = map (, "new") news
                         new'news = olds' `combine` news'
                         renewed = filter (`elem` news) olds
                         older = filter (`notElem` news) olds
                     in all (`elem` new'news) news'
                     && all ((`elem` new'news) . (, "new")) renewed
                     && all ((`elem` new'news) . (, "old")) older

instance {-# Overlapping #-} Arbitrary String where
  arbitrary = do
    size <- elements [1..10]
    return $ take size $ cycle $ concatMap show [0..9]

tScrollPeriod :: Maybe (Id, Int, [(Id, String)]) -> Bool
tScrollPeriod Nothing = True
tScrollPeriod ns@(Just (_, _, is)) = let totLen = sum $ map (length . show . snd) is
                                     in ns == applyN totLen scroll ns

instance {-# Overlapping #-} Show String where
  show = id -- This is because `scroll` uses `show` on the notification,
            -- and if I'm using a `String` here for simplicity, that would
            -- result in wrapping the string within `"`, which alters their
            -- length.

tExactScrolls :: Maybe (Id, Int, [(Id, String)]) -> Bool
tExactScrolls Nothing = True
tExactScrolls (Just (i, _, indexedNotifs))
  = let ns = Just (i, 0, indexedNotifs)
        beforeCurr = takeWhile ((/= i) . theId) indexedNotifs
        lengths = rotate (length beforeCurr) indexedNotifs
                & map (length . snd)
        scrolledNotifs = map (iterate scroll ns !!) (sums lengths)
    in all ((== 0) . snd3 . fromJust) scrolledNotifs

applyN :: Int -> (a -> a) -> a -> a
applyN n = ((!! n) .) . iterate

sums = scanl (+) 0

rotate n l = take (length l) $ drop n $ cycle l