neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Use CacheArrow for rendering

Browse source 
Extremely hacky at the moment, for now the caching isn't used at all...
This commit is contained in:
Matthias Schiffer 2011-08-21 05:38:37 +02:00
parent 15bccc001a
commit 028c4243a8
8 changed files with 98 additions and 80 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
lib/Phi/Border.hs
View file

@ -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

76
lib/Phi/Widget.hs
View file

@ -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
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 :: !(WidgetData a)
, statePrivateData :: !d
, stateRender :: !(CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface)
}
deriving instance Show WidgetState
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

13
lib/Phi/Widgets/AlphaBox.hs
View file

@ -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

18
lib/Phi/Widgets/Clock.hs
View file

@ -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

18
lib/Phi/Widgets/Systray.hs
View file

@ -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 ()

20
lib/Phi/Widgets/Taskbar.hs
View file

@ -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

3
lib/Phi/X11.hs
View file

@ -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

2
phi.cabal
View file

@ -11,7 +11,7 @@ maintainer: mschiffer@universe-factory.net
build-type: Simple
library
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, arrows, CacheArrow
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler