3 files changed, 255 insertions, 1 deletions

diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs
index 16af3db..23de4db 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
diff --git a/src/Xmobar/Config/Template.hs b/src/Xmobar/Config/Template.hs
new file mode 100644
index 0000000..28ccbe1
--- /dev/null
+++ b/src/Xmobar/Config/Template.hs
@@ -0,0 +1,200 @@
+------------------------------------------------------------------------------
+-- |
+-- 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 Control.Monad (guard, mzero)
+import Data.Maybe (fromMaybe)
+
+import Text.Parsec ((<|>))
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Combinator as C
+import Text.ParserCombinators.Parsec (Parser)
+
+import Text.Read (readMaybe)
+
+import Xmobar.Config.Types
+
+-- | Runs the template string parser
+parseString :: Config -> String -> IO [Segment]
+parseString c s =
+    case P.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 []
+
+allParsers :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]
+allParsers c f a =  textParser c f a
+                <|> P.try (iconParser c f a)
+                <|> P.try (hspaceParser c f a)
+                <|> P.try (rawParser c f a)
+                <|> P.try (actionParser c f a)
+                <|> P.try (fontParser c a)
+                <|> P.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 = C.manyTill (allParsers c f a) C.eof
+
+-- | Parses a maximal string without markup.
+textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]
+textParser c f a = do s <- C.many1 $
+                            P.noneOf "<" <|>
+                              P.try (notFollowedBy' (P.char '<')
+                                    (P.try (P.string "fc=")  <|>
+                                     P.try (P.string "box")  <|>
+                                     P.try (P.string "fn=")  <|>
+                                     P.try (P.string "action=") <|>
+                                     P.try (P.string "/action>") <|>
+                                     P.try (P.string "icon=") <|>
+                                     P.try (P.string "hspace=") <|>
+                                     P.try (P.string "raw=") <|>
+                                     P.try (P.string "/fn>") <|>
+                                     P.try (P.string "/box>") <|>
+                                     P.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 "<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 :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]
+rawParser c f a = do
+  P.string "<raw="
+  lenstr <- C.many1 P.digit
+  P.char ':'
+  case reads lenstr of
+    [(len,[])] -> do
+      guard ((len :: Integer) <= fromIntegral (maxBound :: Int))
+      s <- C.count (fromIntegral len) P.anyChar
+      P.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
+                        C.notFollowedBy $ P.try (e >> return '*')
+                        return x
+
+iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]
+iconParser c f a = do
+  P.string "<icon="
+  i <- C.manyTill (P.noneOf ">") (P.try (P.string "/>"))
+  return [(Icon i, c, f, a)]
+
+hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]
+hspaceParser c f a = do
+  P.string "<hspace="
+  pVal <- C.manyTill P.digit (P.try (P.string "/>"))
+  return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)]
+
+actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]
+actionParser c f act = do
+  P.string "<action="
+  command <- C.choice [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 = Spawn (toButtons buttons) command
+      a' = case act of
+        Nothing -> Just [a]
+        Just act' -> Just $ a : act'
+  s <- C.manyTill (allParsers c f a') (P.try $ P.string "</action>")
+  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) fidx a = do
+  c <- C.between (P.string "<fc=") (P.string ">") colors
+  let colorParts = break (==':') c
+  let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of
+                  (top,',':btm) -> (top, btm)
+                  (top,      _) -> (top, top)
+      tri = 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)
+
+-- | 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 <- C.between (P.string "<box") (P.string ">")
+               (C.option "" (C.many1 (P.alphaNum
+                                  <|> P.char '='
+                                  <|> P.char ' '
+                                  <|> P.char '#'
+                                  <|> P.char ',')))
+  let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0)
+  let g = boxReader b (words c)
+  s <- C.manyTill
+       (allParsers (TextRenderInfo cs ot ob (g : bs)) f a)
+       (P.try $ P.string "</box>")
+  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 align offset) lw fc mgs
+  where offset = fromMaybe off $ readMaybe o
+        align = fromMaybe alg $ readMaybe [a]
+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 <- C.between (P.string "<fn=") (P.string ">") colors
+  s <- C.manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (P.try $ P.string "</fn>")
+  return (concat s)
+
+-- | Parses a color specification (hex or named)
+colors :: Parser String
+colors = C.many1 (P.alphaNum <|> P.char ',' <|> P.char ':' <|> P.char '#')
diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs
index 4959aa1..df39f6d 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
 
@@ -110,3 +124,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])