New Module: XMonad.Util.Parser

CHANGES.md

@@ -4,6 +4,12 @@
 
 ### Breaking Changes
 
+  * `XMonad.Util.EZConfig`
+
+    - The functions `parseKey`, `parseKeyCombo`, and `parseKeySequence`
+      now return a `Parser` (from `XMonad.Util.Parser`) instead of a
+      `ReadP`.
+
 ### New Modules
 
   * `XMonad.Layout.CenteredIfSingle`
@@ -21,6 +27,11 @@
     While XMonad provides config to set all window borders at the same
     width, this extension defines and sets border width for each window.
 
+  * `XMonad.Util.Parser`
+
+    A wrapper around the 'ReadP' parser combinator, providing behaviour
+    that's closer to the more popular parser combinator libraries.
+
 ### Bug Fixes and Minor Changes
 
   * `XMonad.Prompt`

XMonad/Prompt/OrgMode.hs

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

XMonad/Util/EZConfig.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 --------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Util.EZConfig
@@ -34,21 +35,24 @@ module XMonad.Util.EZConfig (
 
                              parseKey, -- used by XMonad.Util.Paste
                              parseKeyCombo,
-                             parseKeySequence, readKeySequence
+                             parseKeySequence, readKeySequence,
+#ifdef TESTING
+                             functionKeys, specialKeys, multimediaKeys,
+                             parseModifier,
+#endif
                             ) where
 
 import XMonad
 import XMonad.Actions.Submap
-import XMonad.Prelude hiding (many)
+import XMonad.Prelude
 
 import XMonad.Util.NamedActions
+import XMonad.Util.Parser
 
 import Control.Arrow (first, (&&&))
 import qualified Data.Map as M
 import Data.Ord (comparing)
 
-import Text.ParserCombinators.ReadP
-
 -- $usage
 -- To use this module, first import it into your @~\/.xmonad\/xmonad.hs@:
 --
@@ -408,40 +412,39 @@ readKeymap c = mapMaybe (maybeKeys . first (readKeySequence c))
 -- | Parse a sequence of keys, returning Nothing if there is
 --   a parse failure (no parse, or ambiguous parse).
 readKeySequence :: XConfig l -> String -> Maybe [(KeyMask, KeySym)]
-readKeySequence c = listToMaybe . parses
-  where parses = map fst . filter (null.snd) . readP_to_S (parseKeySequence c)
+readKeySequence c = runParser (parseKeySequence c)
 
 -- | Parse a sequence of key combinations separated by spaces, e.g.
 --   @\"M-c x C-S-2\"@ (mod+c, x, ctrl+shift+2).
-parseKeySequence :: XConfig l -> ReadP [(KeyMask, KeySym)]
-parseKeySequence c = sepBy1 (parseKeyCombo c) (many1 $ char ' ')
+parseKeySequence :: XConfig l -> Parser [(KeyMask, KeySym)]
+parseKeySequence c = parseKeyCombo c `sepBy1` many1 (char ' ')
 
 -- | Parse a modifier-key combination such as "M-C-s" (mod+ctrl+s).
-parseKeyCombo :: XConfig l -> ReadP (KeyMask, KeySym)
+parseKeyCombo :: XConfig l -> Parser (KeyMask, KeySym)
 parseKeyCombo c = do mods <- many (parseModifier c)
                      k <- parseKey
                      return (foldl' (.|.) 0 mods, k)
 
 -- | Parse a modifier: either M- (user-defined mod-key),
 --   C- (control), S- (shift), or M#- where # is an integer
 --   from 1 to 5 (mod1Mask through mod5Mask).
-parseModifier :: XConfig l -> ReadP KeyMask
-parseModifier c =  (string "M-" >> return (modMask c))
-               +++ (string "C-" >> return controlMask)
-               +++ (string "S-" >> return shiftMask)
-               +++ do _ <- char 'M'
-                      n <- satisfy (`elem` ['1'..'5'])
-                      _ <- char '-'
-                      return $ indexMod (read [n] - 1)
+parseModifier :: XConfig l -> Parser KeyMask
+parseModifier c = (string "M-" $> modMask c)
+               <> (string "C-" $> controlMask)
+               <> (string "S-" $> shiftMask)
+               <> do _ <- char 'M'
+                     n <- satisfy (`elem` ['1'..'5'])
+                     _ <- char '-'
+                     return $ indexMod (read [n] - 1)
     where indexMod = (!!) [mod1Mask,mod2Mask,mod3Mask,mod4Mask,mod5Mask]
 
 -- | Parse an unmodified basic key, like @\"x\"@, @\"<F1>\"@, etc.
-parseKey :: ReadP KeySym
-parseKey = parseRegular +++ parseSpecial
+parseKey :: Parser KeySym
+parseKey = parseSpecial <> parseRegular
 
 -- | Parse a regular key name (represented by itself).
-parseRegular :: ReadP KeySym
-parseRegular = choice [ char s >> return k
+parseRegular :: Parser KeySym
+parseRegular = choice [ char s $> k
                       | (s,k) <- zip ['!'             .. '~'          ] -- ASCII
                                      [xK_exclam       .. xK_asciitilde]
 
@@ -450,13 +453,11 @@ parseRegular = choice [ char s >> return k
                       ]
 
 -- | Parse a special key name (one enclosed in angle brackets).
-parseSpecial :: ReadP KeySym
-parseSpecial = do _   <- char '<'
-                  key <- choice [ string name >> return k
-                                | (name,k) <- keyNames
-                                ]
-                  _   <- char '>'
-                  return key
+parseSpecial :: Parser KeySym
+parseSpecial = do _ <- char '<'
+                  choice [ k <$ string name <* char '>'
+                         | (name, k) <- keyNames
+                         ]
 
 -- | A list of all special key names and their associated KeySyms.
 keyNames :: [(String, KeySym)]