From c5745b62996c18f322aad1264bada27b58eab587 Mon Sep 17 00:00:00 2001
From: ivanbrennan <ivan.brennan@gmail.com>
Date: Fri, 18 Sep 2020 11:20:50 -0400
Subject: [PATCH] add RotateSome property tests

Verify that rotateSome behaves as expected and never fails to pattern
match.

In order to run these tests, I ran a custom script:

  scripts/run-tests.sh tests/RotateSome.hs

where the script contained the following:

  set -eu

  toplevel=$(git rev-parse --show-toplevel)
  XMONAD="${XMONAD:-$toplevel/../xmonad}"
  main=$(realpath -e "$1")

  instances_target="$XMONAD/tests/Instances.hs"
  instances_symlink="$toplevel/tests/Instances.hs"

  properties_target="$XMONAD/tests/Properties"
  properties_symlink="$toplevel/tests/Properties"

  utils_target="$XMONAD/tests/Utils.hs"
  utils_symlink="$toplevel/tests/Utils.hs"

  trap "
      rm '$instances_symlink' '$utils_symlink' '$properties_symlink' || true
  " EXIT INT QUIT TERM

  ln -s "$instances_target" "$instances_symlink"
  ln -s "$properties_target" "$properties_symlink"
  ln -s "$utils_target" "$utils_symlink"

  runghc -DTESTING \
      -i"$toplevel" \
      -i"$toplevel/tests" \
      "$main"
---
 tests/RotateSome.hs | 75 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 75 insertions(+)
 create mode 100644 tests/RotateSome.hs

diff --git a/tests/RotateSome.hs b/tests/RotateSome.hs
new file mode 100644
index 00000000..6ca3b9bb
--- /dev/null
+++ b/tests/RotateSome.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module RotateSome where
+
+import Test.QuickCheck (Arbitrary, Gen, arbitrary, choose, listOf, quickCheck)
+import Utils (applyN)
+import XMonad.StackSet (Stack (Stack), down, focus, integrate, up)
+import XMonad.Actions.RotateSome (rotateSome)
+
+instance Arbitrary (Stack Int) where
+  arbitrary = do
+    foc   <- arbNat
+    ups   <- listOf arbNat
+    downs <- listOf arbNat
+    pure (Stack foc ups downs)
+
+arbNat :: Gen Int
+arbNat = fmap abs arbitrary
+
+newtype Divisor = Divisor Int deriving Show
+instance Arbitrary Divisor where
+  arbitrary = Divisor <$> choose (1, 5)
+
+isMultOf :: Int -> Int -> Bool
+x `isMultOf` n = (x `rem` n) == 0
+
+-- Total number of elements does not change.
+prop_rotate_some_length (Divisor d) (stk :: Stack Int) =
+  length (integrate stk) == length (integrate $ rotateSome (`isMultOf` d) stk)
+
+-- Applying rotateSome N times completes a cycle, where N is the number of
+-- elements that satisfy the predicate.
+prop_rotate_some_cycle (Divisor d) (stk :: Stack Int) =
+  stk == applyN (Just n) (rotateSome (`isMultOf` d)) stk
+  where
+    n = length $ filter (`isMultOf` d) (integrate stk)
+
+-- Elements that do not satisfy the predicate remain anchored in place.
+prop_rotate_some_anchors (Divisor d) (stk :: Stack Int) =
+  all check $
+    zip
+      (integrate stk)
+      (integrate $ rotateSome (`isMultOf` d) stk)
+  where
+    check (before, after) = (before `isMultOf` d) || before == after
+
+-- Elements that satisfy the predicate rotate by one position.
+prop_rotate_some_rotate (Divisor d) (stk :: Stack Int) =
+  drop 1 before ++ take 1 before == after
+  where
+    before = filter p (integrate stk)
+    after = filter p (integrate $ rotateSome p stk)
+    p = (`isMultOf` d)
+
+-- Focus position is preserved.
+prop_rotate_some_focus (Divisor d) (stk :: Stack Int) =
+  length (up stk) == length (up $ rotateSome (`isMultOf` d) stk)
+
+main :: IO ()
+main = do
+  putStrLn "Testing rotateSome length"
+  quickCheck prop_rotate_some_length
+
+  putStrLn "Testing rotateSome cycle"
+  quickCheck prop_rotate_some_cycle
+
+  putStrLn "Testing rotateSome anchors"
+  quickCheck prop_rotate_some_anchors
+
+  putStrLn "Testing rotateSome rotate"
+  quickCheck prop_rotate_some_rotate
+
+  putStrLn "Testing rotateSome focus"
+  quickCheck prop_rotate_some_focus