Merge pull request #559 from slotThe/OrgMode-tests

X.P.OrgMode: Add property tests

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
@@ -71,22 +82,24 @@ above you can write
 > , ("M-C-o", orgPrompt def "TODO" "org/todos.org")
 
 There is also some scheduling and deadline functionality present.  They
-are initiated by entering @+s@ or @+d@ into the prompt respectively,
+are initiated by entering @+s@ or @+d@—separated by at least one
-followed by a date and a time of day.  Any of the following are valid
+whitespace character on either side—into the prompt respectively,
-dates:
+followed a date and (optionally) a time of day.  Any of the following
+are valid dates:
 
-  - today
+  - tod[ay]
-  - tomorrow
+  - tom[orrow]
   - /any weekday/
   - /any date of the form DD MM YYYY/
 
 In the last case, the month and the year are optional and will be, if
-missing, filled out with the current month and year.  We disambiguate as
+missing, filled out with the current month and year.  For weekdays, we
-early as possible, so a simple @w@ will suffice to mean Wednesday, while
+also disambiguate as early as possible, so a simple @w@ will suffice to
-@s@ will not be enough to say Sunday.  Weekdays also always schedule
+mean Wednesday, while @s@ will not be enough to say Sunday.  You can,
-into the future, e.g. if today is Monday and you schedule something for
+however, still write the full word without any troubles.  Weekdays also
-Monday, you will actually schedule it for the /next/ Monday (the one in
+always schedule into the future, e.g. if today is Monday and you
-seven days).
+schedule something for Monday, you will actually schedule it for the
+/next/ Monday (the one in seven days).
 
 The time is specified in the @HH:MM@ format.  The minutes may be
 omitted, in which case @00@ will be substituted.
@@ -112,6 +125,11 @@ above, pressed it, and are now confronted with a prompt:
   - @hello +s 11 jan 2013@ would schedule the note for the 11th of
     January 2013.
 
+Note that, due to ambiguity issues, years below @25@ result in undefined
+parsing behaviour.  Otherwise, what should @message +s 11 jan 13@
+resolve to—the 11th of january at 13:00 or the 11th of january in the
+year 13?
+
 There's also the possibility to take what's currently in the primary
 selection and paste that as the content of the created note.  This is
 especially useful when you want to quickly save a URL for later and
@@ -213,13 +231,18 @@ 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
-  show (TimeOfDay h m) = show h <> ":" <> show m <> if m <= 9 then "0" else ""
+  show (TimeOfDay h m) = pad h <> ":" <> pad m
+   where
+    pad :: Int -> String
+    pad n = (if n <= 9 then "0" else "") <> show n
 
 -- | Type for specifying exactly which day one wants.
 data Date
@@ -231,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 =
@@ -272,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],
@@ -306,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
@@ -337,8 +362,9 @@ pInput inp = fmap fst . listToMaybe . (`readP_to_S` inp) . lchoice $
   getLast :: String -> ReadP String
   getLast ptn = go ""
    where
-    go :: String -> ReadP String = \consumed -> do
+    go :: String -> ReadP String
-      next  <- munch1 (/= head ptn)
+    go consumed = do
+      next  <- munch (/= head ptn)
       next' <- munch1 (/= ' ')
       if next' == ptn
         then -- If we're done, it's time to prune extra whitespace
@@ -357,16 +383,17 @@ pTimeOfDay = lchoice
 -- | Parse a 'Date'.
 pDate :: ReadP Date
 pDate = skipSpaces *> lchoice
-  [ Today    <$  string "tod"
+  [ pString "tod" "ay"    Today
-  , Tomorrow <$  string "tom"
+  , pString "tom" "orrow" Tomorrow
   , Next     <$> pNext
   , Date     <$> pDate1 <++ pDate2 <++ pDate3
-  ] <* munch (/= ' ') <* skipSpaces  -- cleanup
+  ] <* skipSpaces  -- cleanup
  where
   pNext :: ReadP DayOfWeek = lchoice
-    [ Monday   <$ string "m" , Tuesday <$ string "tu", Wednesday <$ string "w"
+    [ pString "m"  "onday"    Monday   , pString "tu" "esday"  Tuesday
-    , Thursday <$ string "th", Friday  <$ string "f" , Saturday  <$ string "sa"
+    , pString "w"  "ednesday" Wednesday, pString "th" "ursday" Thursday
-    , Sunday   <$ string "su"
+    , pString "f"  "riday"    Friday   , pString "sa" "turday" Saturday
+    , pString "su" "nday"     Sunday
     ]
 
   -- XXX: This is really horrible, but I can't see a way to not have
@@ -382,12 +409,23 @@ pDate = skipSpaces *> lchoice
   pDate' p p' =
     (,,) <$> pInt
          <*> p (skipSpaces *> lchoice
-               [ 1  <$ string "ja" , 2  <$ string "f"  , 3  <$ string "mar"
+               [ pString "ja"  "nuary"    1 , pString "f"   "ebruary" 2
-               , 4  <$ string "ap" , 5  <$ string "may", 6  <$ string "jun"
+               , pString "mar" "ch"       3 , pString "ap"  "ril"     4
-               , 7  <$ string "jul", 8  <$ string "au" , 9  <$ string "s"
+               , pString "may" ""         5 , pString "jun" "e"       6
-               , 10 <$ string "o"  , 11 <$ string "n"  , 12 <$ string "d"
+               , pString "jul" "y"        7 , pString "au"  "gust"    8
+               , pString "s"   "eptember" 9 , pString "o"   "ctober"  10
+               , pString "n"   "ovember"  11, pString "d"   "ecember" 12
                ])
-         <*> p' (skipSpaces *> pInt)
+         <*> p' (skipSpaces *> pInt >>= \i -> guard (i >= 25) $> i)
+
+-- | Parse a @start@ and see whether the rest of the word (separated by
+-- spaces) fits the @leftover@.
+pString :: String -> String -> a -> ReadP a
+pString start leftover ret = do
+  void $ string start
+  l <- munch (/= ' ')
+  guard (l `isPrefixOf` leftover)
+  pure ret
 
 -- | Parse a number.
 pInt :: (Read a, Integral a) => ReadP a

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