twin/xmonad-contrib
1
0
Fork 0
mirror of https://github.com/xmonad/xmonad-contrib.git synced 2025-08-01 20:51:52 -07:00
Code Issues Packages Projects Releases Wiki Activity

X.P.OrgMode: Use X.U.Parser

Browse Source 
Since we now have an "internal" parser library in xmonad, use it.  This
allows us to get rid of some hacks in this module that were needed
because of ReadP's parsing behaviour.
This commit is contained in:
slotThe
2021-11-29 11:47:16 +01:00
parent 8b3df5b268
commit b1532e666f
1 changed files with 38 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files

104
XMonad/Prompt/OrgMode.hs
View File

@@ -53,12 +53,12 @@ import XMonad.Prelude
import XMonad (X, io) import XMonad (X, io)
import XMonad.Prompt (XPConfig, XPrompt (showXPrompt), mkXPrompt) import XMonad.Prompt (XPConfig, XPrompt (showXPrompt), mkXPrompt)
import XMonad.Util.Parser
import XMonad.Util.XSelection (getSelection) import XMonad.Util.XSelection (getSelection)
import Data.Time (Day (ModifiedJulianDay), NominalDiffTime, UTCTime (utctDay), addUTCTime, defaultTimeLocale, formatTime, fromGregorian, getCurrentTime, iso8601DateFormat, nominalDay, toGregorian) import Data.Time (Day (ModifiedJulianDay), NominalDiffTime, UTCTime (utctDay), addUTCTime, defaultTimeLocale, formatTime, fromGregorian, getCurrentTime, iso8601DateFormat, nominalDay, toGregorian)
import System.Directory (getHomeDirectory) import System.Directory (getHomeDirectory)
import System.IO (IOMode (AppendMode), hPutStrLn, withFile) import System.IO (IOMode (AppendMode), hPutStrLn, withFile)
import Text.ParserCombinators.ReadP (ReadP, munch, munch1, readP_to_S, skipSpaces, string, (<++))
{- $usage {- $usage
@@ -357,13 +357,13 @@ ppNote clp todo = \case
-- | Parse the given string into a 'Note'. -- | Parse the given string into a 'Note'.
pInput :: String -> Maybe Note pInput :: String -> Maybe Note
pInput inp = fmap fst . listToMaybe . (`readP_to_S` inp) . lchoice $ pInput inp = (`runParser` inp) . choice $
[ Scheduled <$> getLast "+s" <*> (Time <$> pDate <*> pTimeOfDay) [ Scheduled <$> getLast "+s" <*> (Time <$> pDate <*> pTimeOfDay)
, Deadline <$> getLast "+d" <*> (Time <$> pDate <*> pTimeOfDay) , Deadline <$> getLast "+d" <*> (Time <$> pDate <*> pTimeOfDay)
, NormalMsg <$> munch1 (const True) , NormalMsg <$> munch1 (const True)
] ]
where where
getLast :: String -> ReadP String getLast :: String -> Parser String
getLast ptn = reverse getLast ptn = reverse
. dropWhile (== ' ') -- trim whitespace at the end . dropWhile (== ' ') -- trim whitespace at the end
. drop (length ptn) -- drop only the last pattern . drop (length ptn) -- drop only the last pattern
@@ -371,82 +371,54 @@ pInput inp = fmap fst . listToMaybe . (`readP_to_S` inp) . lchoice $
. concat . concat
<$> endBy1 (go "") (pure ptn) <$> endBy1 (go "") (pure ptn)
where where
go :: String -> ReadP String go :: String -> Parser String
go consumed = do go consumed = do
str <- munch (/= head ptn) str <- munch (/= head ptn)
word <- munch1 (/= ' ') word <- munch1 (/= ' ')
bool go pure (word == ptn) $ consumed <> str <> word bool go pure (word == ptn) $ consumed <> str <> word
-- | Try to parse a 'Time'. -- | Try to parse a 'Time'.
pTimeOfDay :: ReadP (Maybe TimeOfDay) pTimeOfDay :: Parser (Maybe TimeOfDay)
pTimeOfDay = lchoice pTimeOfDay = choice
[ Just <$> (TimeOfDay <$> pInt <* string ":" <*> pInt ) -- HH:MM [ Just <$> (TimeOfDay <$> num <* string ":" <*> num ) -- HH:MM
, Just <$> (TimeOfDay <$> pInt <*> pure 0) -- HH , Just <$> (TimeOfDay <$> num <*> pure 0) -- HH
, pure Nothing , pure Nothing
] ]
-- | Parse a 'Date'. -- | Parse a 'Date'.
pDate :: ReadP Date pDate :: Parser Date
pDate = skipSpaces *> lchoice pDate = skipSpaces *> choice
[ pString "tod" "ay" Today [ pPrefix "tod" "ay" Today
, pString "tom" "orrow" Tomorrow , pPrefix "tom" "orrow" Tomorrow
, Next <$> pNext , Next <$> pNext
, Date <$> pDate1 <++ pDate2 <++ pDate3 , Date <$> pDate'
] <* skipSpaces -- cleanup ] <* skipSpaces -- cleanup
where where
pNext :: ReadP DayOfWeek = lchoice pNext :: Parser DayOfWeek = choice
[ pString "m" "onday" Monday , pString "tu" "esday" Tuesday [ pPrefix "m" "onday" Monday , pPrefix "tu" "esday" Tuesday
, pString "w" "ednesday" Wednesday, pString "th" "ursday" Thursday , pPrefix "w" "ednesday" Wednesday, pPrefix "th" "ursday" Thursday
, pString "f" "riday" Friday , pString "sa" "turday" Saturday , pPrefix "f" "riday" Friday , pPrefix "sa" "turday" Saturday
, pString "su" "nday" Sunday , pPrefix "su" "nday" Sunday
] ]
-- XXX: This is really horrible, but I can't see a way to not have pDate' :: Parser (Int, Maybe Int, Maybe Integer)
-- exponential blowup with ReadP otherwise. pDate' =
pDate1, pDate2, pDate3 :: ReadP (Int, Maybe Int, Maybe Integer) (,,) <$> num
pDate1 = pDate' (fmap Just) (fmap Just) <*> optional (skipSpaces *> choice
pDate2 = pDate' (fmap Just) (const (pure Nothing)) [ pPrefix "ja" "nuary" 1 , pPrefix "f" "ebruary" 2
pDate3 = pDate' (const (pure Nothing)) (const (pure Nothing)) , pPrefix "mar" "ch" 3 , pPrefix "ap" "ril" 4
pDate' , pPrefix "may" "" 5 , pPrefix "jun" "e" 6
:: (ReadP Int -> ReadP (f Int )) , pPrefix "jul" "y" 7 , pPrefix "au" "gust" 8
-> (ReadP Integer -> ReadP (f Integer)) , pPrefix "s" "eptember" 9 , pPrefix "o" "ctober" 10
-> ReadP (Int, f Int, f Integer) , pPrefix "n" "ovember" 11, pPrefix "d" "ecember" 12
pDate' p p' =
(,,) <$> pInt
<*> p (skipSpaces *> lchoice
[ 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 >>= \i -> guard (i >= 25) $> i) <*> optional (skipSpaces *> num >>= \i -> guard (i >= 25) $> i)
-- | Parse a @start@ and see whether the rest of the word (separated by -- | Parse a prefix and drop a potential suffix up to the next (space
-- spaces) fits the @leftover@. -- separated) word. If successful, return @ret@.
pString :: String -> String -> a -> ReadP a pPrefix :: String -> String -> a -> Parser a
pString start leftover ret = do pPrefix start leftover ret = do
void $ string start void $ string start
l <- munch (/= ' ') l <- munch (/= ' ')
guard (l `isPrefixOf` leftover) guard (l `isPrefixOf` leftover)
pure ret pure ret
-- | Parse a number.
pInt :: (Read a, Integral a) => ReadP a
pInt = read <$> munch1 isDigit
-- | Like 'choice', but with '(<++)' instead of '(+++)', stopping
-- parsing when the left-most parser succeeds.
lchoice :: [ReadP a] -> ReadP a
lchoice = foldl' (<++) empty
-- | Like 'Text.ParserCombinators.ReadP.endBy1', but only return the
-- parse where @parser@ had the highest number of applications.
endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
endBy1 parser sep = many1 (parser <* sep)
where
-- | Like 'Text.ParserCombinators.ReadP.many1', but use '(<++)'
-- instead of '(+++)'.
many1 :: ReadP a -> ReadP [a]
many1 p = (:) <$> p <*> (many1 p <++ pure [])