{-# LANGUAGE DeriveGeneric #-}

------------------------------------------------------------------------------
-- |
-- Module: Xmobar.Text.Swaybar
-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: portable
-- Created: Fri Feb 4, 2022 03:58
--
--
-- Segment codification using swaybar-protocol JSON strings
--
------------------------------------------------------------------------------

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))

import Xmobar.Run.Parsers ( Segment
                          , Widget(..)
                          , Box(..)
                          , BoxBorder(..)
                          , FontIndex
                          , tBoxes
                          , tColorsString
                          , colorComponents)

import Xmobar.Text.SwaybarClicks (startHandler)
import Xmobar.Text.Pango (withPangoFont)

data Preamble =
  Preamble {Preamble -> Int
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
/= :: Preamble -> Preamble -> Bool
$c/= :: Preamble -> Preamble -> Bool
== :: Preamble -> Preamble -> Bool
$c== :: Preamble -> Preamble -> Bool
Eq,Int -> Preamble -> ShowS
[Preamble] -> ShowS
Preamble -> String
(Int -> Preamble -> ShowS)
-> (Preamble -> String) -> ([Preamble] -> ShowS) -> Show Preamble
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Preamble] -> ShowS
$cshowList :: [Preamble] -> ShowS
show :: Preamble -> String
$cshow :: Preamble -> String
showsPrec :: Int -> Preamble -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep Preamble x -> Preamble
$cfrom :: forall x. Preamble -> Rep Preamble x
Generic)

asString :: ToJSON a => a -> String
asString :: 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 :: Int -> Bool -> Preamble
Preamble { version :: Int
version = Int
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 -> Int
separator_block_width :: !Int
        , Block -> Maybe String
border :: Maybe String
        , Block -> Maybe Int
border_top :: Maybe Int
        , Block -> Maybe Int
border_bottom :: Maybe Int
        , Block -> Maybe Int
border_left :: Maybe Int
        , Block -> Maybe Int
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
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq,Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep Block x -> Block
$cfrom :: forall x. Block -> Rep Block x
Generic)


defaultBlock :: Block
defaultBlock :: Block
defaultBlock = Block :: String
-> String
-> Maybe String
-> Maybe String
-> Bool
-> Int
-> Maybe String
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe String
-> Block
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 :: Int
separator_block_width = Int
0
                     , border :: Maybe String
border = Maybe String
forall a. Maybe a
Nothing
                     , border_top :: Maybe Int
border_top = Maybe Int
forall a. Maybe a
Nothing
                     , border_bottom :: Maybe Int
border_bottom = Maybe Int
forall a. Maybe a
Nothing
                     , border_left :: Maybe Int
border_left = Maybe Int
forall a. Maybe a
Nothing
                     , border_right :: Maybe Int
border_right = Maybe Int
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 :: Bool
omitNothingFields = Bool
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 :: Maybe Int
border_right = Maybe Int
w, border_left :: Maybe Int
border_left = Maybe Int
w
                  , border_bottom :: Maybe Int
border_bottom = Maybe Int
w, border_top :: Maybe Int
border_top = Maybe Int
w  }
     BoxBorder
BBTop -> Block
bl { border_top :: Maybe Int
border_top = Maybe Int
w }
     BoxBorder
BBBottom -> Block
bl { border_bottom :: Maybe Int
border_bottom = Maybe Int
w }
     BoxBorder
BBVBoth -> Block
bl { border_bottom :: Maybe Int
border_bottom = Maybe Int
w, border_top :: Maybe Int
border_top = Maybe Int
w }
     BoxBorder
BBLeft -> Block
bl { border_left :: Maybe Int
border_left = Maybe Int
w }
     BoxBorder
BBRight -> Block
bl { border_right :: Maybe Int
border_right = Maybe Int
w }
     BoxBorder
BBHBoth -> Block
bl { border_right :: Maybe Int
border_right = Maybe Int
w, border_left :: Maybe Int
border_left = Maybe Int
w }
  ) { border :: Maybe String
border = Maybe String
bc }
  where w :: Maybe Int
w = Int -> Maybe Int
forall a. a -> Maybe a
Just (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)
        bc :: Maybe String
bc = if String -> 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 Int
j0 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
        bl :: Block
bl = Block
block { border_right :: Maybe Int
border_right = Maybe Int
j0, border_left :: Maybe Int
border_left = Maybe Int
j0
                   , border_bottom :: Maybe Int
border_bottom = Maybe Int
j0, border_top :: Maybe Int
border_top = Maybe Int
j0  }

withFont :: Config -> FontIndex -> Block -> Block
withFont :: Config -> Int -> Block -> Block
withFont Config
conf Int
idx Block
block =
  if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fonts then Block
block
  else Block
block { markup :: Maybe String
markup = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String]
fonts [String] -> Int -> String
forall a. [a] -> Int -> a
!! (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 :: String
full_text = ShowS
txt String
fnt, markup :: Maybe String
markup = String -> Maybe String
forall a. a -> Maybe a
Just String
"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, Int
idx, Maybe [Action]
as) =
  (Box -> Block -> Block) -> Block -> [Box] -> Block
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Box -> Block -> Block
withBox (Config -> Int -> Block -> Block
withFont Config
conf Int
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 :: String
full_text = String
txt
                             , color :: Maybe String
color = String -> Maybe String
forall a. a -> Maybe a
Just String
fg
                             , background :: Maybe String
background = String -> Maybe String
forall a. a -> Maybe a
Just String
bg
                             , name :: String
name = Maybe [Action] -> String
forall a. Show a => a -> String
show Maybe [Action]
as
                             }
formatSwaybar' Config
conf (Hspace Int32
n, TextRenderInfo
info, Int
i, Maybe [Action]
a) =
  Config -> Segment -> Block
formatSwaybar' Config
conf (String -> Widget
Text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) Char
' '), TextRenderInfo
info, Int
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 :: String
full_text = String
""} Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
== Block
h {full_text :: String
full_text = String
""} then
    Block
h {full_text :: String
full_text = Block -> String
full_text Block
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ Block -> String
full_text Block
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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
preamble