From d65979cc4fb0dc85f59b445a377958aa9569b934 Mon Sep 17 00:00:00 2001 From: jao Date: Fri, 4 Feb 2022 00:14:13 +0000 Subject: Xmobar.X11.Parsers -> Xmobar.Run.Parsers --- src/Xmobar/App/TextEventLoop.hs | 6 +- src/Xmobar/App/X11EventLoop.hs | 2 +- src/Xmobar/Run/Parsers.hs | 233 ++++++++++++++++++++++++++++++++++++++++ src/Xmobar/X11/Bitmap.hs | 2 +- src/Xmobar/X11/Draw.hs | 2 +- src/Xmobar/X11/Parsers.hs | 233 ---------------------------------------- xmobar.cabal | 2 +- 7 files changed, 242 insertions(+), 238 deletions(-) create mode 100644 src/Xmobar/Run/Parsers.hs delete mode 100644 src/Xmobar/X11/Parsers.hs diff --git a/src/Xmobar/App/TextEventLoop.hs b/src/Xmobar/App/TextEventLoop.hs index ad7c33b..d41e1a7 100644 --- a/src/Xmobar/App/TextEventLoop.hs +++ b/src/Xmobar/App/TextEventLoop.hs @@ -29,7 +29,11 @@ import Control.Concurrent.STM import Xmobar.System.Signal import Xmobar.Config.Types (Config(textOutputFormat), TextOutputFormat(..)) import Xmobar.Run.Loop (initLoop, loop) -import Xmobar.X11.Parsers (Segment, Widget(..), parseString, tColorsString, colorComponents) +import Xmobar.Run.Parsers ( Segment + , Widget(..) + , parseString + , tColorsString + , colorComponents) -- | Starts the main event loop and threads textLoop :: Config -> IO () diff --git a/src/Xmobar/App/X11EventLoop.hs b/src/Xmobar/App/X11EventLoop.hs index 662c777..850738e 100644 --- a/src/Xmobar/App/X11EventLoop.hs +++ b/src/Xmobar/App/X11EventLoop.hs @@ -51,7 +51,7 @@ import Xmobar.Config.Types ( persistent , XPosition(..)) import Xmobar.Run.Actions -import Xmobar.X11.Parsers +import Xmobar.Run.Parsers import Xmobar.X11.Window import Xmobar.X11.Text import Xmobar.X11.Draw diff --git a/src/Xmobar/Run/Parsers.hs b/src/Xmobar/Run/Parsers.hs new file mode 100644 index 0000000..8a1ba0a --- /dev/null +++ b/src/Xmobar/Run/Parsers.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Run.Parsers +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : portable +-- +-- Parsing for template substrings +-- +----------------------------------------------------------------------------- + +module Xmobar.Run.Parsers ( parseString + , colorComponents + , Segment + , Box(..) + , BoxBorder(..) + , BoxOffset(..) + , BoxMargins(..) + , TextRenderInfo(..) + , Widget(..)) where + +import Control.Monad (guard, mzero) +import Data.Maybe (fromMaybe) +import Data.Int (Int32) +import Text.ParserCombinators.Parsec +import Text.Read (readMaybe) +import Foreign.C.Types (CInt) + +import Xmobar.Config.Types +import Xmobar.Run.Actions + +data Widget = Icon String | Text String | Hspace Int32 deriving Show + +data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) +-- margins: Top, Right, Bottom, Left +data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show) +data BoxBorder = BBTop + | BBBottom + | BBVBoth + | BBLeft + | BBRight + | BBHBoth + | BBFull + deriving ( Read, Eq, Show ) +data Box = Box BoxBorder BoxOffset CInt String BoxMargins deriving (Eq, Show) +data TextRenderInfo = + TextRenderInfo { tColorsString :: String + , tBgTopOffset :: Int32 + , tBgBottomOffset :: Int32 + , tBoxes :: [Box] + } deriving Show +type FontIndex = Int + +type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) + +-- | Runs the string parser +parseString :: Config -> String -> IO [Segment] +parseString c s = + case parse (stringParser ci 0 Nothing) "" s of + Left _ -> return [(Text $ "Could not parse string: " ++ s + , ci + , 0 + , Nothing)] + Right x -> return (concat x) + where ci = TextRenderInfo (fgColor c) 0 0 [] + +-- | Splits a colors string into its two components +colorComponents :: Config -> String -> (String, String) +colorComponents conf c = + case break (==',') c of + (f,',':b) -> (f, b) + (f, _) -> (f, bgColor conf) + +allParsers :: TextRenderInfo + -> FontIndex + -> Maybe [Action] + -> Parser [Segment] +allParsers c f a = textParser c f a + <|> try (iconParser c f a) + <|> try (hspaceParser c f a) + <|> try (rawParser c f a) + <|> try (actionParser c f a) + <|> try (fontParser c a) + <|> try (boxParser c f a) + <|> colorParser c f a + +-- | Gets the string and combines the needed parsers +stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [[Segment]] +stringParser c f a = manyTill (allParsers c f a) eof + +-- | Parses a maximal string without markup. +textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +textParser c f a = do s <- many1 $ + noneOf "<" <|> + try (notFollowedBy' (char '<') + (try (string "fc=") <|> + try (string "box") <|> + try (string "fn=") <|> + try (string "action=") <|> + try (string "/action>") <|> + try (string "icon=") <|> + try (string "hspace=") <|> + try (string "raw=") <|> + try (string "/fn>") <|> + try (string "/box>") <|> + string "/fc>")) + return [(Text s, c, f, a)] + +-- | Parse a "raw" tag, which we use to prevent other tags from creeping in. +-- The format here is net-string-esque: a literal "". +rawParser :: TextRenderInfo + -> FontIndex + -> Maybe [Action] + -> Parser [Segment] +rawParser c f a = do + string " do + guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) + s <- count (fromIntegral len) anyChar + string "/>" + return [(Text s, c, f, a)] + _ -> mzero + +-- | Wrapper for notFollowedBy that returns the result of the first parser. +-- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy +-- accepts only parsers with return type Char. +notFollowedBy' :: Parser a -> Parser b -> Parser a +notFollowedBy' p e = do x <- p + notFollowedBy $ try (e >> return '*') + return x + +iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +iconParser c f a = do + string "") (try (string "/>")) + return [(Icon i, c, f, a)] + +hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +hspaceParser c f a = do + string "")) + return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] + +actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +actionParser c f act = do + string "")] + buttons <- (char '>' >> return "1") <|> (space >> spaces >> + between (string "button=") (string ">") (many1 (oneOf "12345"))) + let a = Spawn (toButtons buttons) command + a' = case act of + Nothing -> Just [a] + Just act' -> Just $ a : act' + s <- manyTill (allParsers c f a') (try $ string "") + return (concat s) + +toButtons :: String -> [Button] +toButtons = map (\x -> read [x]) + +-- | Parsers a string wrapped in a color specification. +colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +colorParser (TextRenderInfo _ _ _ bs) f a = do + c <- between (string "") colors + let colorParts = break (==':') c + let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of + (top,',':btm) -> (top, btm) + (top, _) -> (top, top) + s <- manyTill + (allParsers (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob) bs) f a) + (try $ string "") + return (concat s) + +-- | Parses a string wrapped in a box specification. +boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +boxParser (TextRenderInfo cs ot ob bs) f a = do + c <- between (string "") (option "" (many1 (alphaNum <|> char '=' <|> char ' ' <|> char '#' <|> char ','))) + let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0) + let g = boxReader b (words c) + s <- manyTill + (allParsers (TextRenderInfo cs ot ob (g : bs)) f a) + (try $ string "") + return (concat s) + +boxReader :: Box -> [String] -> Box +boxReader b [] = b +boxReader b (x:xs) = do + let (param,val) = case break (=='=') x of + (p,'=':v) -> (p, v) + (p, _) -> (p, "") + boxReader (boxParamReader b param val) xs + +boxParamReader :: Box -> String -> String -> Box +boxParamReader b _ "" = b +boxParamReader (Box bb off lw fc mgs) "type" val = + Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs +boxParamReader (Box bb (BoxOffset alg off) lw fc mgs) "offset" (a:o) = + Box bb (BoxOffset (fromMaybe alg $ readMaybe [a]) (fromMaybe off $ readMaybe o)) lw fc mgs +boxParamReader (Box bb off lw fc mgs) "width" val = + Box bb off (fromMaybe lw $ readMaybe val) fc mgs +boxParamReader (Box bb off lw _ mgs) "color" val = + Box bb off lw val mgs +boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = do + let mgs' = case pos of + "t" -> BoxMargins (fromMaybe mt $ readMaybe val) mr mb ml + "r" -> BoxMargins mt (fromMaybe mr $ readMaybe val) mb ml + "b" -> BoxMargins mt mr (fromMaybe mb $ readMaybe val) ml + "l" -> BoxMargins mt mr mb (fromMaybe ml $ readMaybe val) + _ -> mgs + Box bb off lw fc mgs' +boxParamReader b _ _ = b + +-- | Parsers a string wrapped in a font specification. +fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [Segment] +fontParser c a = do + f <- between (string "") colors + s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "") + return (concat s) + +-- | Parses a color specification (hex or named) +colors :: Parser String +colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#') diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs index 2dd47ac..2aea470 100644 --- a/src/Xmobar/X11/Bitmap.hs +++ b/src/Xmobar/X11/Bitmap.hs @@ -24,8 +24,8 @@ import System.Directory (doesFileExist) import System.FilePath (()) import System.Mem.Weak ( addFinalizer ) import Xmobar.Run.Actions (Action) +import Xmobar.Run.Parsers (TextRenderInfo(..), Widget(..)) import Xmobar.X11.ColorCache -import Xmobar.X11.Parsers (TextRenderInfo(..), Widget(..)) #ifdef XPM import Xmobar.X11.XPMFile(readXPMFile) diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index 30f0b75..6a9a5d8 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -33,12 +33,12 @@ import Graphics.X11.Xlib.Extras import Xmobar.Config.Types import Xmobar.Run.Actions (Action(..)) +import Xmobar.Run.Parsers hiding (parseString) import qualified Xmobar.X11.Bitmap as B import Xmobar.X11.Types import Xmobar.X11.Text import Xmobar.X11.ColorCache import Xmobar.X11.Window (drawBorder) -import Xmobar.X11.Parsers hiding (parseString) import Xmobar.System.Utils (safeIndex) #ifdef XFT diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs deleted file mode 100644 index 4a7e4eb..0000000 --- a/src/Xmobar/X11/Parsers.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.X11.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : portable --- --- Parsing for template substrings --- ------------------------------------------------------------------------------ - -module Xmobar.X11.Parsers ( parseString - , colorComponents - , Segment - , Box(..) - , BoxBorder(..) - , BoxOffset(..) - , BoxMargins(..) - , TextRenderInfo(..) - , Widget(..)) where - -import Control.Monad (guard, mzero) -import Data.Maybe (fromMaybe) -import Data.Int (Int32) -import Text.ParserCombinators.Parsec -import Text.Read (readMaybe) -import Foreign.C.Types (CInt) - -import Xmobar.Config.Types -import Xmobar.Run.Actions - -data Widget = Icon String | Text String | Hspace Int32 deriving Show - -data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) --- margins: Top, Right, Bottom, Left -data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show) -data BoxBorder = BBTop - | BBBottom - | BBVBoth - | BBLeft - | BBRight - | BBHBoth - | BBFull - deriving ( Read, Eq, Show ) -data Box = Box BoxBorder BoxOffset CInt String BoxMargins deriving (Eq, Show) -data TextRenderInfo = - TextRenderInfo { tColorsString :: String - , tBgTopOffset :: Int32 - , tBgBottomOffset :: Int32 - , tBoxes :: [Box] - } deriving Show -type FontIndex = Int - -type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) - --- | Runs the string parser -parseString :: Config -> String -> IO [Segment] -parseString c s = - case parse (stringParser ci 0 Nothing) "" s of - Left _ -> return [(Text $ "Could not parse string: " ++ s - , ci - , 0 - , Nothing)] - Right x -> return (concat x) - where ci = TextRenderInfo (fgColor c) 0 0 [] - --- | Splits a colors string into its two components -colorComponents :: Config -> String -> (String, String) -colorComponents conf c = - case break (==',') c of - (f,',':b) -> (f, b) - (f, _) -> (f, bgColor conf) - -allParsers :: TextRenderInfo - -> FontIndex - -> Maybe [Action] - -> Parser [Segment] -allParsers c f a = textParser c f a - <|> try (iconParser c f a) - <|> try (hspaceParser c f a) - <|> try (rawParser c f a) - <|> try (actionParser c f a) - <|> try (fontParser c a) - <|> try (boxParser c f a) - <|> colorParser c f a - --- | Gets the string and combines the needed parsers -stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [[Segment]] -stringParser c f a = manyTill (allParsers c f a) eof - --- | Parses a maximal string without markup. -textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -textParser c f a = do s <- many1 $ - noneOf "<" <|> - try (notFollowedBy' (char '<') - (try (string "fc=") <|> - try (string "box") <|> - try (string "fn=") <|> - try (string "action=") <|> - try (string "/action>") <|> - try (string "icon=") <|> - try (string "hspace=") <|> - try (string "raw=") <|> - try (string "/fn>") <|> - try (string "/box>") <|> - string "/fc>")) - return [(Text s, c, f, a)] - --- | Parse a "raw" tag, which we use to prevent other tags from creeping in. --- The format here is net-string-esque: a literal "". -rawParser :: TextRenderInfo - -> FontIndex - -> Maybe [Action] - -> Parser [Segment] -rawParser c f a = do - string " do - guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) - s <- count (fromIntegral len) anyChar - string "/>" - return [(Text s, c, f, a)] - _ -> mzero - --- | Wrapper for notFollowedBy that returns the result of the first parser. --- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy --- accepts only parsers with return type Char. -notFollowedBy' :: Parser a -> Parser b -> Parser a -notFollowedBy' p e = do x <- p - notFollowedBy $ try (e >> return '*') - return x - -iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -iconParser c f a = do - string "") (try (string "/>")) - return [(Icon i, c, f, a)] - -hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -hspaceParser c f a = do - string "")) - return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] - -actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -actionParser c f act = do - string "")] - buttons <- (char '>' >> return "1") <|> (space >> spaces >> - between (string "button=") (string ">") (many1 (oneOf "12345"))) - let a = Spawn (toButtons buttons) command - a' = case act of - Nothing -> Just [a] - Just act' -> Just $ a : act' - s <- manyTill (allParsers c f a') (try $ string "") - return (concat s) - -toButtons :: String -> [Button] -toButtons = map (\x -> read [x]) - --- | Parsers a string wrapped in a color specification. -colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -colorParser (TextRenderInfo _ _ _ bs) f a = do - c <- between (string "") colors - let colorParts = break (==':') c - let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of - (top,',':btm) -> (top, btm) - (top, _) -> (top, top) - s <- manyTill - (allParsers (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob) bs) f a) - (try $ string "") - return (concat s) - --- | Parses a string wrapped in a box specification. -boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -boxParser (TextRenderInfo cs ot ob bs) f a = do - c <- between (string "") (option "" (many1 (alphaNum <|> char '=' <|> char ' ' <|> char '#' <|> char ','))) - let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0) - let g = boxReader b (words c) - s <- manyTill - (allParsers (TextRenderInfo cs ot ob (g : bs)) f a) - (try $ string "") - return (concat s) - -boxReader :: Box -> [String] -> Box -boxReader b [] = b -boxReader b (x:xs) = do - let (param,val) = case break (=='=') x of - (p,'=':v) -> (p, v) - (p, _) -> (p, "") - boxReader (boxParamReader b param val) xs - -boxParamReader :: Box -> String -> String -> Box -boxParamReader b _ "" = b -boxParamReader (Box bb off lw fc mgs) "type" val = - Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs -boxParamReader (Box bb (BoxOffset alg off) lw fc mgs) "offset" (a:o) = - Box bb (BoxOffset (fromMaybe alg $ readMaybe [a]) (fromMaybe off $ readMaybe o)) lw fc mgs -boxParamReader (Box bb off lw fc mgs) "width" val = - Box bb off (fromMaybe lw $ readMaybe val) fc mgs -boxParamReader (Box bb off lw _ mgs) "color" val = - Box bb off lw val mgs -boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = do - let mgs' = case pos of - "t" -> BoxMargins (fromMaybe mt $ readMaybe val) mr mb ml - "r" -> BoxMargins mt (fromMaybe mr $ readMaybe val) mb ml - "b" -> BoxMargins mt mr (fromMaybe mb $ readMaybe val) ml - "l" -> BoxMargins mt mr mb (fromMaybe ml $ readMaybe val) - _ -> mgs - Box bb off lw fc mgs' -boxParamReader b _ _ = b - --- | Parsers a string wrapped in a font specification. -fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [Segment] -fontParser c a = do - f <- between (string "") colors - s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#') diff --git a/xmobar.cabal b/xmobar.cabal index 962d6b1..f812872 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -115,6 +115,7 @@ library Xmobar.Run.Exec, Xmobar.Run.Runnable Xmobar.Run.Actions, + Xmobar.Run.Parsers, Xmobar.Run.Loop, Xmobar.App.X11EventLoop, Xmobar.App.TextEventLoop, @@ -129,7 +130,6 @@ library Xmobar.System.Signal, Xmobar.System.Kbd, Xmobar.X11.Events, - Xmobar.X11.Parsers, Xmobar.X11.Types, Xmobar.X11.Text, Xmobar.X11.Bitmap, -- cgit v1.2.3