summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Config
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/Config')
-rw-r--r--src/Xmobar/Config/Parse.hs16
-rw-r--r--src/Xmobar/Config/Template.hs188
-rw-r--r--src/Xmobar/Config/Types.hs141
3 files changed, 331 insertions, 14 deletions
diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs
index 16af3db..0b41267 100644
--- a/src/Xmobar/Config/Parse.hs
+++ b/src/Xmobar/Config/Parse.hs
@@ -19,7 +19,8 @@
module Xmobar.Config.Parse(readConfig
, parseConfig
, indexedFont
- , indexedOffset) where
+ , indexedOffset
+ , colorComponents) where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Number (int)
@@ -31,6 +32,14 @@ import Xmobar.Config.Types
import qualified System.IO as S (readFile)
+-- | 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)
+
+
stripComments :: String -> String
stripComments =
unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines
@@ -63,7 +72,7 @@ parseConfig defaultConfig =
<|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest
<|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot
<|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate
- <|?> pVerbose <|?> pSignal
+ <|?> pVerbose <|?> pSignal <|?> pDpi
fields = [ "font", "additionalFonts", "bgColor", "fgColor"
, "wmClass", "wmName", "sepChar"
@@ -72,7 +81,7 @@ parseConfig defaultConfig =
, "allDesktops", "overrideRedirect", "pickBroadest"
, "hideOnStart", "lowerOnStart", "persistent", "iconRoot"
, "alpha", "commands", "verbose", "signal", "textOutput"
- , "textOutputFormat"
+ , "textOutputFormat", "dpi"
]
pTextOutput = readField textOutput "textOutput"
@@ -103,6 +112,7 @@ parseConfig defaultConfig =
pIconRoot = readField iconRoot "iconRoot"
pAlpha = readField alpha "alpha"
pVerbose = readField verbose "verbose"
+ pDpi = readField dpi "dpi"
pSignal = field signal "signal" $
fail "signal is meant for use with Xmobar as a library.\n It is not meant for use in the configuration file."
diff --git a/src/Xmobar/Config/Template.hs b/src/Xmobar/Config/Template.hs
new file mode 100644
index 0000000..ad30c3d
--- /dev/null
+++ b/src/Xmobar/Config/Template.hs
@@ -0,0 +1,188 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.Config.Template
+-- Copyright: (c) 2022 jao
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: mail@jao.io
+-- Stability: unstable
+-- Portability: portable
+-- Created: Fri Sep 30, 2022 06:33
+--
+--
+-- Parsing template strings
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Config.Template (parseString) where
+
+import Data.Maybe (fromMaybe)
+import qualified Control.Monad as CM
+
+import Text.Parsec ((<|>))
+import Text.Read (readMaybe)
+
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Combinator as C
+
+import Text.ParserCombinators.Parsec (Parser)
+
+import qualified Xmobar.Config.Types as T
+
+type Context = (T.TextRenderInfo, T.FontIndex, Maybe [T.Action])
+
+retSegment :: Context -> T.Widget -> Parser [T.Segment]
+retSegment (i, idx, as) widget = return [(widget, i, idx, as)]
+
+-- | Run the template string parser for the given config, producing a list of
+-- drawable segment specifications.
+parseString :: T.Config -> String -> [T.Segment]
+parseString c s =
+ case P.parse (stringParser ci) "" s of
+ Left _ -> [(T.Text $ "Could not parse string: " ++ s, ti, 0, Nothing)]
+ Right x -> concat x
+ where ci = (ti , 0, Nothing)
+ ti = T.TextRenderInfo (T.fgColor c) 0 0 []
+
+-- Top level parser reading the full template string
+stringParser :: Context -> Parser [[T.Segment]]
+stringParser c = C.manyTill (allParsers c) C.eof
+
+allParsers :: Context -> Parser [T.Segment]
+allParsers c = C.choice (textParser c:map (\f -> P.try (f c)) parsers)
+ where parsers = [ iconParser, hspaceParser, rawParser, actionParser
+ , fontParser, boxParser, colorParser ]
+
+-- 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
+ C.notFollowedBy $ P.try (e >> return '*')
+ return x
+
+-- Parse a maximal string without markup
+textParser :: Context -> Parser [T.Segment]
+textParser c =
+ C.many1 (P.noneOf "<" <|> P.try (notFollowedBy' (P.char '<') suffixes))
+ >>= retSegment c . T.Text
+ where suffixes = C.choice $ map (P.try . P.string)
+ [ "icon=" , "hspace=", "raw="
+ , "action=", "/action>", "fn=", "/fn>"
+ , "box", "/box>", "fc=", "/fc>" ]
+
+-- Parse a "raw" tag, which we use to prevent other tags from creeping in.
+-- The format here is net-string-esque: a literal "<raw=" followed by a string
+-- of digits (base 10) denoting the length of the raw string, a literal ":" as
+-- digit-string-terminator, the raw string itself, and then a literal "/>".
+rawParser :: Context -> Parser [T.Segment]
+rawParser c = do
+ P.string "<raw="
+ lenstr <- C.many1 P.digit
+ P.char ':'
+ case reads lenstr of
+ [(len,[])] -> do
+ CM.guard ((len :: Integer) <= fromIntegral (maxBound :: Int))
+ s <- C.count (fromIntegral len) P.anyChar
+ P.string "/>"
+ retSegment c (T.Text s)
+ _ -> CM.mzero
+
+iconParser :: Context -> Parser [T.Segment]
+iconParser c = do
+ P.string "<icon="
+ i <- C.manyTill (P.noneOf ">") (P.try (P.string "/>"))
+ retSegment c (T.Icon i)
+
+hspaceParser :: Context -> Parser [T.Segment]
+hspaceParser c = do
+ P.string "<hspace="
+ pVal <- C.manyTill P.digit (P.try (P.string "/>"))
+ retSegment c (T.Hspace (fromMaybe 0 $ readMaybe pVal))
+
+actionParser :: Context -> Parser [T.Segment]
+actionParser (ti, fi, act) = do
+ P.string "<action="
+ command <- C.between (P.char '`') (P.char '`') (C.many1 (P.noneOf "`"))
+ <|> C.many1 (P.noneOf ">")
+ buttons <- (P.char '>' >> return "1") <|> (P.space >> P.spaces >>
+ C.between (P.string "button=") (P.string ">") (C.many1 (P.oneOf "12345")))
+ let a = T.Spawn (toButtons buttons) command
+ a' = case act of
+ Nothing -> Just [a]
+ Just act' -> Just $ a : act'
+ s <- C.manyTill (allParsers (ti, fi, a')) (P.try $ P.string "</action>")
+ return (concat s)
+
+toButtons :: String -> [T.Button]
+toButtons = map (\x -> read [x])
+
+colorParser :: Context -> Parser [T.Segment]
+colorParser (T.TextRenderInfo _ _ _ bs, fidx, a) = do
+ c <- C.between (P.string "<fc=") (P.string ">") (C.many1 colorc)
+ let colorParts = break (==':') c
+ let (ot,ob) = case break (==',') (drop 1 $ snd colorParts) of
+ (top,',':btm) -> (top, btm)
+ (top, _) -> (top, top)
+ tri = T.TextRenderInfo (fst colorParts)
+ (fromMaybe (-1) $ readMaybe ot)
+ (fromMaybe (-1) $ readMaybe ob)
+ bs
+ s <- C.manyTill (allParsers (tri, fidx, a)) (P.try $ P.string "</fc>")
+ return (concat s)
+ where colorc = P.alphaNum <|> P.oneOf ",:#"
+
+boxParser :: Context -> Parser [T.Segment]
+boxParser (T.TextRenderInfo cs ot ob bs, f, a) = do
+ c <- C.between (P.string "<box") (P.string ">")
+ (C.option "" (C.many1 (P.alphaNum <|> P.oneOf "= #,")))
+ let b = T.Box T.BBFull (T.BoxOffset T.C 0) 1 cs (T.BoxMargins 0 0 0 0)
+ let g = boxReader b (words c)
+ s <- C.manyTill
+ (allParsers (T.TextRenderInfo cs ot ob (g : bs), f, a))
+ (P.try $ P.string "</box>")
+ return (concat s)
+
+boxReader :: T.Box -> [String] -> T.Box
+boxReader b [] = b
+boxReader b (x:xs) = boxReader (boxParamReader b param val) xs
+ where (param,val) = case break (=='=') x of
+ (p,'=':v) -> (p, v)
+ (p, _) -> (p, "")
+
+boxParamReader :: T.Box -> String -> String -> T.Box
+boxParamReader b _ "" = b
+
+boxParamReader (T.Box bb off lw fc mgs) "type" val =
+ T.Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs
+
+boxParamReader (T.Box bb (T.BoxOffset alg off) lw fc mgs) "offset" (a:o) =
+ T.Box bb (T.BoxOffset align offset) lw fc mgs
+ where offset = fromMaybe off $ readMaybe o
+ align = fromMaybe alg $ readMaybe [a]
+
+boxParamReader (T.Box bb off lw fc mgs) "width" val =
+ T.Box bb off (fromMaybe lw $ readMaybe val) fc mgs
+
+boxParamReader (T.Box bb off lw _ mgs) "color" val =
+ T.Box bb off lw val mgs
+
+boxParamReader (T.Box bb off lw fc mgs@(T.BoxMargins mt mr mb ml)) ('m':pos) v =
+ let mgs' = case pos of
+ "t" -> T.BoxMargins (maybeVal mt) mr mb ml
+ "r" -> T.BoxMargins mt (maybeVal mr) mb ml
+ "b" -> T.BoxMargins mt mr (maybeVal mb) ml
+ "l" -> T.BoxMargins mt mr mb (maybeVal ml)
+ _ -> mgs
+ maybeVal d = fromMaybe d (readMaybe v)
+ in T.Box bb off lw fc mgs'
+
+boxParamReader b _ _ = b
+
+fontParser :: Context -> Parser [T.Segment]
+fontParser (i, _, a) = do
+ f <- C.between (P.string "<fn=") (P.string ">") (C.many1 P.digit)
+ s <- C.manyTill (allParsers (i, fromMaybe 0 $ readMaybe f, a))
+ (P.try $ P.string "</fn>")
+ return (concat s)
diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs
index 4959aa1..785b55b 100644
--- a/src/Xmobar/Config/Types.hs
+++ b/src/Xmobar/Config/Types.hs
@@ -15,14 +15,28 @@
module Xmobar.Config.Types
( Config (..)
, XPosition (..), Align (..), Border (..), TextOutputFormat (..)
+ , Segment
, FontIndex
+ , Box(..)
+ , BoxBorder(..)
+ , BoxOffset(..)
+ , BoxMargins(..)
+ , TextRenderInfo(..)
+ , Widget(..)
, SignalChan (..)
+ , Action (..)
+ , Button
) where
import qualified Control.Concurrent.STM as STM
import qualified Xmobar.Run.Runnable as R
import qualified Xmobar.System.Signal as S
+import Data.Int (Int32)
+import Foreign.C.Types (CInt)
+
+import Xmobar.Run.Actions (Action (..), Button)
+
-- $config
-- Configuration data type
@@ -71,20 +85,94 @@ data Config =
, template :: String -- ^ The output template
, verbose :: Bool -- ^ Emit additional debug messages
, signal :: SignalChan -- ^ Channel to send signals to xmobar
+ , dpi :: Double -- ^ DPI scaling factor for fonts
} deriving (Read, Show)
-data XPosition = Top
- | TopH Int
- | TopW Align Int
- | TopSize Align Int Int
- | TopP Int Int
+-- | The position datatype
+data XPosition = Top -- ^ Top of the screen, full width, auto height
+
+ | TopH -- ^ Top of the screen, full width with
+ -- specific height
+ Int -- ^ Height (in pixels)
+
+ -- | Top of the screen, full width with
+ -- specific height and margins
+ | TopHM
+ Int -- ^ Height (in pixels)
+ Int -- ^ Left margin (in pixels)
+ Int -- ^ Right margin (in pixels)
+ Int -- ^ Top margin (in pixels)
+ Int -- ^ Bottom margin (in pixels)
+
+ -- | Top of the screen with specific width
+ -- (as screen percentage) and alignment
+ | TopW
+ Align -- ^ Alignement (L|C|R)
+ Int -- ^ Width as screen percentage (0-100)
+
+ -- | Top of the screen with specific width
+ -- (as screen percentage), height and
+ -- alignment
+ | TopSize
+ Align -- ^ Alignement (L|C|R)
+ Int -- ^ Width as screen percentage (0-100)
+ Int -- ^ Height (in pixels)
+
+ -- | Top of the screen with specific left/right
+ -- margins
+ | TopP
+ Int -- ^ Left margin (in pixels)
+ Int -- ^ Right margin (in pixels)
+
+ -- | Bottom of the screen, full width, auto height
| Bottom
- | BottomH Int
- | BottomP Int Int
- | BottomW Align Int
- | BottomSize Align Int Int
- | Static {xpos, ypos, width, height :: Int}
- | OnScreen Int XPosition
+
+ | BottomH -- ^ Bottom of the screen, full width, with
+ -- specific height
+ Int -- ^ Height (in pixels)
+
+ -- | Bottom of the screen with specific height
+ -- and margins
+ | BottomHM
+ Int -- ^ Height (in pixels)
+ Int -- ^ Left margin (in pixels)
+ Int -- ^ Right margin (in pixels)
+ Int -- ^ Top margin (in pixels)
+ Int -- ^ Bottom margin (in pixels)
+
+ -- | Bottom of the screen with specific
+ -- left/right margins
+ | BottomP
+ Int -- ^ Left margin (in pixels)
+ Int -- ^ Bottom margin (in pixels)
+
+ -- | Bottom of the screen with specific width
+ -- (as screen percentage) and alignment
+ -- and alignment
+ | BottomW
+ Align -- ^ Alignement (L|C|R)
+ Int -- ^ Width as screen percentage (0-100)
+
+ -- | Bottom of the screen with specific width
+ -- (as screen percentage), height
+ -- and alignment
+ | BottomSize
+ Align -- ^ Alignement (L|C|R)
+ Int -- ^ Width as screen percentage (0-100)
+ Int -- ^ Height (in pixels)
+
+ -- | Static position and specific size
+ | Static { xpos :: Int -- ^ Position X (in pixels)
+ , ypos :: Int -- ^ Position Y (in pixels)
+ , width :: Int -- ^ Width (in pixels)
+ , height :: Int -- ^ Height (in pixels)
+ }
+
+ -- | Along with the position characteristics
+ -- specify the screen to display the bar
+ | OnScreen
+ Int -- ^ Screen id (primary is 0)
+ XPosition -- ^ Position
deriving ( Read, Show, Eq )
data Align = L | R | C deriving ( Read, Show, Eq )
@@ -110,3 +198,34 @@ instance Read SignalChan where
instance Show SignalChan where
show (SignalChan (Just _)) = "SignalChan (Just <tmvar>)"
show (SignalChan Nothing) = "SignalChan Nothing"
+
+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 { bBorder :: BoxBorder
+ , bOffset :: BoxOffset
+ , bWidth :: CInt
+ , bColor :: String
+ , bMargins :: BoxMargins
+ } deriving (Eq, Show)
+
+data TextRenderInfo = TextRenderInfo { tColorsString :: String
+ , tBgTopOffset :: Int32
+ , tBgBottomOffset :: Int32
+ , tBoxes :: [Box]
+ } deriving Show
+
+type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action])
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-06 02:43:32 +0000