Get rid of existential Widget type and Widget lists
This commit is contained in:
parent
028c4243a8
commit
022783f4a7
8 changed files with 141 additions and 176 deletions
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, ExistentialQuantification, FlexibleInstances #-}
|
||||
|
||||
module Phi.Border ( BorderWidth(..)
|
||||
, simpleBorderWidth
|
||||
|
|
@ -8,6 +8,7 @@ module Phi.Border ( BorderWidth(..)
|
|||
, defaultBorderConfig
|
||||
, drawBorder
|
||||
, roundRectangle
|
||||
, Border
|
||||
, border
|
||||
) where
|
||||
|
||||
|
|
@ -34,8 +35,6 @@ borderH bw = borderLeft bw + borderRight bw
|
|||
borderV :: BorderWidth -> Int
|
||||
borderV bw = borderTop bw + borderBottom bw
|
||||
|
||||
data BorderState = BorderState ![WidgetState] deriving Eq
|
||||
|
||||
data BorderConfig = BorderConfig { margin :: !BorderWidth
|
||||
, borderWidth :: !Int
|
||||
, padding :: !BorderWidth
|
||||
|
|
@ -54,17 +53,19 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
|
|||
, borderWeight = 1
|
||||
}
|
||||
|
||||
data Border = Border !BorderConfig ![Widget] deriving (Show, Eq)
|
||||
data Border w d = (Widget w d) => Border !BorderConfig !w
|
||||
deriving instance Show (Border w d)
|
||||
deriving instance Eq (Border w d)
|
||||
|
||||
instance WidgetClass Border BorderState where
|
||||
initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
|
||||
instance Eq d => Widget (Border w d) d where
|
||||
initWidget (Border _ w) = initWidget w
|
||||
|
||||
minSize (Border config _) (BorderState widgetStates) height screen =
|
||||
minSize (Border config w) d height screen =
|
||||
case True of
|
||||
_ | childSize == 0 -> 0
|
||||
| otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m)
|
||||
where
|
||||
childSize = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv}) -> minSize w priv height' screen) widgetStates
|
||||
childSize = minSize w d height' screen
|
||||
|
||||
m = margin config
|
||||
bw = borderWidth config
|
||||
|
|
@ -74,30 +75,34 @@ instance WidgetClass Border BorderState where
|
|||
|
||||
weight (Border config _) = borderWeight config
|
||||
|
||||
layout (Border config _) (BorderState widgetStates) width height screen = case True of
|
||||
_ | width' > 0 -> BorderState $ layoutWidgets widgetStates x y width' height' screen
|
||||
| otherwise -> BorderState widgetStates
|
||||
layout (Border config w) d width height screen = case True of
|
||||
_ | width' > 0 -> layout w d width' height' screen
|
||||
| otherwise -> d
|
||||
where
|
||||
m = margin config
|
||||
bw = borderWidth config
|
||||
p = padding config
|
||||
|
||||
x = borderLeft m + bw + borderLeft p
|
||||
y = borderTop m + bw + borderTop p
|
||||
width' = width - borderH m - 2*bw - borderH p
|
||||
height' = height - borderV m - 2*bw - borderV p
|
||||
|
||||
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
|
||||
render (Border config w) d x y width height screen = when (width > borderH m - 2*bw - borderH p) $ do
|
||||
drawBorder config 0 0 width height
|
||||
clip
|
||||
renderWidgets widgetStates screen x y
|
||||
translate (fromIntegral dx) (fromIntegral dy)
|
||||
render w d (x+dx) (y+dy) width' height' screen
|
||||
return ()
|
||||
where
|
||||
m = margin config
|
||||
bw = borderWidth config
|
||||
p = padding config
|
||||
|
||||
handleMessage _ (BorderState widgetStates) m = BorderState $ handleMessageWidgets m widgetStates
|
||||
dx = borderLeft m + bw + borderLeft p
|
||||
dy = borderTop m + bw + borderTop p
|
||||
width' = width - borderH m - 2*bw - borderH p
|
||||
height' = height - borderV m - 2*bw - borderV p
|
||||
|
||||
handleMessage (Border _ w) = handleMessage w
|
||||
|
||||
drawBorder :: BorderConfig -> Int -> Int -> Int -> Int -> Render ()
|
||||
drawBorder config dx dy w h = do
|
||||
|
|
@ -134,5 +139,5 @@ roundRectangle x y width height radius = do
|
|||
arc (x + radius) (y + radius) radius pi (pi*3/2)
|
||||
closePath
|
||||
|
||||
border :: BorderConfig -> [Widget] -> Widget
|
||||
border config = Widget . Border config
|
||||
border :: (Widget w d) => BorderConfig -> w -> Border w d
|
||||
border = Border
|
||||
|
|
|
|||
|
|
@ -7,13 +7,10 @@ module Phi.Widget ( Display(..)
|
|||
, getScreens
|
||||
, unionArea
|
||||
, Widget(..)
|
||||
, WidgetClass(..)
|
||||
, WidgetState(..)
|
||||
, CompoundWidget
|
||||
, (<~>)
|
||||
, Separator
|
||||
, separator
|
||||
, createWidgetState
|
||||
, layoutWidgets
|
||||
, renderWidgets
|
||||
, handleMessageWidgets
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
|
|
@ -67,7 +64,7 @@ unionArea a b = fromIntegral $ uw*uh
|
|||
by2 = by1 + fromIntegral bh
|
||||
|
||||
|
||||
class (Show a, Eq a, Eq d) => WidgetClass a d | a -> d where
|
||||
class (Show a, Eq a, Eq d) => Widget a d | a -> d where
|
||||
initWidget :: a -> Phi -> Display -> IO d
|
||||
|
||||
minSize :: a -> d -> Int -> Xlib.Rectangle -> Int
|
||||
|
|
@ -83,26 +80,7 @@ class (Show a, Eq a, Eq d) => WidgetClass a d | a -> d where
|
|||
handleMessage :: a -> d -> Message -> d
|
||||
handleMessage _ priv _ = priv
|
||||
|
||||
data Widget = forall a d. WidgetClass a d => Widget !a
|
||||
deriving instance Show Widget
|
||||
|
||||
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 :: Widget 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
|
||||
|
|
@ -110,66 +88,59 @@ createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
|
|||
paint
|
||||
setOperator OperatorOver
|
||||
render widget state x y w h screen
|
||||
return surface
|
||||
return surface-}
|
||||
|
||||
createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
|
||||
createWidgetState phi disp (Widget w) = do
|
||||
priv <- initWidget w phi disp
|
||||
return WidgetState { stateWidget = w
|
||||
, stateX = 0
|
||||
, stateY = 0
|
||||
, stateWidth = 0
|
||||
, stateHeight = 0
|
||||
, statePrivateData = priv
|
||||
, stateRender = createStateRender
|
||||
}
|
||||
data CompoundWidget a da b db = (Widget a da, Widget b db) => CompoundWidget !a !b
|
||||
deriving instance Eq (CompoundWidget a da b db)
|
||||
deriving instance Show (CompoundWidget a da b db)
|
||||
|
||||
layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> [WidgetState]
|
||||
layoutWidgets widgets x y width height screen = snd $ mapAccumL layoutWidgetAndX x widgets
|
||||
where
|
||||
sizesum = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv} ) -> nneg $ minSize w priv height screen) widgets
|
||||
wsum = let wsum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . weight $ w) widgets
|
||||
data CompoundState a da b db = (Widget a da, Widget b db) => CompoundState !da !db !Int
|
||||
deriving instance Eq (CompoundState a da b db)
|
||||
|
||||
instance Widget (CompoundWidget a da b db) (CompoundState a da b db) where
|
||||
initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0)
|
||||
|
||||
minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen
|
||||
|
||||
weight (CompoundWidget a b) = weight' a + weight' b
|
||||
|
||||
layout c@(CompoundWidget a b) d@(CompoundState da db _) width height screen = CompoundState da' db' xb
|
||||
where
|
||||
sizesum = minSize c d height screen
|
||||
wsum = let wsum = weight c
|
||||
in if wsum > 0 then wsum else 1
|
||||
|
||||
surplus = width - sizesum
|
||||
surplus = width - sizesum
|
||||
|
||||
layoutWidgetAndX wX state = let lw = layoutWidget wX state
|
||||
in (wX + stateWidth lw, lw)
|
||||
(xb, da') = layoutWidget a da
|
||||
(_, db') = layoutWidget b db
|
||||
|
||||
layoutWidget wX state = case state of
|
||||
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' render
|
||||
layoutWidget w priv = let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(weight' w)/wsum
|
||||
in (wWidth, layout w priv wWidth height screen)
|
||||
|
||||
nneg :: (Num a, Ord a) => a -> a
|
||||
nneg x = max 0 x
|
||||
render (CompoundWidget a b) (CompoundState da db xb) x y w h screen = do
|
||||
save
|
||||
render a da x y xb h screen
|
||||
restore
|
||||
translate (fromIntegral xb) 0
|
||||
render b db (x+xb) y (w-xb) h screen
|
||||
|
||||
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)
|
||||
handleMessage (CompoundWidget a b) (CompoundState da db xb) message = CompoundState (handleMessage a da message) (handleMessage b db message) xb
|
||||
|
||||
save
|
||||
translate (fromIntegral x) (fromIntegral y)
|
||||
withPatternForSurface surface setSource
|
||||
paint
|
||||
restore
|
||||
weight' :: (Widget a da) => a -> Float
|
||||
weight' = max 0 . weight
|
||||
|
||||
return $ WidgetState widget x y w h priv render'
|
||||
(<~>) :: (Widget a da, Widget b db) => a -> b -> CompoundWidget a da b db
|
||||
a <~> b = CompoundWidget a b
|
||||
|
||||
handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
|
||||
handleMessageWidgets message = map handleMessageWidget
|
||||
where
|
||||
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, Eq)
|
||||
|
||||
data Separator = Separator Int Float deriving (Show, Eq)
|
||||
|
||||
instance WidgetClass Separator () where
|
||||
instance Widget Separator () where
|
||||
initWidget _ _ _ = return ()
|
||||
|
||||
minSize (Separator s _) _ _ _ = s
|
||||
weight (Separator _ w) = w
|
||||
render _ _ _ _ _ _ _ = return ()
|
||||
|
||||
separator :: Int -> Float -> Widget
|
||||
separator s w = Widget $ Separator s w
|
||||
separator :: Int -> Float -> Separator
|
||||
separator = Separator
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, ExistentialQuantification, FlexibleInstances #-}
|
||||
|
||||
module Phi.Widgets.AlphaBox ( alphaBox
|
||||
module Phi.Widgets.AlphaBox ( AlphaBox
|
||||
, alphaBox
|
||||
) where
|
||||
|
||||
import Phi.Types
|
||||
|
|
@ -11,25 +12,23 @@ import Control.Monad
|
|||
import Graphics.Rendering.Cairo
|
||||
|
||||
|
||||
data AlphaBoxState = AlphaBoxState ![WidgetState] deriving Eq
|
||||
data AlphaBox w d = (Widget w d) => AlphaBox !Double !w
|
||||
deriving instance Show (AlphaBox w d)
|
||||
deriving instance Eq (AlphaBox w d)
|
||||
|
||||
data AlphaBox = AlphaBox !Double ![Widget] deriving (Show, Eq)
|
||||
instance Eq d => Widget (AlphaBox w d) d where
|
||||
initWidget (AlphaBox _ w) = initWidget w
|
||||
|
||||
minSize (AlphaBox _ w) = minSize w
|
||||
|
||||
instance WidgetClass AlphaBox AlphaBoxState where
|
||||
initWidget (AlphaBox _ widgets) phi disp = liftM AlphaBoxState $ mapM (createWidgetState phi disp) widgets
|
||||
weight (AlphaBox _ w) = weight w
|
||||
|
||||
minSize (AlphaBox _ _) (AlphaBoxState widgetStates) height screen =
|
||||
sum (map (\(WidgetState {stateWidget = w, statePrivateData = priv}) -> minSize w priv height screen) widgetStates)
|
||||
layout (AlphaBox _ w) = layout w
|
||||
|
||||
weight (AlphaBox _ widgets) = sum (map (\(Widget w) -> weight w) widgets)
|
||||
|
||||
layout (AlphaBox _ _) (AlphaBoxState widgetStates) width height screen = AlphaBoxState $ layoutWidgets widgetStates 0 0 width height screen
|
||||
|
||||
render (AlphaBox alpha _) (AlphaBoxState widgetStates) x y w h screen = do
|
||||
renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do
|
||||
render (AlphaBox alpha w) d x y width height screen = do
|
||||
renderWithSimilarSurface ContentColorAlpha width height $ \surface -> do
|
||||
renderWith surface $ do
|
||||
renderWidgets widgetStates screen x y
|
||||
render w d x y width height screen
|
||||
|
||||
setOperator OperatorDestIn
|
||||
setSourceRGBA 0 0 0 alpha
|
||||
|
|
@ -38,11 +37,9 @@ instance WidgetClass AlphaBox AlphaBoxState where
|
|||
withPatternForSurface surface setSource
|
||||
paint
|
||||
|
||||
handleMessage (AlphaBox _ w) = handleMessage w
|
||||
|
||||
|
||||
handleMessage _ (AlphaBoxState widgetStates) m = AlphaBoxState $ handleMessageWidgets m widgetStates
|
||||
|
||||
|
||||
alphaBox :: Double -> [Widget] -> Widget
|
||||
alphaBox alpha = Widget . AlphaBox alpha
|
||||
alphaBox :: (Widget w d) => Double -> w -> AlphaBox w d
|
||||
alphaBox = AlphaBox
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq)
|
|||
|
||||
data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
|
||||
|
||||
instance WidgetClass Clock ClockState where
|
||||
instance Widget Clock ClockState where
|
||||
initWidget (Clock _) phi _ = do
|
||||
forkIO $ forever $ do
|
||||
time <- getZonedTime
|
||||
|
|
@ -85,6 +85,6 @@ instance WidgetClass Clock ClockState where
|
|||
_ -> priv
|
||||
|
||||
|
||||
clock :: ClockConfig -> Widget
|
||||
clock :: ClockConfig -> Clock
|
||||
clock config = do
|
||||
Widget $ Clock config
|
||||
Clock config
|
||||
|
|
@ -35,19 +35,9 @@ import Phi.Widget
|
|||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
instance Show Display where
|
||||
show _ = "Display <?>"
|
||||
|
||||
instance Show Phi where
|
||||
show _ = "Phi <?>"
|
||||
|
||||
instance Show (IORef a) where
|
||||
show _ = "IORef <?>"
|
||||
|
||||
|
||||
data SystrayIconState = SystrayIconState !Window !Window deriving Show
|
||||
|
||||
data SystrayState = SystrayState !Phi !Rectangle !Int !(IORef Int) ![SystrayIconState] deriving Show
|
||||
data SystrayState = SystrayState !Phi !Rectangle !Int !(IORef Int) ![SystrayIconState]
|
||||
instance Eq SystrayState where
|
||||
_ == _ = False
|
||||
|
||||
|
|
@ -57,7 +47,7 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon
|
|||
deriving (Show, Typeable)
|
||||
|
||||
|
||||
instance WidgetClass Systray SystrayState where
|
||||
instance Widget Systray SystrayState where
|
||||
initWidget (Systray) phi dispvar = do
|
||||
phi' <- dupPhi phi
|
||||
forkIO $ systrayRunner phi' dispvar
|
||||
|
|
@ -298,5 +288,5 @@ removeIcon phi disp reparent window = do
|
|||
return ()
|
||||
|
||||
|
||||
systray :: Widget
|
||||
systray = Widget $ Systray
|
||||
systray :: Systray
|
||||
systray = Systray
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ module Phi.Widgets.Taskbar ( IconStyle
|
|||
, DesktopStyle(..)
|
||||
, TaskbarConfig(..)
|
||||
, defaultTaskbarConfig
|
||||
, Taskbar
|
||||
, taskbar
|
||||
) where
|
||||
|
||||
|
|
@ -165,7 +166,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
|
|||
instance Show (IORef a) where
|
||||
show _ = "IORef <?>"
|
||||
|
||||
instance WidgetClass Taskbar TaskbarState where
|
||||
instance Widget Taskbar TaskbarState where
|
||||
initWidget (Taskbar _) phi dispvar = do
|
||||
phi' <- dupPhi phi
|
||||
forkIO $ taskbarRunner phi' dispvar
|
||||
|
|
@ -566,6 +567,5 @@ showWindow disp atoms window = do
|
|||
getWindowList :: Xlib.Display -> Atoms -> IO [Window]
|
||||
getWindowList disp atoms = liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
|
||||
|
||||
taskbar :: TaskbarConfig -> Widget
|
||||
taskbar config = do
|
||||
Widget $ Taskbar config
|
||||
taskbar :: TaskbarConfig -> Taskbar
|
||||
taskbar = Taskbar
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-}
|
||||
|
||||
module Phi.X11 ( XConfig(..)
|
||||
, defaultXConfig
|
||||
|
|
@ -30,6 +30,7 @@ import Phi.Phi
|
|||
import qualified Phi.Types as Phi
|
||||
import qualified Phi.Panel as Panel
|
||||
import qualified Phi.Widget as Widget
|
||||
import Phi.Widget (Widget)
|
||||
import Phi.X11.Atoms
|
||||
import qualified Phi.Bindings.Util as Util
|
||||
|
||||
|
|
@ -37,20 +38,21 @@ import qualified Phi.Bindings.Util as Util
|
|||
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
|
||||
}
|
||||
|
||||
data PhiState = PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState]
|
||||
, phiRepaint :: !Bool
|
||||
, phiShutdown :: !Bool
|
||||
, phiShutdownHold :: !Int
|
||||
}
|
||||
|
||||
data PanelState = PanelState { panelWindow :: !Window
|
||||
, panelPixmap :: !Pixmap
|
||||
, panelArea :: !Rectangle
|
||||
, panelScreenArea :: !Rectangle
|
||||
, panelWidgetStates :: ![Widget.WidgetState]
|
||||
data PhiState w d = (Widget.Widget w d) => PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState w d]
|
||||
, phiRepaint :: !Bool
|
||||
, phiShutdown :: !Bool
|
||||
, phiShutdownHold :: !Int
|
||||
}
|
||||
|
||||
data PanelState w d = (Widget.Widget w d) => PanelState { panelWindow :: !Window
|
||||
, panelPixmap :: !Pixmap
|
||||
, panelArea :: !Rectangle
|
||||
, panelScreenArea :: !Rectangle
|
||||
, panelWidget :: !w
|
||||
, panelWidgetState :: !d
|
||||
}
|
||||
|
||||
data PhiConfig = PhiConfig { phiPhi :: !Phi
|
||||
, phiPanelConfig :: !Panel.PanelConfig
|
||||
, phiXConfig :: !XConfig
|
||||
|
|
@ -63,18 +65,18 @@ newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
|
|||
runPhiReader :: PhiConfig -> PhiReader a -> IO a
|
||||
runPhiReader config (PhiReader a) = runReaderT a config
|
||||
|
||||
newtype PhiX a = PhiX (StateT PhiState PhiReader a)
|
||||
deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)
|
||||
newtype PhiX w d a = PhiX (StateT (PhiState w d) PhiReader a)
|
||||
deriving (Monad, MonadState (PhiState w d), MonadReader PhiConfig, MonadIO)
|
||||
|
||||
runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
|
||||
runPhiX :: PhiConfig -> PhiState w d -> PhiX w d a -> IO (a, PhiState w d)
|
||||
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
|
||||
|
||||
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
|
||||
}
|
||||
|
||||
|
||||
runPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
|
||||
runPhi xconfig config widgets = do
|
||||
runPhi :: (Widget.Widget w d) => XConfig -> Panel.PanelConfig -> w -> IO ()
|
||||
runPhi xconfig config widget = do
|
||||
xSetErrorHandler
|
||||
|
||||
phi <- initPhi
|
||||
|
|
@ -108,10 +110,10 @@ runPhi xconfig config widgets = do
|
|||
dispmvar <- liftIO $ newMVar disp
|
||||
let screenPanels = zip screens panelWindows
|
||||
dispvar = Widget.Display dispmvar atoms screenPanels
|
||||
widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
|
||||
widgetState <- liftIO $ Widget.initWidget widget phi dispvar
|
||||
|
||||
Widget.withDisplay dispvar $ \disp -> do
|
||||
panels <- mapM (\(screen, window) -> createPanel disp window widgetStates screen) screenPanels
|
||||
panels <- mapM (\(screen, window) -> createPanel disp window widget widgetState screen) screenPanels
|
||||
|
||||
forM_ panels $ \panel -> do
|
||||
setPanelProperties disp panel
|
||||
|
|
@ -155,12 +157,12 @@ termHandler :: Phi -> Handler
|
|||
termHandler phi = Catch $ sendMessage phi Shutdown
|
||||
|
||||
|
||||
handlePanel :: Message -> PanelState -> PanelState
|
||||
handlePanel message panel@PanelState {panelWidgetStates = widgets} = panel {panelWidgetStates = widgets'}
|
||||
handlePanel :: Message -> PanelState w d -> PanelState w d
|
||||
handlePanel message panel@PanelState {panelWidget = widget, panelWidgetState = state} = panel {panelWidgetState = state'}
|
||||
where
|
||||
widgets' = Widget.handleMessageWidgets message widgets
|
||||
state' = Widget.handleMessage widget state message
|
||||
|
||||
handleMessage :: Widget.Display -> Message -> PhiX ()
|
||||
handleMessage :: Widget.Display -> Message -> PhiX w d ()
|
||||
handleMessage dispvar m = do
|
||||
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
|
||||
|
||||
|
|
@ -192,7 +194,7 @@ receiveEvents phi dispvar = do
|
|||
|
||||
when (not handled) $ threadWaitRead connection
|
||||
|
||||
updatePanels :: Widget.Display -> PhiX ()
|
||||
updatePanels :: (Widget w d) => Widget.Display -> PhiX w d ()
|
||||
updatePanels dispvar = do
|
||||
rootImage <- gets phiRootImage
|
||||
panels <- gets phiPanels
|
||||
|
|
@ -201,8 +203,8 @@ updatePanels dispvar = do
|
|||
let pixmap = panelPixmap panel
|
||||
area = panelArea panel
|
||||
|
||||
let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel
|
||||
panel' = panel { panelWidgetStates = layoutedWidgets }
|
||||
let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel
|
||||
panel' = panel { panelWidgetState = layoutedWidget }
|
||||
|
||||
Widget.withDisplay dispvar $ \disp -> do
|
||||
let screen = defaultScreen disp
|
||||
|
|
@ -218,13 +220,12 @@ updatePanels dispvar = do
|
|||
setSource pattern
|
||||
paint
|
||||
restore
|
||||
Widget.renderWidgets layoutedWidgets (panelScreenArea panel) 0 0
|
||||
(withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel)
|
||||
renderWith xbuffer $ do
|
||||
withPatternForSurface buffer $ \pattern -> do
|
||||
setSource pattern
|
||||
paint
|
||||
|
||||
surfaceFlush xbuffer
|
||||
surfaceFinish xbuffer
|
||||
|
||||
-- copy buffer to window
|
||||
|
|
@ -237,7 +238,7 @@ updatePanels dispvar = do
|
|||
modify $ \state -> state { phiPanels = panels' }
|
||||
|
||||
|
||||
handlePropertyUpdate :: Display -> Event -> PhiX ()
|
||||
handlePropertyUpdate :: Display -> Event -> PhiX w d ()
|
||||
handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
|
||||
phi <- asks phiPhi
|
||||
atoms <- asks phiAtoms
|
||||
|
|
@ -249,7 +250,7 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
|
|||
sendMessage phi Repaint
|
||||
|
||||
|
||||
updateRootImage :: Display -> PhiX ()
|
||||
updateRootImage :: Display -> PhiX w d ()
|
||||
updateRootImage disp = do
|
||||
atoms <- asks phiAtoms
|
||||
|
||||
|
|
@ -287,8 +288,8 @@ updateRootImage disp = do
|
|||
surfaceFinish rootSurface
|
||||
|
||||
|
||||
createPanel :: Display -> Window -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
|
||||
createPanel disp win widgets screenRect = do
|
||||
createPanel :: (Widget w d) => Display -> Window -> w -> d -> Rectangle -> PhiX w d (PanelState w d)
|
||||
createPanel disp win w d screenRect = do
|
||||
config <- asks phiPanelConfig
|
||||
let rect = panelBounds config screenRect
|
||||
let screen = defaultScreen disp
|
||||
|
|
@ -301,10 +302,11 @@ createPanel disp win widgets screenRect = do
|
|||
, panelPixmap = pixmap
|
||||
, panelArea = rect
|
||||
, panelScreenArea = screenRect
|
||||
, panelWidgetStates = widgets
|
||||
, panelWidget = w
|
||||
, panelWidgetState = d
|
||||
}
|
||||
|
||||
createPanelWindow :: Display -> Rectangle -> PhiX Window
|
||||
createPanelWindow :: Display -> Rectangle -> PhiX w d Window
|
||||
createPanelWindow disp screenRect = do
|
||||
config <- asks phiPanelConfig
|
||||
let rect = panelBounds config screenRect
|
||||
|
|
@ -323,7 +325,7 @@ createPanelWindow disp screenRect = do
|
|||
withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
|
||||
|
||||
|
||||
setPanelProperties :: Display -> PanelState -> PhiX ()
|
||||
setPanelProperties :: Display -> PanelState w d -> PhiX w d ()
|
||||
setPanelProperties disp panel = do
|
||||
atoms <- asks phiAtoms
|
||||
liftIO $ do
|
||||
|
|
@ -354,7 +356,7 @@ setPanelProperties disp panel = do
|
|||
setStruts disp panel
|
||||
|
||||
|
||||
setStruts :: Display -> PanelState -> PhiX ()
|
||||
setStruts :: Display -> PanelState w d -> PhiX w d ()
|
||||
setStruts disp panel = do
|
||||
atoms <- asks phiAtoms
|
||||
config <- asks phiPanelConfig
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@ import Phi.Widgets.Systray
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Top }
|
||||
[alphaBox 0.9 [theTaskbar, brightBorder [theSystray], brightBorder [theClock]]]
|
||||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Top } $ alphaBox 0.9 $ theTaskbar <~> brightBorder theSystray <~> brightBorder theClock
|
||||
where
|
||||
normalTaskBorder = BorderConfig (BorderWidth (-1) (-3) (-1) 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 0.8) 5 0
|
||||
activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8)
|
||||
|
|
@ -53,4 +52,5 @@ main = do
|
|||
, lineSpacing = (-3)
|
||||
, clockSize = 75
|
||||
}
|
||||
brightBorder :: (Widget w d) => w -> Border w d
|
||||
brightBorder = border normalDesktopBorder
|
||||
|
|
|
|||
Reference in a new issue