From 028c4243a87e41e3b7e2c51eb752d4b089b30680 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sun, 21 Aug 2011 05:38:37 +0200 Subject: Use CacheArrow for rendering Extremely hacky at the moment, for now the caching isn't used at all... --- lib/Phi/Border.hs | 18 +++++----- lib/Phi/Widget.hs | 86 +++++++++++++++++++++++++++------------------ lib/Phi/Widgets/AlphaBox.hs | 13 ++++--- lib/Phi/Widgets/Clock.hs | 18 +++++----- lib/Phi/Widgets/Systray.hs | 18 +++++----- lib/Phi/Widgets/Taskbar.hs | 20 ++++++----- lib/Phi/X11.hs | 3 +- 7 files changed, 97 insertions(+), 79 deletions(-) (limited to 'lib/Phi') 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 -- cgit v1.2.3