twin/xmonad-contrib
1
0
Fork 0
mirror of https://github.com/xmonad/xmonad-contrib.git synced 2025-05-19 11:30:22 -07:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #659 from slotThe/x.u.parser

Browse Source 
New Module: XMonad.Util.Parser
This commit is contained in:
Tony Zorman 2021-12-17 12:13:02 +01:00 committed by GitHub
commit 0010735aca
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 344 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
CHANGES.md
View File

@ -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`

104
XMonad/Prompt/OrgMode.hs
View File

@ -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,13 +357,13 @@ 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
@ -371,82 +371,54 @@ pInput inp = fmap fst . listToMaybe . (`readP_to_S` inp) . lchoice $
. 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)
<*> optional (skipSpaces *> num >>= \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 [])
-- | 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

57
XMonad/Util/EZConfig.hs
View File

@ -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,16 +412,15 @@ 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)
@ -425,23 +428,23 @@ parseKeyCombo c = do mods <- many (parseModifier c)
-- | 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)]

215
XMonad/Util/Parser.hs Normal file
View File

@ -0,0 +1,215 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeApplications #-}
--------------------------------------------------------------------
-- |
-- Module : XMonad.Util.Parser
-- Description : A parser combinator library for xmonad
-- Copyright : (c) 2021 slotThe <soliditsallgood@mailbox.org>
-- License : BSD3
-- Maintainer : slotThe <soliditsallgood@mailbox.org>
-- Stability : experimental
-- Portability : non-portable
--
-- A small wrapper around the 'ReadP' parser combinator in @base@,
-- providing a more intuitive behaviour. While it's theoretically nice
-- that 'ReadP' is actually commutative, this makes a lot of parsing
-- operations rather awkward—more often than not, one only wants the
-- argument that's parsed "first".
--
-- Due to the left-biased nature of the chosen semigroup implementation,
-- using functions like 'many' or 'optional' from "Control.Applicative"
-- now yields more consistent behaviour with other parser combinator
-- libraries.
--
--------------------------------------------------------------------
module XMonad.Util.Parser (
-- * Usage
-- $usage
-- * Running
Parser,
runParser,
-- * Primitive Parsers
eof,
num,
char,
string,
skipSpaces,
get,
look,
-- * Combining Parsers
satisfy,
choice,
many1,
sepBy,
sepBy1,
endBy,
endBy1,
munch,
munch1,
) where
import XMonad.Prelude
import qualified Text.ParserCombinators.ReadP as ReadP
import Data.Coerce (coerce)
import Text.ParserCombinators.ReadP (ReadP, (<++))
{- $usage
NOTE: This module is mostly intended for developing of other modules.
If you are a users, you probably won't find much use here—you have been
warned.
The high-level API tries to stay as close to 'ReadP' as possible. If
you are familiar with that then no functions here should surprise you.
One notable usability difference when forcing left-biasedness is /when/
one wants to disambiguate a parse. For normal 'ReadP' usage this
happens after the actual parsing stage by going through the list of
successful parses. For 'Parser' it does when constructing the relevant
combinators, leading to only one successful parse. As an example,
consider the 'ReadP'-based parser
> pLangle = ReadP.string "<"
> pLongerSequence = ReadP.char '<' *> ReadP.string "f" <* ReadP.char '>'
> pCombination = pLangle ReadP.+++ pLongerSequence
Parsing the string @"<f>"@ will return
>>> ReadP.readP_to_S pCombination "<f>"
[("<","f>"),("f","")]
One would now need to, for example, filter for the second (leftover)
string being empty and take the head of the resulting list (which may
still have more than one element).
With 'Parser', the same situation would look like the following
> pLangle' = string "<"
> pLongerSequence' = char '<' *> string "f" <* char '>'
> pCombination' = pLongerSequence' <> pLangle'
Notice how @pLangle'@ and @pLongerSequence'@ have traded places—since we
are not forcing @pLangle'@ to consume the entire string and @(<>)@ is
left-biased, @pLongerSequence'@ parses a superset of @pLangle'@!
Running @runParser pCombination'@ now yields the expected result:
>>> runParser pCombination' "<f>"
Just "f"
One might also define @pLangle'@ as @string "<" <* eof@, which would
enable a definition of @pCombination' = pLangle' <> pLongerSequence'@.
For example uses, see "XMonad.Util.EZConfig" or "XMonad.Prompt.OrgMode".
-}
-- Parser :: Type -> Type
newtype Parser a = Parser (ReadP a)
deriving newtype (Functor, Applicative, Monad)
instance Semigroup (Parser a) where
-- | Local, exclusive, left-biased choice: If left parser locally
-- produces any result at all, then right parser is not used.
(<>) :: Parser a -> Parser a -> Parser a
(<>) = coerce ((<++) @a)
instance Monoid (Parser a) where
-- | A parser that always fails.
mempty :: Parser a
mempty = Parser empty
instance Alternative Parser where
empty :: Parser a
empty = mempty
(<|>) :: Parser a -> Parser a -> Parser a
(<|>) = (<>)
-- | Run a parser on a given string.
runParser :: Parser a -> String -> Maybe a
runParser (Parser p) = fmap fst . listToMaybe . ReadP.readP_to_S p
-- | Consume and return the next character. Fails if there is no input
-- left.
get :: Parser Char
get = coerce ReadP.get
-- | Look-ahead: return the part of the input that is left, without
-- consuming it.
look :: Parser String
look = coerce ReadP.look
-- | Succeeds if and only if we are at the end of input.
eof :: Parser ()
eof = coerce ReadP.eof
-- | Parse an integral number number.
num :: (Read a, Integral a) => Parser a
num = read <$> munch1 isDigit
{-# SPECIALISE num :: Parser Word #-}
{-# SPECIALISE num :: Parser Int #-}
{-# SPECIALISE num :: Parser Integer #-}
-- | Parse and return the specified character.
char :: Char -> Parser Char
char = coerce ReadP.char
-- | Parse and return the specified string.
string :: String -> Parser String
string = coerce ReadP.string
-- | Skip all whitespace.
skipSpaces :: Parser ()
skipSpaces = coerce ReadP.skipSpaces
-- | Consume and return the next character if it satisfies the specified
-- predicate.
satisfy :: (Char -> Bool) -> Parser Char
satisfy = coerce ReadP.satisfy
-- | Combine all parsers in the given list in a left-biased way.
choice :: [Parser a] -> Parser a
choice = foldl' (<>) mempty
-- | Parse the first zero or more characters satisfying the predicate.
-- Always succeeds; returns an empty string if the predicate returns
-- @False@ on the first character of input.
munch :: (Char -> Bool) -> Parser String
munch = coerce ReadP.munch
-- | Parse the first one or more characters satisfying the predicate.
-- Fails if none, else succeeds exactly once having consumed all the
-- characters.
munch1 :: (Char -> Bool) -> Parser String
munch1 = coerce ReadP.munch1
-- | @endBy p sep@ parses zero or more occurrences of @p@, separated and
-- ended by @sep@.
endBy :: Parser a -> Parser sep -> Parser [a]
endBy p sep = many (p <* sep)
-- | @endBy p sep@ parses one or more occurrences of @p@, separated and
-- ended by @sep@.
endBy1 :: Parser a -> Parser sep -> Parser [a]
endBy1 p sep = many1 (p <* sep)
-- | Parse one or more occurrences of the given parser.
many1 :: Parser a -> Parser [a]
many1 p = liftA2 (:) p (many p)
-- | @sepBy p sep@ parses zero or more occurrences of @p@, separated by
-- @sep@. Returns a list of values returned by @p@.
sepBy :: Parser a -> Parser sep -> Parser [a]
sepBy p sep = sepBy1 p sep <> pure []
-- | @sepBy1 p sep@ parses one or more occurrences of @p@, separated by
-- @sep@. Returns a list of values returned by @p@.
sepBy1 :: Parser a -> Parser sep -> Parser [a]
sepBy1 p sep = liftA2 (:) p (many (sep *> p))

8
XMonad/Util/Paste.hs
View File

@ -28,10 +28,10 @@ import Graphics.X11
import Graphics.X11.Xlib.Extras (none, setEventType, setKeyEvent)
import Control.Monad.Reader (asks)
import XMonad.Operations (withFocused)
import XMonad.Prelude (isUpper, listToMaybe)
import XMonad.Prelude (isUpper, fromMaybe)
import XMonad.Util.XSelection (getSelection)
import XMonad.Util.EZConfig (parseKey)
import Text.ParserCombinators.ReadP (readP_to_S)
import XMonad.Util.Parser (runParser)
{- $usage
@ -72,8 +72,8 @@ pasteString = mapM_ (\x -> if isUpper x || x `elem` "~!@#$%^&*()_+{}|:\"<>?" the
outside ASCII.
-}
pasteChar :: KeyMask -> Char -> X ()
pasteChar m c = sendKey m $ maybe (unicodeToKeysym c) fst
$ listToMaybe $ readP_to_S parseKey [c]
pasteChar m c = sendKey m $ fromMaybe (unicodeToKeysym c)
$ runParser parseKey [c]
-- | Send a key with a modifier to the currently focused window.
sendKey :: KeyMask -> KeySym -> X ()

39
tests/EZConfig.hs Normal file
View File

@ -0,0 +1,39 @@
module EZConfig (spec) where
import Control.Arrow (first)
import Test.Hspec
import XMonad
import XMonad.Prelude
import XMonad.Util.EZConfig
import XMonad.Util.Parser
spec :: Spec
spec = do
context "parseKey" $ do
let prepare = unzip . map (first surround)
testParseKey (ns, ks) = traverse (runParser parseKey) ns `shouldBe` Just ks
it "parses all regular keys" $ testParseKey regularKeys
it "parses all function keys" $ testParseKey (prepare functionKeys )
it "parses all special keys" $ testParseKey (prepare specialKeys )
it "parses all multimedia keys" $ testParseKey (prepare multimediaKeys)
context "parseModifier" $ do
it "parses all combinations of modifiers" $
nub . map sort <$> traverse (runParser (many $ parseModifier def))
modifiers
`shouldBe` Just [[ shiftMask, controlMask
, mod1Mask, mod1Mask -- def M and M1
, mod2Mask, mod3Mask, mod4Mask, mod5Mask
]]
regularKeys :: ([String], [KeySym])
regularKeys = unzip . map (first (: ""))
$ zip ['!' .. '~' ] [xK_exclam .. xK_asciitilde]
++ zip ['\xa0' .. '\xff'] [xK_nobreakspace .. xK_ydiaeresis]
-- | QuickCheck can handle the 8! combinations just fine.
modifiers :: [String]
modifiers = map concat $
permutations ["M-", "C-", "S-", "M1-", "M2-", "M3-", "M4-", "M5-"]
surround :: String -> String
surround s = "<" <> s <> ">"

2
tests/Main.hs
View File

@ -13,6 +13,7 @@ import qualified XPrompt
import qualified CycleRecentWS
import qualified OrgMode
import qualified GridSelect
import qualified EZConfig
main :: IO ()
main = hspec $ do
@ -51,3 +52,4 @@ main = hspec $ do
context "CycleRecentWS" CycleRecentWS.spec
context "OrgMode" OrgMode.spec
context "GridSelect" GridSelect.spec
context "EZConfig" EZConfig.spec

6
xmonad-contrib.cabal
View File

@ -359,6 +359,7 @@ library
XMonad.Util.NamedScratchpad
XMonad.Util.NamedWindows
XMonad.Util.NoTaskbar
XMonad.Util.Parser
XMonad.Util.Paste
XMonad.Util.PositionStore
XMonad.Util.PureX
@ -387,6 +388,7 @@ test-suite tests
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules: CycleRecentWS
EZConfig
ExtensibleConf
GridSelect
Instances
@ -403,6 +405,7 @@ test-suite tests
XMonad.Actions.GridSelect
XMonad.Actions.PhysicalScreens
XMonad.Actions.RotateSome
XMonad.Actions.Submap
XMonad.Actions.SwapWorkspaces
XMonad.Actions.TagWindows
XMonad.Actions.WindowBringer
@ -421,12 +424,15 @@ test-suite tests
XMonad.Prompt.Shell
XMonad.Util.Dmenu
XMonad.Util.Dzen
XMonad.Util.EZConfig
XMonad.Util.ExtensibleConf
XMonad.Util.ExtensibleState
XMonad.Util.Font
XMonad.Util.Image
XMonad.Util.Invisible
XMonad.Util.NamedActions
XMonad.Util.NamedWindows
XMonad.Util.Parser
XMonad.Util.PureX
XMonad.Util.Rectangle
XMonad.Util.Run