From cfc793e94f6df8d3702a902833ec2ff1c2206c89 Mon Sep 17 00:00:00 2001
From: slotThe <soliditsallgood@mailbox.org>
Date: Sun, 13 Jun 2021 17:44:19 +0200
Subject: [PATCH] tests: Add OrgMode
Adds a pretty-printer, as well as property tests that this is in fact
an proper inverse for the parser.
---
XMonad/Prompt/OrgMode.hs | 17 ++++-
tests/Main.hs | 2 +
tests/OrgMode.hs | 157 +++++++++++++++++++++++++++++++++++++++
xmonad-contrib.cabal | 3 +
4 files changed, 178 insertions(+), 1 deletion(-)
create mode 100644 tests/OrgMode.hs
diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs
index c159e92b..8a38b0a5 100644
--- a/XMonad/Prompt/OrgMode.hs
+++ b/XMonad/Prompt/OrgMode.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -35,6 +36,16 @@ module XMonad.Prompt.OrgMode (
-- * Types
ClipboardSupport (..),
OrgMode, -- abstract
+
+#ifdef TESTING
+ pInput,
+ Note (..),
+ Date (..),
+ Time (..),
+ TimeOfDay (..),
+ DayOfWeek (..),
+#endif
+
) where
import XMonad.Prelude
@@ -220,9 +231,11 @@ data Time = Time
{ date :: Date
, tod :: Maybe TimeOfDay
}
+ deriving (Eq, Show)
-- | The time in HH:MM.
data TimeOfDay = TimeOfDay Int Int
+ deriving (Eq)
instance Show TimeOfDay where
show :: TimeOfDay -> String
@@ -241,6 +254,7 @@ data Date
-- following Monday)
| Date (Int, Maybe Int, Maybe Integer)
-- ^ Manual date entry in the format DD [MM] [YYYY]
+ deriving (Eq, Ord, Show)
toOrgFmt :: Maybe TimeOfDay -> Day -> String
toOrgFmt tod day =
@@ -282,7 +296,7 @@ dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3
data DayOfWeek
= Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
- deriving (Show, Eq)
+ deriving (Eq, Ord, Show)
-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless
-- sequence. Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday],
@@ -316,6 +330,7 @@ data Note
= Scheduled String Time
| Deadline String Time
| NormalMsg String
+ deriving (Eq, Show)
-- | Pretty print a given 'Note'.
ppNote :: Clp -> String -> Note -> IO String
diff --git a/tests/Main.hs b/tests/Main.hs
index 54c8a340..b080bdb2 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -11,6 +11,7 @@ import qualified Selective
import qualified SwapWorkspaces
import qualified XPrompt
import qualified CycleRecentWS
+import qualified OrgMode
main :: IO ()
main = hspec $ do
@@ -47,3 +48,4 @@ main = hspec $ do
context "NoBorders" NoBorders.spec
context "ExtensibleConf" ExtensibleConf.spec
context "CycleRecentWS" CycleRecentWS.spec
+ context "OrgMode" OrgMode.spec
diff --git a/tests/OrgMode.hs b/tests/OrgMode.hs
new file mode 100644
index 00000000..0b8d3a40
--- /dev/null
+++ b/tests/OrgMode.hs
@@ -0,0 +1,157 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
+module OrgMode where
+
+import XMonad.Prelude hiding ((!?))
+import XMonad.Prompt.OrgMode
+
+import qualified Data.Map.Strict as Map
+
+import Data.Map.Strict (Map, (!), (!?))
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+
+
+spec :: Spec
+spec = do
+ prop "prop_encodeLinearity" prop_encodeLinearity
+ prop "prop_decodeLinearity" prop_decodeLinearity
+
+-- | Printing omits no information from output.
+prop_encodeLinearity :: OrgMsg -> Bool
+prop_encodeLinearity (OrgMsg s) = Just s == (ppNote <$> pInput s)
+
+-- | Parsing discards no information from input.
+prop_decodeLinearity :: Note -> Bool
+prop_decodeLinearity n = Just n == pInput (ppNote n)
+
+------------------------------------------------------------------------
+-- Pretty Printing
+
+ppNote :: Note -> String
+ppNote = \case
+ Scheduled str t -> str <> " +s " <> ppTime t
+ Deadline str t -> str <> " +d " <> ppTime t
+ NormalMsg str -> str
+
+ppTime :: Time -> String
+ppTime (Time d t) = ppDate d <> ppTOD t
+ where
+ ppTOD :: Maybe TimeOfDay -> String
+ ppTOD = maybe "" ((' ' :) . show)
+
+ ppDate :: Date -> String
+ ppDate dte = case days !? dte of
+ Just v -> v
+ Nothing -> case d of -- only way it can't be in the map
+ Date (d', mbM, mbY) -> show d'
+ <> maybe "" ((' ' :) . (months !)) mbM
+ <> maybe "" ((' ' :) . show) mbY
+
+------------------------------------------------------------------------
+-- Arbitrary Instances
+
+-- | An arbitrary (correct) message string.
+newtype OrgMsg = OrgMsg String
+ deriving (Show)
+
+instance Arbitrary OrgMsg where
+ arbitrary :: Gen OrgMsg
+ arbitrary = OrgMsg <$>
+ randomString <<>> elements [" +s ", " +d ", ""] <<>> dateGen <<>> hourGen
+ where
+ dateGen :: Gen String
+ dateGen = oneof
+ [ pure $ days ! Today
+ , pure $ days ! Tomorrow
+ , elements $ (days !) . Next <$> [Monday .. Sunday]
+ , rNat
+ , unwords <$> sequenceA [rNat, monthGen]
+ , unwords <$> sequenceA [rNat, monthGen, show <$> posInt `suchThat` (> 25)]
+ ]
+ where
+ rNat :: Gen String
+ rNat = show <$> posInt
+
+ monthGen :: Gen String
+ monthGen = elements $ Map.elems months
+
+ hourGen :: Gen String
+ hourGen = oneof
+ [ pure " " <<>> (pad <$> hourInt) <<>> pure ":" <<>> (pad <$> minuteInt)
+ , pure ""
+ ]
+ where
+ pad :: Int -> String
+ pad n = (if n <= 9 then "0" else "") <> show n
+
+instance Arbitrary Note where
+ arbitrary :: Gen Note
+ arbitrary = do
+ msg <- randomString
+ t <- arbitrary
+ elements [Scheduled msg t, Deadline msg t, NormalMsg msg]
+
+instance Arbitrary Time where
+ arbitrary :: Gen Time
+ arbitrary = Time <$> arbitrary <*> arbitrary
+
+instance Arbitrary Date where
+ arbitrary :: Gen Date
+ arbitrary = oneof
+ [ pure Today
+ , pure Tomorrow
+ , Next . toEnum <$> choose (0, 6)
+ , do d <- posInt
+ m <- mbPos `suchThat` (<= Just 12)
+ Date . (d, m, ) <$> if isNothing m
+ then pure Nothing
+ else mbPos `suchThat` (>= Just 25)
+ ]
+
+instance Arbitrary TimeOfDay where
+ arbitrary :: Gen TimeOfDay
+ arbitrary = TimeOfDay <$> hourInt <*> minuteInt
+
+------------------------------------------------------------------------
+-- Util
+
+randomString :: Gen String
+randomString = listOf arbitraryPrintableChar <<>> (noSpace <&> (: []))
+ where
+ noSpace :: Gen Char
+ noSpace = arbitraryPrintableChar `suchThat` (/= ' ')
+
+days :: Map Date String
+days = Map.fromList
+ [ (Today, "tod"), (Tomorrow, "tom"), (Next Monday, "m"), (Next Tuesday, "tu")
+ , (Next Wednesday, "w"), (Next Thursday, "th"), (Next Friday, "f")
+ , (Next Saturday,"sa"), (Next Sunday,"su")
+ ]
+
+months :: Map Int String
+months = Map.fromList
+ [ (1, "ja"), (2, "f"), (3, "mar"), (4, "ap"), (5, "may"), (6, "jun")
+ , (7, "jul"), (8, "au"), (9, "s"), (10, "o"), (11, "n"), (12, "d")
+ ]
+
+posInt :: Gen Int
+posInt = getPositive <$> arbitrary @(Positive Int)
+
+hourInt :: Gen Int
+hourInt = posInt `suchThat` (<= 23)
+
+minuteInt :: Gen Int
+minuteInt = posInt `suchThat` (<= 59)
+
+mbPos :: Num a => Gen (Maybe a)
+mbPos = fmap (fromIntegral . getPositive) <$> arbitrary @(Maybe (Positive Int))
+
+infixr 6 <<>>
+(<<>>) :: (Applicative f, Monoid a) => f a -> f a -> f a
+(<<>>) = liftA2 (<>)
diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal
index 7af73601..adffdfe7 100644
--- a/xmonad-contrib.cabal
+++ b/xmonad-contrib.cabal
@@ -378,6 +378,7 @@ test-suite tests
Instances
ManageDocks
NoBorders
+ OrgMode
RotateSome
Selective
SwapWorkspaces
@@ -397,6 +398,7 @@ test-suite tests
XMonad.Layout.NoBorders
XMonad.Prelude
XMonad.Prompt
+ XMonad.Prompt.OrgMode
XMonad.Prompt.Shell
XMonad.Util.ExtensibleConf
XMonad.Util.ExtensibleState
@@ -418,6 +420,7 @@ test-suite tests
, X11 >= 1.10 && < 1.11
, containers
, directory
+ , time >= 1.8 && < 1.12
, hspec >= 2.4.0 && < 3
, mtl
, process