summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Border.hs18
-rw-r--r--lib/Phi/Widget.hs86
-rw-r--r--lib/Phi/Widgets/AlphaBox.hs13
-rw-r--r--lib/Phi/Widgets/Clock.hs18
-rw-r--r--lib/Phi/Widgets/Systray.hs18
-rw-r--r--lib/Phi/Widgets/Taskbar.hs20
-rw-r--r--lib/Phi/X11.hs3
7 files changed, 97 insertions, 79 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 0a9a74c..01dea44 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
@@ -23,7 +23,7 @@ data BorderWidth = BorderWidth { borderTop :: !Int
, borderRight :: !Int
, borderBottom :: !Int
, borderLeft :: !Int
- } deriving Show
+ } deriving (Show, Eq)
simpleBorderWidth :: Int -> BorderWidth
simpleBorderWidth w = BorderWidth w w w w
@@ -34,7 +34,7 @@ borderH bw = borderLeft bw + borderRight bw
borderV :: BorderWidth -> Int
borderV bw = borderTop bw + borderBottom bw
-data BorderState = BorderState ![WidgetState] deriving Show
+data BorderState = BorderState ![WidgetState] deriving Eq
data BorderConfig = BorderConfig { margin :: !BorderWidth
, borderWidth :: !Int
@@ -43,7 +43,7 @@ data BorderConfig = BorderConfig { margin :: !BorderWidth
, backgroundColor :: !Color
, cornerRadius :: !Int
, borderWeight :: !Float
- } deriving Show
+ } deriving (Show, Eq)
defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
, borderWidth = 1
@@ -54,10 +54,9 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
, borderWeight = 1
}
-data Border = Border !BorderConfig ![Widget] deriving Show
+data Border = Border !BorderConfig ![Widget] deriving (Show, Eq)
-instance WidgetClass Border where
- type WidgetData Border = BorderState
+instance WidgetClass Border BorderState where
initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
minSize (Border config _) (BorderState widgetStates) height screen =
@@ -88,10 +87,11 @@ instance WidgetClass Border where
width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p
- render (Border config _) (BorderState widgetStates) w h screen = when (w > borderH m - 2*bw - borderH p) $ do
+ render (Border config _) (BorderState widgetStates) x y w h screen = when (w > borderH m - 2*bw - borderH p) $ do
drawBorder config 0 0 w h
clip
- renderWidgets widgetStates screen
+ renderWidgets widgetStates screen x y
+ return ()
where
m = margin config
bw = borderWidth config
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 48c0b6c..e4a1e6a 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
+{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-}
module Phi.Widget ( Display(..)
, withDisplay
@@ -16,11 +16,14 @@ module Phi.Widget ( Display(..)
, handleMessageWidgets
) where
+import Control.Arrow
+import Control.Arrow.Transformer
+import Control.CacheArrow
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
-import Data.Traversable
+import Data.Traversable hiding (forM)
import qualified Graphics.X11.Xlib as Xlib
import Graphics.Rendering.Cairo
@@ -64,35 +67,50 @@ unionArea a b = fromIntegral $ uw*uh
by2 = by1 + fromIntegral bh
-class Show a => WidgetClass a where
- type WidgetData a :: *
+class (Show a, Eq a, Eq d) => WidgetClass a d | a -> d where
+ initWidget :: a -> Phi -> Display -> IO d
- initWidget :: a -> Phi -> Display -> IO (WidgetData a)
-
- minSize :: a -> WidgetData a -> Int -> Xlib.Rectangle -> Int
+ minSize :: a -> d -> Int -> Xlib.Rectangle -> Int
weight :: a -> Float
weight _ = 0
- layout :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> WidgetData a
+ layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d
layout _ priv _ _ _ = priv
- render :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> Render ()
+ render :: a -> d -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()
- handleMessage :: a -> WidgetData a -> Message -> WidgetData a
+ handleMessage :: a -> d -> Message -> d
handleMessage _ priv _ = priv
-data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => Widget !a
+data Widget = forall a d. WidgetClass a d => Widget !a
deriving instance Show Widget
-data WidgetState = forall a. (WidgetClass a, Show (WidgetData a)) => WidgetState { stateWidget :: !a
- , stateX :: !Int
- , stateY :: !Int
- , stateWidth :: !Int
- , stateHeight :: !Int
- , statePrivateData :: !(WidgetData a)
- }
-deriving instance Show WidgetState
+instance Eq Widget where
+ _ == _ = False
+
+data WidgetState = forall a d. WidgetClass a d =>
+ WidgetState { stateWidget :: !a
+ , stateX :: !Int
+ , stateY :: !Int
+ , stateWidth :: !Int
+ , stateHeight :: !Int
+ , statePrivateData :: !d
+ , stateRender :: !(CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface)
+ }
+
+instance Eq WidgetState where
+ _ == _ = False
+
+createStateRender :: WidgetClass a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface
+createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
+ surface <- createImageSurface FormatARGB32 w h
+ renderWith surface $ do
+ setOperator OperatorClear
+ paint
+ setOperator OperatorOver
+ render widget state x y w h screen
+ return surface
createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
createWidgetState phi disp (Widget w) = do
@@ -103,6 +121,7 @@ createWidgetState phi disp (Widget w) = do
, stateWidth = 0
, stateHeight = 0
, statePrivateData = priv
+ , stateRender = createStateRender
}
layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> [WidgetState]
@@ -118,40 +137,39 @@ layoutWidgets widgets x y width height screen = snd $ mapAccumL layoutWidgetAndX
in (wX + stateWidth lw, lw)
layoutWidget wX state = case state of
- WidgetState {stateWidget = w, statePrivateData = priv} ->
+ WidgetState {stateWidget = w, statePrivateData = priv, stateRender = render} ->
let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(nneg $ weight w)/wsum
priv' = layout w priv wWidth height screen
- in WidgetState w wX y wWidth height priv'
+ in WidgetState w wX y wWidth height priv' render
nneg :: (Num a, Ord a) => a -> a
nneg x = max 0 x
-renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Render ()
-renderWidgets widgets screen = forM_ widgets $ \WidgetState { stateWidget = widget
- , stateX = x
- , stateY = y
- , stateWidth = w
- , stateHeight = h
- , statePrivateData = priv } -> do
+renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Int -> Int -> Render [WidgetState]
+renderWidgets widgets screen winX winY = forM widgets $ \(WidgetState widget x y w h priv render) -> do
+ (surface, render') <- liftIO $ runKleisli (runCache render) (widget, priv, winX+x, winY+y, w, h, screen)
+
save
translate (fromIntegral x) (fromIntegral y)
- render widget priv w h screen
+ withPatternForSurface surface setSource
+ paint
restore
+
+ return $ WidgetState widget x y w h priv render'
handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
handleMessageWidgets message = map handleMessageWidget
where
- handleMessageWidget (WidgetState w x y width height priv) = WidgetState w x y width height $ handleMessage w priv message
+ handleMessageWidget (WidgetState w x y width height priv render) = WidgetState w x y width height (handleMessage w priv message) render
-data Separator = Separator Int Float deriving Show
+data Separator = Separator Int Float deriving (Show, Eq)
-instance WidgetClass Separator where
- type WidgetData Separator = ()
+instance WidgetClass Separator () where
initWidget _ _ _ = return ()
minSize (Separator s _) _ _ _ = s
weight (Separator _ w) = w
- render _ _ _ _ _ = return ()
+ render _ _ _ _ _ _ _ = return ()
separator :: Int -> Float -> Widget
separator s w = Widget $ Separator s w
diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs
index dd4bfba..2db17f4 100644
--- a/lib/Phi/Widgets/AlphaBox.hs
+++ b/lib/Phi/Widgets/AlphaBox.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Phi.Widgets.AlphaBox ( alphaBox
) where
@@ -11,13 +11,12 @@ import Control.Monad
import Graphics.Rendering.Cairo
-data AlphaBoxState = AlphaBoxState ![WidgetState] deriving Show
+data AlphaBoxState = AlphaBoxState ![WidgetState] deriving Eq
-data AlphaBox = AlphaBox !Double ![Widget] deriving Show
+data AlphaBox = AlphaBox !Double ![Widget] deriving (Show, Eq)
-instance WidgetClass AlphaBox where
- type WidgetData AlphaBox = AlphaBoxState
+instance WidgetClass AlphaBox AlphaBoxState where
initWidget (AlphaBox _ widgets) phi disp = liftM AlphaBoxState $ mapM (createWidgetState phi disp) widgets
minSize (AlphaBox _ _) (AlphaBoxState widgetStates) height screen =
@@ -27,10 +26,10 @@ instance WidgetClass AlphaBox where
layout (AlphaBox _ _) (AlphaBoxState widgetStates) width height screen = AlphaBoxState $ layoutWidgets widgetStates 0 0 width height screen
- render (AlphaBox alpha _) (AlphaBoxState widgetStates) w h screen = do
+ render (AlphaBox alpha _) (AlphaBoxState widgetStates) x y w h screen = do
renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do
renderWith surface $ do
- renderWidgets widgetStates screen
+ renderWidgets widgetStates screen x y
setOperator OperatorDestIn
setSourceRGBA 0 0 0 alpha
diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
index d2ad134..2607288 100644
--- a/lib/Phi/Widgets/Clock.hs
+++ b/lib/Phi/Widgets/Clock.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}
module Phi.Widgets.Clock ( ClockConfig(..)
, defaultClockConfig
@@ -29,20 +29,21 @@ data ClockConfig = ClockConfig { clockFormat :: !String
, fontColor :: !Color
, lineSpacing :: !Double
, clockSize :: !Int
- } deriving Show
+ } deriving (Show, Eq)
defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50
-data Clock = Clock !ClockConfig deriving Show
+data Clock = Clock !ClockConfig deriving (Show, Eq)
-data ClockState = ClockState !ZonedTime deriving Show
+instance Eq ZonedTime where
+ (ZonedTime localTime timezone) == (ZonedTime localTime' timezone') = (localTime == localTime') && (timezone == timezone')
+
+data ClockState = ClockState !ZonedTime deriving (Show, Eq)
data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
-instance WidgetClass Clock where
- type WidgetData Clock = ClockState
-
+instance WidgetClass Clock ClockState where
initWidget (Clock _) phi _ = do
forkIO $ forever $ do
time <- getZonedTime
@@ -57,8 +58,7 @@ instance WidgetClass Clock where
minSize (Clock config) _ _ _ = clockSize config
- render (Clock config) (ClockState time) w h _ = do
- time <- liftIO getZonedTime
+ render (Clock config) (ClockState time) _ _ w h _ = do
let (r, g, b, a) = fontColor config
str = formatTime defaultTimeLocale (clockFormat config) time
setSourceRGBA r g b a
diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
index 385a740..e9311de 100644
--- a/lib/Phi/Widgets/Systray.hs
+++ b/lib/Phi/Widgets/Systray.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}
module Phi.Widgets.Systray ( systray
) where
@@ -48,16 +48,16 @@ instance Show (IORef a) where
data SystrayIconState = SystrayIconState !Window !Window deriving Show
data SystrayState = SystrayState !Phi !Rectangle !Int !(IORef Int) ![SystrayIconState] deriving Show
+instance Eq SystrayState where
+ _ == _ = False
-data Systray = Systray deriving Show
+data Systray = Systray deriving (Show, Eq)
data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int !Bool
deriving (Show, Typeable)
-instance WidgetClass Systray where
- type WidgetData Systray = SystrayState
-
+instance WidgetClass Systray SystrayState where
initWidget (Systray) phi dispvar = do
phi' <- dupPhi phi
forkIO $ systrayRunner phi' dispvar
@@ -71,15 +71,13 @@ instance WidgetClass Systray where
weight _ = 0
- render Systray (SystrayState phi systrayScreen reset lastResetRef icons) w h screen = case True of
+ render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = case True of
_ | screen == systrayScreen -> do
lastReset <- liftIO $ readIORef lastResetRef
liftIO $ writeIORef lastResetRef reset
- Matrix _ _ _ _ dx dy <- getMatrix
forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
- let x = round dx + i*(h+2)
- y = round dy
- sendMessage phi $ RenderIcon midParent window x y h h (lastReset /= reset)
+ let x' = x + i*(h+2)
+ sendMessage phi $ RenderIcon midParent window x' y h h (lastReset /= reset)
| otherwise -> return ()
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index e1a4adc..feb7246 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances #-}
module Phi.Widgets.Taskbar ( IconStyle
, idIconStyle
@@ -50,6 +50,8 @@ import Phi.X11.Atoms
type IconStyle = Surface -> Render ()
instance Show IconStyle where
show _ = "IconStyle <?>"
+instance Eq IconStyle where
+ _ == _ = True
idIconStyle :: IconStyle
idIconStyle = flip withPatternForSurface setSource
@@ -103,20 +105,20 @@ data TaskStyle = TaskStyle { taskFont :: !String
, taskColor :: !Color
, taskBorder :: !BorderConfig
, taskIconStyle :: !IconStyle
- } deriving Show
+ } deriving (Show, Eq)
data DesktopStyle = DesktopStyle { desktopFont :: !String
, desktopLabelWidth :: !Int
, desktopLabelGap :: !Int
, desktopColor :: !Color
, desktopBorder :: !BorderConfig
- } deriving Show
+ } deriving (Show, Eq)
data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int
, normalTaskStyle :: !TaskStyle
, activeTaskStyle :: !TaskStyle
, desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle))
- } deriving Show
+ } deriving (Show, Eq)
defaultStyle :: TaskStyle
defaultStyle = TaskStyle { taskFont = "Sans 8"
@@ -132,7 +134,7 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
, desktopStyle = Nothing
}
-data Taskbar = Taskbar TaskbarConfig deriving Show
+data Taskbar = Taskbar TaskbarConfig deriving (Show, Eq)
instance Show Surface where
show _ = "Surface <?>"
@@ -146,6 +148,8 @@ data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
, taskbarWindowScaledIcons :: !(M.Map Window (IORef (Maybe (Int, Surface))))
, taskbarWindowScreens :: !(M.Map Window Xlib.Rectangle)
} deriving Show
+instance Eq TaskbarState where
+ _ == _ = False
data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int
@@ -161,9 +165,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
instance Show (IORef a) where
show _ = "IORef <?>"
-instance WidgetClass Taskbar where
- type WidgetData Taskbar = TaskbarState
-
+instance WidgetClass Taskbar TaskbarState where
initWidget (Taskbar _) phi dispvar = do
phi' <- dupPhi phi
forkIO $ taskbarRunner phi' dispvar
@@ -182,7 +184,7 @@ instance WidgetClass Taskbar where
, taskbarWindowIcons = windowIcons
, taskbarWindowScaledIcons = windowScaledIcons
, taskbarWindowScreens = windowScreens
- } w h screen = do
+ } _ _ w h screen = do
let screenWindows = filter ((== Just screen) . flip M.lookup windowScreens) windows
desktopNumbers = take desktopCount [0..]
desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index d7159dd..afa8440 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -218,12 +218,13 @@ updatePanels dispvar = do
setSource pattern
paint
restore
- Widget.renderWidgets layoutedWidgets $ panelScreenArea panel
+ Widget.renderWidgets layoutedWidgets (panelScreenArea panel) 0 0
renderWith xbuffer $ do
withPatternForSurface buffer $ \pattern -> do
setSource pattern
paint
+ surfaceFlush xbuffer
surfaceFinish xbuffer
-- copy buffer to window
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 01:32:28 +0100