From c1cb3aaa244b5d6eda478177ff8199b15674b3c5 Mon Sep 17 00:00:00 2001 From: slotThe Date: Sat, 12 Jun 2021 14:04:28 +0200 Subject: [PATCH 1/5] X.P.OrgMode: Only parse actual words Instead of trying to find a prefix and then killing the rest of the word, actually see whether it at least fits the pattern. This means that message +s saturated will no longer parse as a scheduled item for saturday, while message +s satur still will. --- XMonad/Prompt/OrgMode.hs | 56 +++++++++++++++++++++++++--------------- 1 file changed, 35 insertions(+), 21 deletions(-) diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs index ecc4541d..bcbf1582 100644 --- a/XMonad/Prompt/OrgMode.hs +++ b/XMonad/Prompt/OrgMode.hs @@ -71,22 +71,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, -followed by a date and a time of day. Any of the following are valid -dates: +are initiated by entering @+s@ or @+d@—separated by at least one +whitespace character on either side—into the prompt respectively, +followed a date and (optionally) a time of day. Any of the following +are valid dates: - - today - - tomorrow + - tod[ay] + - 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 -early as possible, so a simple @w@ will suffice to mean Wednesday, while -@s@ will not be enough to say Sunday. Weekdays also always schedule -into the future, e.g. if today is Monday and you schedule something for -Monday, you will actually schedule it for the /next/ Monday (the one in -seven days). +missing, filled out with the current month and year. For weekdays, we +also disambiguate as early as possible, so a simple @w@ will suffice to +mean Wednesday, while @s@ will not be enough to say Sunday. You can, +however, still write the full word without any troubles. Weekdays also +always schedule into the future, e.g. if today is Monday and you +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. @@ -357,16 +359,17 @@ pTimeOfDay = lchoice -- | Parse a 'Date'. pDate :: ReadP Date pDate = skipSpaces *> lchoice - [ Today <$ string "tod" - , Tomorrow <$ string "tom" + [ pString "tod" "ay" Today + , 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" - , Thursday <$ string "th", Friday <$ string "f" , Saturday <$ string "sa" - , Sunday <$ string "su" + [ pString "m" "onday" Monday , pString "tu" "esday" Tuesday + , pString "w" "ednesday" Wednesday, pString "th" "ursday" Thursday + , 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,13 +385,24 @@ pDate = skipSpaces *> lchoice pDate' p p' = (,,) <$> pInt <*> p (skipSpaces *> lchoice - [ 1 <$ string "ja" , 2 <$ string "f" , 3 <$ string "mar" - , 4 <$ string "ap" , 5 <$ string "may", 6 <$ string "jun" - , 7 <$ string "jul", 8 <$ string "au" , 9 <$ string "s" - , 10 <$ string "o" , 11 <$ string "n" , 12 <$ string "d" + [ pString "ja" "nuary" 1 , pString "f" "ebruary" 2 + , pString "mar" "ch" 3 , pString "ap" "ril" 4 + , pString "may" "" 5 , pString "jun" "e" 6 + , 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) +-- | 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 pInt = read <$> munch1 isDigit From 4b15ea2eccd269dfb148e735426d94aa75a2bea0 Mon Sep 17 00:00:00 2001 From: slotThe Date: Sat, 12 Jun 2021 14:07:14 +0200 Subject: [PATCH 2/5] X.P.OrgMode: Parse empty message Empty messages seem quite useless, but it's an easy fix for the parser to be able to deal with them, so do it. --- XMonad/Prompt/OrgMode.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs index bcbf1582..534d21d1 100644 --- a/XMonad/Prompt/OrgMode.hs +++ b/XMonad/Prompt/OrgMode.hs @@ -339,8 +339,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 - next <- munch1 (/= head ptn) + go :: String -> ReadP String + go consumed = do + next <- munch (/= head ptn) next' <- munch1 (/= ' ') if next' == ptn then -- If we're done, it's time to prune extra whitespace From 1c6e6c808d004a4267e24c36e28392798f96d5aa Mon Sep 17 00:00:00 2001 From: slotThe Date: Sun, 13 Jun 2021 16:52:41 +0200 Subject: [PATCH 3/5] X.P.OrgMode: Start counting years at 25 This is for disambiguation purposes. Otherwise, there is no way to decide whether message +s 17 jul 12 wants to schedule the note for the 17th of july at 12:00, or for the 17th of july in the year 12. The easiest way around this is to stipulate that people want to make these notes for the future more often than not and to simply prohibit note before the year 25 (as that is where the valid times end). --- XMonad/Prompt/OrgMode.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs index 534d21d1..f702a519 100644 --- a/XMonad/Prompt/OrgMode.hs +++ b/XMonad/Prompt/OrgMode.hs @@ -114,6 +114,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 @@ -393,7 +398,7 @@ pDate = skipSpaces *> lchoice , 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@. From dea8d9dced3223eb7dd68ea62100eb8549fc9972 Mon Sep 17 00:00:00 2001 From: slotThe Date: Sun, 13 Jun 2021 17:09:59 +0200 Subject: [PATCH 4/5] X.P.OrgMode: Appropriately pad output time The standard formatting for org is to left-pad single digits with a zero; do that. --- XMonad/Prompt/OrgMode.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs index f702a519..c159e92b 100644 --- a/XMonad/Prompt/OrgMode.hs +++ b/XMonad/Prompt/OrgMode.hs @@ -226,7 +226,10 @@ data TimeOfDay = TimeOfDay Int Int 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 From cfc793e94f6df8d3702a902833ec2ff1c2206c89 Mon Sep 17 00:00:00 2001 From: slotThe Date: Sun, 13 Jun 2021 17:44:19 +0200 Subject: [PATCH 5/5] 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