{-# LANGUAGE CPP #-}
module Xmobar.Draw.Cairo (drawSegments) where
import qualified Data.Colour.SRGB as SRGB
import qualified Data.Colour.Names as CNames
import Control.Monad (foldM, when)
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.Rendering.Pango as Pango
import Graphics.Rendering.Cairo.Types(Surface)
import qualified Xmobar.Config.Types as C
import qualified Xmobar.Config.Parse as ConfigParse
import qualified Xmobar.Text.Pango as TextPango
import qualified Xmobar.Draw.Boxes as Boxes
import qualified Xmobar.Draw.Types as T
type Renderinfo = (C.Segment, Surface -> Double -> Double -> IO (), Double)
type BoundedBox = (Double, Double, [C.Box])
type Acc = (Double, T.Actions, [BoundedBox])
readColourName :: String -> (SRGB.Colour Double, Double)
readColourName :: String -> (Colour Double, Double)
readColourName String
str =
case forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
String -> m (Colour a)
CNames.readColourName String
str of
Just Colour Double
c -> (Colour Double
c, Double
1.0)
Maybe (Colour Double)
Nothing -> case forall b. (Ord b, Floating b) => ReadS (Colour b)
SRGB.sRGB24reads String
str of
[(Colour Double
c, String
"")] -> (Colour Double
c, Double
1.0)
[(Colour Double
c,String
d)] -> (Colour Double
c, forall a. Read a => String -> a
read (String
"0x" forall a. [a] -> [a] -> [a]
++ String
d))
[(Colour Double, String)]
_ -> (forall a. (Ord a, Floating a) => Colour a
CNames.white, Double
1.0)
setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render ()
setSourceColor :: (Colour Double, Double) -> Render ()
setSourceColor (Colour Double
colour, Double
alph) =
if Double
alph forall a. Ord a => a -> a -> Bool
< Double
1 then Double -> Double -> Double -> Double -> Render ()
Cairo.setSourceRGBA Double
r Double
g Double
b Double
alph else Double -> Double -> Double -> Render ()
Cairo.setSourceRGB Double
r Double
g Double
b
where rgb :: RGB Double
rgb = forall b. (Ord b, Floating b) => Colour b -> RGB b
SRGB.toSRGB Colour Double
colour
r :: Double
r = forall a. RGB a -> a
SRGB.channelRed RGB Double
rgb
g :: Double
g = forall a. RGB a -> a
SRGB.channelGreen RGB Double
rgb
b :: Double
b = forall a. RGB a -> a
SRGB.channelBlue RGB Double
rgb
renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render ()
renderLines :: String -> Double -> [Line] -> Render ()
renderLines String
color Double
wd [Line]
lns = do
(Colour Double, Double) -> Render ()
setSourceColor (String -> (Colour Double, Double)
readColourName String
color)
Double -> Render ()
Cairo.setLineWidth Double
wd
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Double
x0, Double
y0, Double
x1, Double
y1) ->
Double -> Double -> Render ()
Cairo.moveTo Double
x0 Double
y0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Double -> Render ()
Cairo.lineTo Double
x1 Double
y1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
Cairo.stroke) [Line]
lns
segmentMarkup :: C.Config -> C.Segment -> String
segmentMarkup :: Config -> Segment -> String
segmentMarkup Config
conf (C.Text String
txt, TextRenderInfo
info, Int
idx, Maybe [Action]
_actions) =
let fnt :: String
fnt = String -> String
TextPango.fixXft forall a b. (a -> b) -> a -> b
$ Config -> Int -> String
ConfigParse.indexedFont Config
conf Int
idx
(String
fg, String
bg) = Config -> String -> (String, String)
ConfigParse.colorComponents Config
conf (TextRenderInfo -> String
C.tColorsString TextRenderInfo
info)
attrs :: [SpanAttribute]
attrs = [String -> SpanAttribute
Pango.FontDescr String
fnt, String -> SpanAttribute
Pango.FontForeground String
fg]
attrs' :: [SpanAttribute]
attrs' = if String
bg forall a. Eq a => a -> a -> Bool
== Config -> String
C.bgColor Config
conf
then [SpanAttribute]
attrs
else String -> SpanAttribute
Pango.FontBackground String
bgforall a. a -> [a] -> [a]
:[SpanAttribute]
attrs
in [SpanAttribute] -> String -> String
Pango.markSpan [SpanAttribute]
attrs' forall a b. (a -> b) -> a -> b
$ forall string. GlibString string => string -> string
Pango.escapeMarkup String
txt
segmentMarkup Config
_ Segment
_ = String
""
withRenderinfo :: Pango.PangoContext -> T.DrawContext -> C.Segment -> IO Renderinfo
withRenderinfo :: PangoContext -> DrawContext -> Segment -> IO Renderinfo
withRenderinfo PangoContext
ctx DrawContext
dctx seg :: Segment
seg@(C.Text String
_, TextRenderInfo
inf, Int
idx, Maybe [Action]
a) = do
let conf :: Config
conf = DrawContext -> Config
T.dcConfig DrawContext
dctx
PangoLayout
lyt <- PangoContext -> IO PangoLayout
Pango.layoutEmpty PangoContext
ctx
String
mk <- forall markup string.
(GlibString markup, GlibString string) =>
PangoLayout -> markup -> IO string
Pango.layoutSetMarkup PangoLayout
lyt (Config -> Segment -> String
segmentMarkup Config
conf Segment
seg) :: IO String
(PangoRectangle
_, Pango.PangoRectangle Double
o Double
u Double
w Double
h) <- PangoLayout -> IO (PangoRectangle, PangoRectangle)
Pango.layoutGetExtents PangoLayout
lyt
let voff' :: Double
voff' = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Config -> Int -> Int
ConfigParse.indexedOffset Config
conf Int
idx
voff :: Double
voff = Double
voff' forall a. Num a => a -> a -> a
+ (DrawContext -> Double
T.dcHeight DrawContext
dctx forall a. Num a => a -> a -> a
- Double
h forall a. Num a => a -> a -> a
+ Double
u) forall a. Fractional a => a -> a -> a
/ Double
2.0
wd :: Double
wd = Double
w forall a. Num a => a -> a -> a
- Double
o
slyt :: Surface -> Double -> Double -> IO ()
slyt Surface
s Double
off Double
mx = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
off forall a. Num a => a -> a -> a
+ Double
w forall a. Ord a => a -> a -> Bool
> Double
mx) forall a b. (a -> b) -> a -> b
$ do
PangoLayout -> EllipsizeMode -> IO ()
Pango.layoutSetEllipsize PangoLayout
lyt EllipsizeMode
Pango.EllipsizeEnd
PangoLayout -> Maybe Double -> IO ()
Pango.layoutSetWidth PangoLayout
lyt (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double
mx forall a. Num a => a -> a -> a
- Double
off)
forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
Cairo.renderWith Surface
s forall a b. (a -> b) -> a -> b
$ Double -> Double -> Render ()
Cairo.moveTo Double
off Double
voff forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PangoLayout -> Render ()
Pango.showLayout PangoLayout
lyt
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Widget
C.Text String
mk, TextRenderInfo
inf, Int
idx, Maybe [Action]
a), Surface -> Double -> Double -> IO ()
slyt, Double
wd)
withRenderinfo PangoContext
_ DrawContext
_ seg :: Segment
seg@(C.Hspace Int32
w, TextRenderInfo
_, Int
_, Maybe [Action]
_) =
forall (m :: * -> *) a. Monad m => a -> m a
return (Segment
seg, \Surface
_ Double
_ Double
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (), forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w)
withRenderinfo PangoContext
_ DrawContext
dctx seg :: Segment
seg@(C.Icon String
p, TextRenderInfo
info, Int
_, Maybe [Action]
_) = do
let (Double
wd, Double
_) = DrawContext -> IconLookup
T.dcIconLookup DrawContext
dctx String
p
ioff :: Int
ioff = Config -> Int
C.iconOffset (DrawContext -> Config
T.dcConfig DrawContext
dctx)
vpos :: Double
vpos = DrawContext -> Double
T.dcHeight DrawContext
dctx forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ioff
conf :: Config
conf = DrawContext -> Config
T.dcConfig DrawContext
dctx
(String
fg, String
bg) = Config -> String -> (String, String)
ConfigParse.colorComponents Config
conf (TextRenderInfo -> String
C.tColorsString TextRenderInfo
info)
render :: p -> Double -> Double -> IO ()
render p
_ Double
off Double
mx = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
off forall a. Num a => a -> a -> a
+ Double
wd forall a. Ord a => a -> a -> Bool
<= Double
mx) forall a b. (a -> b) -> a -> b
$
DrawContext -> IconDrawer
T.dcIconDrawer DrawContext
dctx Double
off Double
vpos String
p String
fg String
bg
forall (m :: * -> *) a. Monad m => a -> m a
return (Segment
seg, forall {p}. p -> Double -> Double -> IO ()
render, Double
wd)
drawBox :: T.DrawContext -> Surface -> Double -> Double -> C.Box -> IO ()
drawBox :: DrawContext -> Surface -> Double -> Double -> Box -> IO ()
drawBox DrawContext
dctx Surface
surf Double
x0 Double
x1 box :: Box
box@(C.Box BoxBorder
_ BoxOffset
_ CInt
w String
color BoxMargins
_) =
forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
Cairo.renderWith Surface
surf forall a b. (a -> b) -> a -> b
$
String -> Double -> [Line] -> Render ()
renderLines String
color (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w) (Box -> Double -> Double -> Double -> [Line]
Boxes.boxLines Box
box (DrawContext -> Double
T.dcHeight DrawContext
dctx) Double
x0 Double
x1)
drawSegmentBackground ::
T.DrawContext -> Surface -> C.TextRenderInfo -> Double -> Double -> IO ()
drawSegmentBackground :: DrawContext
-> Surface -> TextRenderInfo -> Double -> Double -> IO ()
drawSegmentBackground DrawContext
dctx Surface
surf TextRenderInfo
info Double
x0 Double
x1 =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
bg forall a. Eq a => a -> a -> Bool
/= Config -> String
C.bgColor Config
conf Bool -> Bool -> Bool
&& (Double
top forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
|| Double
bot forall a. Ord a => a -> a -> Bool
>= Double
0)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
Cairo.renderWith Surface
surf forall a b. (a -> b) -> a -> b
$ do
(Colour Double, Double) -> Render ()
setSourceColor (String -> (Colour Double, Double)
readColourName String
bg)
Double -> Double -> Double -> Double -> Render ()
Cairo.rectangle Double
x0 Double
top (Double
x1 forall a. Num a => a -> a -> a
- Double
x0) (DrawContext -> Double
T.dcHeight DrawContext
dctx forall a. Num a => a -> a -> a
- Double
bot forall a. Num a => a -> a -> a
- Double
top)
Render ()
Cairo.fillPreserve
where conf :: Config
conf = DrawContext -> Config
T.dcConfig DrawContext
dctx
(String
_, String
bg) = Config -> String -> (String, String)
ConfigParse.colorComponents Config
conf (TextRenderInfo -> String
C.tColorsString TextRenderInfo
info)
top :: Double
top = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TextRenderInfo -> Int32
C.tBgTopOffset TextRenderInfo
info
bot :: Double
bot = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TextRenderInfo -> Int32
C.tBgBottomOffset TextRenderInfo
info
drawSegment :: T.DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
drawSegment :: DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
drawSegment DrawContext
dctx Surface
surface Double
maxoff (Double
off, Actions
acts, [BoundedBox]
boxs) (Segment
segment, Surface -> Double -> Double -> IO ()
render, Double
lwidth) = do
let end :: Double
end = forall a. Ord a => a -> a -> a
min Double
maxoff (Double
off forall a. Num a => a -> a -> a
+ Double
lwidth)
(Widget
_, TextRenderInfo
info, Int
_, Maybe [Action]
a) = Segment
segment
acts' :: Actions
acts' = case Maybe [Action]
a of Just [Action]
as -> ([Action]
as, Double
off, Double
end)forall a. a -> [a] -> [a]
:Actions
acts; Maybe [Action]
_ -> Actions
acts
bs :: [Box]
bs = TextRenderInfo -> [Box]
C.tBoxes TextRenderInfo
info
boxs' :: [BoundedBox]
boxs' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Box]
bs then [BoundedBox]
boxs else (Double
off, Double
end, [Box]
bs)forall a. a -> [a] -> [a]
:[BoundedBox]
boxs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
end forall a. Ord a => a -> a -> Bool
> Double
off) forall a b. (a -> b) -> a -> b
$ do
DrawContext
-> Surface -> TextRenderInfo -> Double -> Double -> IO ()
drawSegmentBackground DrawContext
dctx Surface
surface TextRenderInfo
info Double
off Double
end
Surface -> Double -> Double -> IO ()
render Surface
surface Double
off Double
maxoff
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
off forall a. Num a => a -> a -> a
+ Double
lwidth, Actions
acts', [BoundedBox]
boxs')
renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render ()
renderOuterBorder :: Config -> Double -> Double -> Render ()
renderOuterBorder Config
conf Double
mw Double
mh = do
let (Double
x0, Double
y0, Double
w, Double
h) = Border -> Double -> Double -> Line
Boxes.borderRect (Config -> Border
C.border Config
conf) Double
mw Double
mh
(Colour Double, Double) -> Render ()
setSourceColor (String -> (Colour Double, Double)
readColourName (Config -> String
C.borderColor Config
conf))
Double -> Render ()
Cairo.setLineWidth (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Config -> Int
C.borderWidth Config
conf))
Double -> Double -> Double -> Double -> Render ()
Cairo.rectangle Double
x0 Double
y0 Double
w Double
h
Render ()
Cairo.stroke
drawBorder :: C.Config -> Double -> Double -> Surface -> IO ()
drawBorder :: Config -> Double -> Double -> Surface -> IO ()
drawBorder Config
conf Double
w Double
h Surface
surf =
case Config -> Border
C.border Config
conf of
Border
C.NoBorder -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Border
_ -> forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
Cairo.renderWith Surface
surf (Config -> Double -> Double -> Render ()
renderOuterBorder Config
conf Double
w Double
h)
drawBBox :: T.DrawContext -> Surface -> BoundedBox -> IO ()
drawBBox :: DrawContext -> Surface -> BoundedBox -> IO ()
drawBBox DrawContext
dctx Surface
surf (Double
from, Double
to, [Box]
bs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DrawContext -> Surface -> Double -> Double -> Box -> IO ()
drawBox DrawContext
dctx Surface
surf Double
from Double
to) [Box]
bs
drawBoxes :: T.DrawContext -> Surface -> [BoundedBox] -> IO ()
drawBoxes :: DrawContext -> Surface -> [BoundedBox] -> IO ()
drawBoxes DrawContext
dctx Surface
surf ((Double
from, Double
to, [Box]
b):(Double
from', Double
to', [Box]
b'):[BoundedBox]
bxs) =
if Double
to forall a. Ord a => a -> a -> Bool
< Double
from' Bool -> Bool -> Bool
|| [Box]
b forall a. Eq a => a -> a -> Bool
/= [Box]
b'
then do DrawContext -> Surface -> BoundedBox -> IO ()
drawBBox DrawContext
dctx Surface
surf (Double
from, Double
to, [Box]
b)
DrawContext -> Surface -> [BoundedBox] -> IO ()
drawBoxes DrawContext
dctx Surface
surf forall a b. (a -> b) -> a -> b
$ (Double
from', Double
to', [Box]
b')forall a. a -> [a] -> [a]
:[BoundedBox]
bxs
else DrawContext -> Surface -> [BoundedBox] -> IO ()
drawBoxes DrawContext
dctx Surface
surf forall a b. (a -> b) -> a -> b
$ (Double
from, Double
to', [Box]
b')forall a. a -> [a] -> [a]
:[BoundedBox]
bxs
drawBoxes DrawContext
dctx Surface
surf [BoundedBox
bi] = DrawContext -> Surface -> BoundedBox -> IO ()
drawBBox DrawContext
dctx Surface
surf BoundedBox
bi
drawBoxes DrawContext
_ Surface
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#ifndef XRENDER
drawCairoBackground :: T.DrawContext -> Surface -> IO ()
drawCairoBackground dctx surf = do
let (c, _) = readColourName (C.bgColor (T.dcConfig dctx))
Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint
#endif
drawSegments :: T.DrawContext -> Surface -> IO T.Actions
drawSegments :: DrawContext -> Surface -> IO Actions
drawSegments DrawContext
dctx Surface
surf = do
let [[Segment]
left, [Segment]
center, [Segment]
right] = forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ DrawContext -> [[Segment]]
T.dcSegments DrawContext
dctx forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat []
dh :: Double
dh = DrawContext -> Double
T.dcHeight DrawContext
dctx
dw :: Double
dw = DrawContext -> Double
T.dcWidth DrawContext
dctx
conf :: Config
conf = DrawContext -> Config
T.dcConfig DrawContext
dctx
sWidth :: [(a, b, Double)] -> Double
sWidth = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Double
a (a
_,b
_,Double
w) -> Double
a forall a. Num a => a -> a -> a
+ Double
w) Double
0
PangoContext
ctx <- Maybe FontMap -> IO PangoContext
Pango.cairoCreateContext forall a. Maybe a
Nothing
PangoContext -> Double -> IO ()
Pango.cairoContextSetResolution PangoContext
ctx forall a b. (a -> b) -> a -> b
$ Config -> Double
C.dpi Config
conf
[Renderinfo]
llyts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PangoContext -> DrawContext -> Segment -> IO Renderinfo
withRenderinfo PangoContext
ctx DrawContext
dctx) [Segment]
left
[Renderinfo]
rlyts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PangoContext -> DrawContext -> Segment -> IO Renderinfo
withRenderinfo PangoContext
ctx DrawContext
dctx) [Segment]
right
[Renderinfo]
clyts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PangoContext -> DrawContext -> Segment -> IO Renderinfo
withRenderinfo PangoContext
ctx DrawContext
dctx) [Segment]
center
#ifndef XRENDER
drawCairoBackground dctx surf
#endif
(Double
lend, Actions
as, [BoundedBox]
bx) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
drawSegment DrawContext
dctx Surface
surf Double
dw) (Double
0, [], []) [Renderinfo]
llyts
let [Double
rw, Double
cw] = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. [(a, b, Double)] -> Double
sWidth [[Renderinfo]
rlyts, [Renderinfo]
clyts]
rstart :: Double
rstart = forall a. Ord a => a -> a -> a
max Double
lend (Double
dw forall a. Num a => a -> a -> a
- Double
rw)
cstart :: Double
cstart = if Double
lend forall a. Ord a => a -> a -> Bool
> Double
1 then forall a. Ord a => a -> a -> a
max Double
lend ((Double
dw forall a. Num a => a -> a -> a
- Double
cw) forall a. Fractional a => a -> a -> a
/ Double
2.0) else Double
lend
(Double
_, Actions
as', [BoundedBox]
bx') <- if Double
cw forall a. Ord a => a -> a -> Bool
> Double
0
then forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
drawSegment DrawContext
dctx Surface
surf Double
rstart) (Double
cstart, Actions
as, [BoundedBox]
bx) [Renderinfo]
clyts
else forall (m :: * -> *) a. Monad m => a -> m a
return (Double
0, Actions
as, [BoundedBox]
bx)
(Double
_, Actions
as'', [BoundedBox]
bx'') <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
drawSegment DrawContext
dctx Surface
surf Double
dw) (Double
rstart, Actions
as', [BoundedBox]
bx') [Renderinfo]
rlyts
DrawContext -> Surface -> [BoundedBox] -> IO ()
drawBoxes DrawContext
dctx Surface
surf (forall a. [a] -> [a]
reverse [BoundedBox]
bx'')
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Int
C.borderWidth Config
conf forall a. Ord a => a -> a -> Bool
> Int
0) (Config -> Double -> Double -> Surface -> IO ()
drawBorder Config
conf Double
dw Double
dh Surface
surf)
forall (m :: * -> *) a. Monad m => a -> m a
return Actions
as''