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

@@ -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

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

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 (<>)

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