From 153d46fd9042008210353d41645e84d2bf30d566 Mon Sep 17 00:00:00 2001
From: slotThe <soliditsallgood@mailbox.org>
Date: Sat, 5 Feb 2022 10:40:58 +0100
Subject: [PATCH] tests: Add property tests for X.U.EZConfig
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Adds property tests in both directions for the parser in X.U.EZConfig.
As with the tests for X.P.OrgMode, these (modulo `Maybe` noise) take the
shape of the operation of an inverse semigroup:

    pp ∘ p ∘ pp ≡ pp        and        p ∘ pp ∘ p = p,

where pp is pretty-printing and p is parsing.
---
 tests/EZConfig.hs | 71 +++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 63 insertions(+), 8 deletions(-)

diff --git a/tests/EZConfig.hs b/tests/EZConfig.hs
index 5b677b50..ac81a48f 100644
--- a/tests/EZConfig.hs
+++ b/tests/EZConfig.hs
@@ -1,7 +1,16 @@
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs               #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE ViewPatterns               #-}
 module EZConfig (spec) where
 
-import Control.Arrow (first)
+import Control.Arrow (first, (>>>))
+import Data.Coerce
+import Foreign.C.Types (CUInt(..))
 import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
 import XMonad
 import XMonad.Prelude
 import XMonad.Util.EZConfig
@@ -9,10 +18,13 @@ import XMonad.Util.Parser
 
 spec :: Spec
 spec = do
+  prop "prop_decodePreservation" prop_decodePreservation
+  prop "prop_encodePreservation" prop_encodePreservation
+
   context "parseKey" $ do
     let prepare = unzip . map (first surround)
         testParseKey (ns, ks) = traverse (runParser parseKey) ns `shouldBe` Just ks
-    it "parses all regular keys"    $ testParseKey          regularKeys
+    it "parses all regular keys"    $ testParseKey (unzip   regularKeys   )
     it "parses all function keys"   $ testParseKey (prepare functionKeys  )
     it "parses all special keys"    $ testParseKey (prepare specialKeys   )
     it "parses all multimedia keys" $ testParseKey (prepare multimediaKeys)
@@ -30,15 +42,58 @@ spec = do
     it "Fails on the non-existent key M-10" $
       readKeySequence def "M-10" `shouldBe` Nothing
 
-regularKeys :: ([String], [KeySym])
-regularKeys = unzip . map (first (: ""))
-            $ zip ['!'    .. '~'   ] [xK_exclam       .. xK_asciitilde]
-           ++ zip ['\xa0' .. '\xff'] [xK_nobreakspace .. xK_ydiaeresis]
+-- | Parsing preserves all info that printing does.
+prop_encodePreservation :: KeyString -> Property
+prop_encodePreservation (coerce -> s) = parse s === (parse . pp =<< parse s)
+ where parse = runParser (parseKeySequence def)
+       pp    = unwords . map keyToString
+
+-- | Printing preserves all info that parsing does.
+prop_decodePreservation :: NonEmptyList (AKeyMask, AKeySym) -> Property
+prop_decodePreservation (getNonEmpty >>> coerce -> xs) =
+  Just (pp xs) === (fmap pp . parse $ pp xs)
+ where parse = runParser (parseKeySequence def)
+       pp    = unwords . map keyToString
 
 -- | QuickCheck can handle the 8! combinations just fine.
 modifiers :: [String]
-modifiers = map concat $
-  permutations ["M-", "C-", "S-", "M1-", "M2-", "M3-", "M4-", "M5-"]
+modifiers = map concat $ permutations mods
+
+mods :: [String]
+mods = ["M-", "C-", "S-", "M1-", "M2-", "M3-", "M4-", "M5-"]
 
 surround :: String -> String
 surround s = "<" <> s <> ">"
+
+-----------------------------------------------------------------------
+-- Newtypes and Arbitrary instances
+
+newtype AKeyMask = AKeyMask KeyMask
+  deriving newtype (Show)
+
+instance Arbitrary AKeyMask where
+  arbitrary :: Gen AKeyMask
+  arbitrary = fmap (coerce . sum . nub) . listOf . elements $
+    [noModMask, shiftMask, controlMask, mod1Mask, mod2Mask, mod3Mask, mod4Mask, mod5Mask]
+
+newtype AKeySym = AKeySym KeySym
+  deriving newtype (Show)
+
+instance Arbitrary AKeySym where
+  arbitrary :: Gen AKeySym
+  arbitrary = elements . coerce . map snd $ regularKeys <> allSpecialKeys
+
+newtype KeyString = KeyString String
+  deriving newtype (Show)
+
+instance Arbitrary KeyString where
+  arbitrary :: Gen KeyString
+  arbitrary = coerce . unwords <$> listOf keybinding
+   where
+    keybinding :: Gen String
+    keybinding = do
+      let keyStr = map fst $ regularKeys <> allSpecialKeys
+      mks <- nub <$> listOf (elements ("" : mods))
+      k   <- elements keyStr
+      ks  <- listOf . elements $ keyStr
+      pure $ concat mks <> k <> " " <> unwords ks