{-# 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)
                           , 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