{-# LANGUAGE DeriveGeneric #-}
module Xmobar.Text.Swaybar (prepare, formatSwaybar) where
import Data.Aeson
import Data.ByteString.Lazy.UTF8 (toString)
import GHC.Generics
import Xmobar.Config.Types ( Config (additionalFonts)
, Segment
, Widget(..)
, Box(..)
, BoxBorder(..)
, FontIndex
, tBoxes
, tColorsString)
import Xmobar.Config.Parse (colorComponents)
import Xmobar.Text.SwaybarClicks (startHandler)
import Xmobar.Text.Pango (withPangoFont)
data Preamble =
Preamble {Preamble -> FontIndex
version :: !Int, Preamble -> Bool
click_events :: Bool} deriving (Preamble -> Preamble -> Bool
(Preamble -> Preamble -> Bool)
-> (Preamble -> Preamble -> Bool) -> Eq Preamble
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Preamble -> Preamble -> Bool
== :: Preamble -> Preamble -> Bool
$c/= :: Preamble -> Preamble -> Bool
/= :: Preamble -> Preamble -> Bool
Eq,FontIndex -> Preamble -> ShowS
[Preamble] -> ShowS
Preamble -> String
(FontIndex -> Preamble -> ShowS)
-> (Preamble -> String) -> ([Preamble] -> ShowS) -> Show Preamble
forall a.
(FontIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: FontIndex -> Preamble -> ShowS
showsPrec :: FontIndex -> Preamble -> ShowS
$cshow :: Preamble -> String
show :: Preamble -> String
$cshowList :: [Preamble] -> ShowS
showList :: [Preamble] -> ShowS
Show,(forall x. Preamble -> Rep Preamble x)
-> (forall x. Rep Preamble x -> Preamble) -> Generic Preamble
forall x. Rep Preamble x -> Preamble
forall x. Preamble -> Rep Preamble x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Preamble -> Rep Preamble x
from :: forall x. Preamble -> Rep Preamble x
$cto :: forall x. Rep Preamble x -> Preamble
to :: forall x. Rep Preamble x -> Preamble
Generic)
asString :: ToJSON a => a -> String
asString :: forall a. ToJSON a => a -> String
asString = ByteString -> String
toString (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode
preamble :: String
preamble :: String
preamble = (Preamble -> String
forall a. ToJSON a => a -> String
asString (Preamble -> String) -> Preamble -> String
forall a b. (a -> b) -> a -> b
$ Preamble { version :: FontIndex
version = FontIndex
1, click_events :: Bool
click_events = Bool
True }) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\x0A["
data Block =
Block { Block -> String
full_text :: !String
, Block -> String
name :: !String
, Block -> Maybe String
color :: Maybe String
, Block -> Maybe String
background :: Maybe String
, Block -> Bool
separator :: !Bool
, Block -> FontIndex
separator_block_width :: !Int
, Block -> Maybe String
border :: Maybe String
, Block -> Maybe FontIndex
border_top :: Maybe Int
, Block -> Maybe FontIndex
border_bottom :: Maybe Int
, Block -> Maybe FontIndex
border_left :: Maybe Int
, Block -> Maybe FontIndex
border_right :: Maybe Int
, Block -> Maybe String
markup :: Maybe String
} deriving (Block -> Block -> Bool
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
/= :: Block -> Block -> Bool
Eq,FontIndex -> Block -> ShowS
[Block] -> ShowS
Block -> String
(FontIndex -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(FontIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: FontIndex -> Block -> ShowS
showsPrec :: FontIndex -> Block -> ShowS
$cshow :: Block -> String
show :: Block -> String
$cshowList :: [Block] -> ShowS
showList :: [Block] -> ShowS
Show,(forall x. Block -> Rep Block x)
-> (forall x. Rep Block x -> Block) -> Generic Block
forall x. Rep Block x -> Block
forall x. Block -> Rep Block x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Block -> Rep Block x
from :: forall x. Block -> Rep Block x
$cto :: forall x. Rep Block x -> Block
to :: forall x. Rep Block x -> Block
Generic)
defaultBlock :: Block
defaultBlock :: Block
defaultBlock = Block { full_text :: String
full_text = String
""
, name :: String
name = String
""
, color :: Maybe String
color = Maybe String
forall a. Maybe a
Nothing
, background :: Maybe String
background = Maybe String
forall a. Maybe a
Nothing
, separator :: Bool
separator = Bool
False
, separator_block_width :: FontIndex
separator_block_width = FontIndex
0
, border :: Maybe String
border = Maybe String
forall a. Maybe a
Nothing
, border_top :: Maybe FontIndex
border_top = Maybe FontIndex
forall a. Maybe a
Nothing
, border_bottom :: Maybe FontIndex
border_bottom = Maybe FontIndex
forall a. Maybe a
Nothing
, border_left :: Maybe FontIndex
border_left = Maybe FontIndex
forall a. Maybe a
Nothing
, border_right :: Maybe FontIndex
border_right = Maybe FontIndex
forall a. Maybe a
Nothing
, markup :: Maybe String
markup = Maybe String
forall a. Maybe a
Nothing
}
instance ToJSON Block where
toJSON :: Block -> Value
toJSON = Options -> Block -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
{ omitNothingFields = True }
instance ToJSON Preamble
withBox :: Box -> Block -> Block
withBox :: Box -> Block -> Block
withBox (Box BoxBorder
b BoxOffset
_ CInt
n String
c BoxMargins
_) Block
block =
(case BoxBorder
b of
BoxBorder
BBFull -> Block
bl { border_right = w, border_left = w
, border_bottom = w, border_top = w }
BoxBorder
BBTop -> Block
bl { border_top = w }
BoxBorder
BBBottom -> Block
bl { border_bottom = w }
BoxBorder
BBVBoth -> Block
bl { border_bottom = w, border_top = w }
BoxBorder
BBLeft -> Block
bl { border_left = w }
BoxBorder
BBRight -> Block
bl { border_right = w }
BoxBorder
BBHBoth -> Block
bl { border_right = w, border_left = w }
) { border = bc }
where w :: Maybe FontIndex
w = FontIndex -> Maybe FontIndex
forall a. a -> Maybe a
Just (CInt -> FontIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)
bc :: Maybe String
bc = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
c then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
c
j0 :: Maybe FontIndex
j0 = FontIndex -> Maybe FontIndex
forall a. a -> Maybe a
Just FontIndex
0
bl :: Block
bl = Block
block { border_right = j0, border_left = j0
, border_bottom = j0, border_top = j0 }
withFont :: Config -> FontIndex -> Block -> Block
withFont :: Config -> FontIndex -> Block -> Block
withFont Config
conf FontIndex
idx Block
block =
if FontIndex
idx FontIndex -> FontIndex -> Bool
forall a. Ord a => a -> a -> Bool
< FontIndex
1 Bool -> Bool -> Bool
|| FontIndex
idx FontIndex -> FontIndex -> Bool
forall a. Ord a => a -> a -> Bool
> [String] -> FontIndex
forall a. [a] -> FontIndex
forall (t :: * -> *) a. Foldable t => t a -> FontIndex
length [String]
fonts then Block
block
else Block
block { markup = Just $ fonts !! (idx - 1) }
where fonts :: [String]
fonts = Config -> [String]
additionalFonts Config
conf
withPango :: Block -> Block
withPango :: Block -> Block
withPango Block
block = case Block -> Maybe String
markup Block
block of
Maybe String
Nothing -> Block
block
Just String
fnt -> Block
block { full_text = txt fnt, markup = Just "pango"}
where txt :: ShowS
txt String
fn = String -> ShowS
withPangoFont String
fn (Block -> String
full_text Block
block)
formatSwaybar' :: Config -> Segment -> Block
formatSwaybar' :: Config -> Segment -> Block
formatSwaybar' Config
conf (Text String
txt, TextRenderInfo
info, FontIndex
idx, Maybe [Action]
as) =
(Box -> Block -> Block) -> Block -> [Box] -> Block
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Box -> Block -> Block
withBox (Config -> FontIndex -> Block -> Block
withFont Config
conf FontIndex
idx Block
block) (TextRenderInfo -> [Box]
tBoxes TextRenderInfo
info)
where (String
fg, String
bg) = Config -> String -> (String, String)
colorComponents Config
conf (TextRenderInfo -> String
tColorsString TextRenderInfo
info)
block :: Block
block = Block
defaultBlock { full_text = txt
, color = Just fg
, background = Just bg
, name = show as
}
formatSwaybar' Config
conf (Hspace Int32
n, TextRenderInfo
info, FontIndex
i, Maybe [Action]
a) =
Config -> Segment -> Block
formatSwaybar' Config
conf (String -> Widget
Text (FontIndex -> Char -> String
forall a. FontIndex -> a -> [a]
replicate (Int32 -> FontIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) Char
' '), TextRenderInfo
info, FontIndex
i, Maybe [Action]
a)
formatSwaybar' Config
_ Segment
_ = Block
defaultBlock
collectBlock :: Block -> [Block] -> [Block]
collectBlock :: Block -> [Block] -> [Block]
collectBlock Block
b [] = [Block
b]
collectBlock Block
b (Block
h:[Block]
bs) =
if Block
b {full_text = ""} Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
== Block
h {full_text = ""} then
Block
h {full_text = full_text b ++ full_text h} Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
bs
else Block
bBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:Block
hBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
bs
collectSegment :: Config -> Segment -> [Block] -> [Block]
collectSegment :: Config -> Segment -> [Block] -> [Block]
collectSegment Config
config Segment
segment [Block]
blocks =
if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Block -> String
full_text Block
b then [Block]
blocks else Block -> [Block] -> [Block]
collectBlock Block
b [Block]
blocks
where b :: Block
b = Config -> Segment -> Block
formatSwaybar' Config
config Segment
segment
formatSwaybar :: Config -> [Segment] -> String
formatSwaybar :: Config -> [Segment] -> String
formatSwaybar Config
conf [Segment]
segs = [Block] -> String
forall a. ToJSON a => a -> String
asString ((Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Block
withPango [Block]
blocks) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
","
where blocks :: [Block]
blocks = (Segment -> [Block] -> [Block]) -> [Block] -> [Segment] -> [Block]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Config -> Segment -> [Block] -> [Block]
collectSegment Config
conf) [] [Segment]
segs
prepare :: IO ()
prepare :: IO ()
prepare = IO ()
startHandler IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
preamble