Merge pull request #747 from slotThe/org-mode/priorities

X.P.OrgMode: Add ability to specify priorities

CHANGES.md

@@ -106,8 +106,11 @@
 
   * `XMonad.Prompt.OrgMode`
 
-    - Fixes the date parsing issue such that entries with format of
+    - Fixed the date parsing issue such that entries with a format of
-      `todo +d 12 02 2024` works.
+      `todo +d 12 02 2024` work.
+
+    - Added the ability to specify alphabetic (`#A`, `#B`, and `#C`)
+      [priorities] at the end of the input note.
 
   * `XMonad.Prompt`
 
@@ -236,6 +239,7 @@
     - Added a `Default` instance for `UrgencyConfig` and `DzenUrgencyHook`.
 
 [this PR]: https://github.com/xmonad/xmonad-contrib/pull/744
+[priorities]: https://orgmode.org/manual/Priorities.html
 
 ### Other changes
 

XMonad/Prompt/OrgMode.hs

@@ -2,8 +2,9 @@
 {-# LANGUAGE InstanceSigs        #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE StrictData          #-}
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData          #-}
 --------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Prompt.OrgMode
@@ -20,9 +21,9 @@
 -- "XMonad.Prompt.AppendFile", allowing for more interesting
 -- interactions with that particular file type.
 --
--- It can be used to quickly save TODOs, NOTEs, and the like with
+-- It can be used to quickly save TODOs, NOTEs, and the like with the
--- the additional capability to schedule/deadline a task, or use
+-- additional capability to schedule/deadline a task, add a priority,
--- the system's clipboard (really: the primary selection) as the
+-- and use the system's clipboard (really: the primary selection) as the
 -- contents of the note.
 --
 --------------------------------------------------------------------
@@ -41,6 +42,7 @@ module XMonad.Prompt.OrgMode (
 #ifdef TESTING
     pInput,
     Note (..),
+    Priority (..),
     Date (..),
     Time (..),
     TimeOfDay (..),
@@ -132,6 +134,12 @@ 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 is basic support for alphabetic org-mode
+<https:\/\/orgmode.org\/manual\/Priorities.html priorities>.
+Simply append either @#A@, @#B@, or @#C@ (capitalisation is optional) to
+the end of the note.  For example, one could write @"hello +s 11 jan
+2013 #A"@ or @"hello #C"@.
+
 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
@@ -327,26 +335,39 @@ instance Enum DayOfWeek where
 
 -- | An @org-mode@ style note.
 data Note
-  = Scheduled String Time
+  = Scheduled String Time Priority
-  | Deadline  String Time
+  | Deadline  String Time Priority
-  | NormalMsg String
+  | NormalMsg String      Priority
+  deriving (Eq, Show)
+
+-- | An @org-mode@ style priority symbol[1]; e.g., something like
+-- @[#A]@.  Note that this uses the standard org conventions: supported
+-- priorities are @A@, @B@, and @C@, with @A@ being the highest.
+-- Numerical priorities are not supported.
+--
+-- [1]: https://orgmode.org/manual/Priorities.html
+data Priority = A | B | C | NoPriority
   deriving (Eq, Show)
 
 -- | Pretty print a given 'Note'.
 ppNote :: Clp -> String -> Note -> IO String
 ppNote clp todo = \case
-  Scheduled str time -> mkLine str "SCHEDULED: " (Just time)
+  Scheduled str time prio -> mkLine str "SCHEDULED: " (Just time) prio
-  Deadline  str time -> mkLine str "DEADLINE: "  (Just time)
+  Deadline  str time prio -> mkLine str "DEADLINE: "  (Just time) prio
-  NormalMsg str      -> mkLine str ""            Nothing
+  NormalMsg str      prio -> mkLine str ""            Nothing     prio
  where
-  mkLine :: String -> String -> Maybe Time -> IO String
+  mkLine :: String -> String -> Maybe Time -> Priority -> IO String
-  mkLine str sched time = do
+  mkLine str sched time prio = do
     t <- case time of
       Nothing -> pure ""
       Just ti -> (("\n  " <> sched) <>) <$> ppDate ti
-    pure $ case clp of
+    pure $ "* " <> todo <> priority <> case clp of
-      Body   c -> mconcat ["* ", todo, " ", str, t, c]
+      Body   c -> mconcat [str, t, c]
-      Header c -> mconcat ["* ", todo, " [[", c, "][", str,"]]", t]
+      Header c -> mconcat ["[[", c, "][", str,"]]", t]
+   where
+    priority = case prio of
+      NoPriority -> " "
+      otherPrio  -> " [#" <> show otherPrio <> "] "
 
 ------------------------------------------------------------------------
 -- Parsing
@@ -354,16 +375,29 @@ ppNote clp todo = \case
 -- | Parse the given string into a 'Note'.
 pInput :: String -> Maybe Note
 pInput inp = (`runParser` inp) . choice $
-  [ Scheduled <$> getLast "+s" <*> (Time <$> pDate <*> pTimeOfDay)
+  [ Scheduled <$> getLast "+s" <*> (Time <$> pDate <*> pTimeOfDay) <*> pPriority
-  , Deadline  <$> getLast "+d" <*> (Time <$> pDate <*> pTimeOfDay)
+  , Deadline  <$> getLast "+d" <*> (Time <$> pDate <*> pTimeOfDay) <*> pPriority
-  , NormalMsg <$> munch1 (const True)
+  , do s <- munch1 (pure True)
+       let (s', p) = splitAt (length s - 2) s
+       pure $ case tryPrio p of
+         Just prio -> NormalMsg (dropStripEnd 0 s') prio
+         Nothing   -> NormalMsg s                   NoPriority
   ]
  where
+  tryPrio :: String -> Maybe Priority
+  tryPrio ['#', x]
+    | x `elem` ("Aa" :: String) = Just A
+    | x `elem` ("Bb" :: String) = Just B
+    | x `elem` ("Cc" :: String) = Just C
+  tryPrio _ = Nothing
+
+  -- Trim whitespace at the end of a string after dropping some number
+  -- of characters from it.
+  dropStripEnd :: Int -> String -> String
+  dropStripEnd n = reverse . dropWhile (== ' ') . drop n . reverse
+
   getLast :: String -> Parser String
-  getLast ptn =  reverse
+  getLast ptn =  dropStripEnd (length ptn) -- drop only the last pattern before stripping
-              .  dropWhile (== ' ')    -- trim whitespace at the end
-              .  drop (length ptn)     -- drop only the last pattern
-              .  reverse
               .  concat
              <$> endBy1 (go "") (pure ptn)
    where
@@ -373,6 +407,15 @@ pInput inp = (`runParser` inp) . choice $
       word <- munch1 (/= ' ')
       bool go pure (word == ptn) $ consumed <> str <> word
 
+-- | Parse a 'Priority'.
+pPriority :: Parser Priority
+pPriority = skipSpaces *> choice
+  [ "#" *> ("A" <|> "a") $> A
+  , "#" *> ("B" <|> "b") $> B
+  , "#" *> ("C" <|> "c") $> C
+  , pure NoPriority
+  ]
+
 -- | Try to parse a 'Time'.
 pTimeOfDay :: Parser (Maybe TimeOfDay)
 pTimeOfDay = choice
@@ -424,9 +467,9 @@ pDate = skipSpaces *> choice
 
   -- | Parse a prefix and drop a potential suffix up to the next (space
   -- separated) word.  If successful, return @ret@.
-  pPrefix :: String -> String -> a -> Parser a
+  pPrefix :: Parser String -> String -> a -> Parser a
   pPrefix start leftover ret = do
-    void $ string start
+    void start
     l <- munch (/= ' ')
     guard (l `isPrefixOf` leftover)
     pure ret

tests/OrgMode.hs

@@ -30,6 +30,7 @@ spec = do
           ( Deadline
               "todo"
               (Time {date = Date (22, Just 1, Just 2021), tod = Nothing})
+              NoPriority
           )
     it "works with todo +d 22 01 2022" $ do
       pInput "todo +d 22 01 2022"
@@ -37,6 +38,7 @@ spec = do
           ( Deadline
               "todo"
               (Time {date = Date (22, Just 1, Just 2022), tod = Nothing})
+              NoPriority
           )
     it "works with todo +d 1 01:01" $ do
       pInput "todo +d 1 01:01"
@@ -44,14 +46,29 @@ spec = do
           ( Deadline
               "todo"
               (Time {date = Date (1, Nothing, Nothing), tod = Just $ TimeOfDay 1 1})
+              NoPriority
+          )
+    it "works with todo +d 22 jan 2021 01:01 #b" $ do
+      pInput "todo +d 22 jan 2021 01:01 #b"
+        `shouldBe` Just
+          ( Deadline
+                "todo"
+                (Time {date = Date (22, Just 1, Just 2021), tod = Just $ TimeOfDay 1 1})
+                B
           )
 
   context "+d +d f" $ do
     it "encode" $ prop_encodePreservation (OrgMsg "+d +d f")
-    it "decode" $ prop_decodePreservation (Deadline "+d" (Time {date = Next Friday, tod = Nothing}))
+    it "decode" $ prop_decodePreservation (Deadline "+d" (Time {date = Next Friday, tod = Nothing}) NoPriority)
+  context "+d f 1 +d f #c" $ do
+    it "encode" $ prop_encodePreservation (OrgMsg "+d +d f")
+    it "decode" $ prop_decodePreservation (Deadline "+d" (Time {date = Next Friday, tod = Nothing}) C)
   context "+d f 1 +d f" $ do
     it "encode" $ prop_encodePreservation (OrgMsg "+d f 1 +d f")
-    it "decode" $ prop_decodePreservation (Deadline "+d f 1" (Time {date = Next Friday, tod = Nothing}))
+    it "decode" $ prop_decodePreservation (Deadline "+d f 1" (Time {date = Next Friday, tod = Nothing}) NoPriority)
+  context "+d f 1 +d f #b" $ do
+    it "encode" $ prop_encodePreservation (OrgMsg "+d f 1 +d f #b")
+    it "decode" $ prop_decodePreservation (Deadline "+d f 1" (Time {date = Next Friday, tod = Nothing}) B)
 
 -- | Parsing preserves all info that printing does.
 prop_encodePreservation :: OrgMsg -> Property
@@ -66,9 +83,14 @@ prop_decodePreservation n = Just (ppNote n) === (fmap ppNote . pInput $ ppNote n
 
 ppNote :: Note -> String
 ppNote = \case
-  Scheduled str t -> str <> " +s " <> ppTime t
+  Scheduled str t p -> str <> " +s " <> ppTime t <> ppPrio p
-  Deadline  str t -> str <> " +d " <> ppTime t
+  Deadline  str t p -> str <> " +d " <> ppTime t <> ppPrio p
-  NormalMsg str   -> str
+  NormalMsg str   p -> str                       <> ppPrio p
+
+ppPrio :: Priority -> String
+ppPrio = \case
+  NoPriority -> ""
+  prio       -> " #" <> show prio
 
 ppTime :: Time -> String
 ppTime (Time d t) = ppDate d <> ppTOD t
@@ -93,8 +115,10 @@ newtype OrgMsg = OrgMsg String
 
 instance Arbitrary OrgMsg where
   arbitrary :: Gen OrgMsg
-  arbitrary = OrgMsg <$>
+  arbitrary
-    randomString <<>> elements [" +s ", " +d ", ""] <<>> dateGen <<>> hourGen
+    = OrgMsg <$> randomString                                             -- note
+            <<>> elements [" +s ", " +d ", ""] <<>> dateGen <<>> hourGen  -- time and date
+            <<>> elements ("" : map (reverse . (: " #")) "AaBbCc")        -- priority
    where
     dateGen :: Gen String
     dateGen = oneof
@@ -130,7 +154,12 @@ instance Arbitrary Note where
   arbitrary = do
     msg <- randomString
     t   <- arbitrary
-    elements [Scheduled msg t, Deadline msg t, NormalMsg msg]
+    p   <- arbitrary
+    elements [Scheduled msg t p, Deadline msg t p, NormalMsg msg p]
+
+instance Arbitrary Priority where
+  arbitrary :: Gen Priority
+  arbitrary = elements [A, B, C, NoPriority]
 
 instance Arbitrary Time where
   arbitrary :: Gen Time