diff options
| -rw-r--r-- | lib/Phi/Widget.hs | 13 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Clock.hs | 20 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 55 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 141 | ||||
| -rw-r--r-- | phi.cabal | 2 | ||||
| -rw-r--r-- | src/Phi.hs | 10 |
6 files changed, 169 insertions, 72 deletions
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index d28c21d..e0d051b 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-} -module Phi.Widget ( Display +module Phi.Widget ( Display(..) + , withDisplay , Widget(..) , WidgetClass(..) , WidgetState(..) @@ -11,7 +12,6 @@ module Phi.Widget ( Display , handleMessageWidgets ) where -import Control.Concurrent import Control.Monad import Data.Traversable @@ -23,7 +23,14 @@ import Graphics.Rendering.Cairo import Phi.Phi -type Display = MVar Graphics.X11.Xlib.Display +newtype Display = Display Graphics.X11.Xlib.Display + +withDisplay :: Display -> (Graphics.X11.Xlib.Display -> IO a) -> IO a +withDisplay (Display disp) f = do + Graphics.X11.Xlib.lockDisplay disp + a <- f disp + Graphics.X11.Xlib.unlockDisplay disp + return a class Show a => WidgetClass a where diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index 602a1fc..3e88b0e 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} +{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-} module Phi.Widgets.Clock ( ClockConfig(..) , defaultClockConfig @@ -36,21 +36,28 @@ defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50 data Clock = Clock ClockConfig deriving Show +data ClockState = ClockState ZonedTime deriving Show + +data ClockMessage = UpdateTime ZonedTime deriving (Show, Typeable) + instance WidgetClass Clock where - type WidgetData Clock = () + type WidgetData Clock = ClockState initWidget (Clock _) phi _ = do forkIO $ forever $ do time <- getZonedTime + sendMessage phi $ UpdateTime time sendMessage phi Repaint threadDelay $ ceiling $ 1000000*(max 1 $ 60 - (todSec . localTimeOfDay . zonedTimeToLocalTime $ time)) - return () + + time <- getZonedTime + return $ ClockState time minSize (Clock config ) = clockSize config - render (Clock config) _ w h = do + render (Clock config) (ClockState time) w h = do time <- liftIO getZonedTime let (r, g, b, a) = fontColor config str = formatTime defaultTimeLocale (clockFormat config) time @@ -72,6 +79,11 @@ instance WidgetClass Clock where moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2) showLayout layout + + handleMessage _ priv m = case (fromMessage m) of + Just (UpdateTime time) -> ClockState time + _ -> priv + clock :: ClockConfig -> Widget clock config = do diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs new file mode 100644 index 0000000..1b86ffd --- /dev/null +++ b/lib/Phi/Widgets/Taskbar.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TypeFamilies #-} + +module Phi.Widgets.Taskbar ( TaskbarConfig(..) + , defaultTaskbarConfig + , taskbar + ) where + +import Control.Concurrent +import Control.Monad + +import Data.Typeable +import Data.Time.LocalTime +import Data.Time.Format + +import Graphics.Rendering.Cairo + +import Graphics.Rendering.Pango.Cairo +import Graphics.Rendering.Pango.Enums (PangoRectangle(..)) +import Graphics.Rendering.Pango.Layout + +import System.Locale + +import Phi.Phi +import Phi.Types +import Phi.Widget + + +data TaskbarConfig = TaskbarConfig deriving Show + +defaultTaskbarConfig :: TaskbarConfig +defaultTaskbarConfig = TaskbarConfig + +data Taskbar = Taskbar TaskbarConfig deriving Show + +data TaskbarState = TaskbarState deriving Show + +instance WidgetClass Taskbar where + type WidgetData Taskbar = TaskbarState + + initWidget (Taskbar _) phi dispvar = do + --withMVar dispvar $ \disp -> + + -- return () + return TaskbarState + + + minSize _ = 0 + weight _ = 1 + + render (Taskbar config) _ w h = do + return () + +taskbar :: TaskbarConfig -> Widget +taskbar config = do + Widget $ Taskbar config diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 3fc08e6..e5d220b 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -35,14 +35,12 @@ data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle]) } data PhiState = PhiState { phiPhi :: !Phi - , phiRootPixmap :: !Pixmap + , phiRootImage :: !Surface , phiPanels :: ![PanelState] } data PanelState = PanelState { panelWindow :: !Window - , panelGC :: !GC - , panelPixmap :: !Pixmap - , panelSurface :: !Surface + , panelBuffer :: !Surface , panelArea :: !Rectangle , panelScreenArea :: !Rectangle , panelWidgetStates :: ![Widget.WidgetState] @@ -65,12 +63,12 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a) runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState) runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st -withMVarX :: MVar a -> (a -> PhiX b) -> PhiX b -withMVarX m f = do - a <- liftIO $ takeMVar m - b <- f a - liftIO $ putMVar m a - return b +withDisplayX :: Widget.Display -> (Display -> PhiX a) -> PhiX a +withDisplayX (Widget.Display disp) f = do + liftIO $ lockDisplay disp + a <- f disp + liftIO $ unlockDisplay disp + return a defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } @@ -78,31 +76,33 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo runPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO () runPhi xconfig config widgets = do + initThreads phi <- initPhi disp <- openDisplay [] atoms <- initAtoms disp selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask - runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootPixmap = 0, phiPanels = [] } $ do - updateRootPixmap disp + bg <- createImageSurface FormatRGB24 1 1 + runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootImage = bg, phiPanels = [] } $ do + updateRootImage disp screens <- liftIO $ phiXScreenInfo xconfig disp - dispvar <- liftIO $ newEmptyMVar + let dispvar = Widget.Display disp widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets - panels <- mapM (createPanel disp widgetStates) screens - - forM_ panels $ \panel -> do - setPanelProperties disp panel - liftIO $ mapWindow disp (panelWindow panel) - - modify $ \state -> state { phiPanels = panels } - - updatePanels disp True - - liftIO $ putMVar dispvar disp + withDisplayX dispvar $ \disp -> do + panels <- mapM (createPanel disp widgetStates) screens + + forM_ panels $ \panel -> do + setPanelProperties disp panel + liftIO $ mapWindow disp (panelWindow panel) + + modify $ \state -> state { phiPanels = panels } + + updatePanels disp True + liftIO $ forkIO $ receiveEvents phi dispvar forever $ do @@ -116,28 +116,28 @@ handlePanel message panel@PanelState {panelWidgetStates = widgets} = panel {pane where widgets' = Widget.handleMessageWidgets message widgets -handleMessage :: MVar Display -> Message -> PhiX () +handleMessage :: Widget.Display -> Message -> PhiX () handleMessage dispvar m = do modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels} case (fromMessage m) of - Just Repaint -> withMVarX dispvar $ \disp -> + Just Repaint -> withDisplayX dispvar $ \disp -> updatePanels disp True _ -> case (fromMessage m) of - Just ExposeEvent {} -> withMVarX dispvar $ \disp -> + Just ExposeEvent {} -> withDisplayX dispvar $ \disp -> updatePanels disp False - Just event@PropertyEvent {} -> withMVarX dispvar $ \disp -> + Just event@PropertyEvent {} -> withDisplayX dispvar $ \disp -> handlePropertyUpdate disp event _ -> return () -receiveEvents :: Phi -> MVar Display -> IO () +receiveEvents :: Phi -> Widget.Display -> IO () receiveEvents phi dispvar = do - connection <- withMVar dispvar $ return . Fd . connectionNumber + connection <- Widget.withDisplay dispvar $ return . Fd . connectionNumber forever $ allocaXEvent $ \xevent -> do - handled <- withMVar dispvar $ \disp -> do + handled <- Widget.withDisplay dispvar $ \disp -> do pend <- pending disp if pend /= 0 then do @@ -152,28 +152,38 @@ receiveEvents phi dispvar = do updatePanels :: Display -> Bool -> PhiX () updatePanels disp redraw = do - - rootPixmap <- gets phiRootPixmap + rootImage <- gets phiRootImage panels <- gets phiPanels panels' <- forM panels $ \panel -> do + let buffer = panelBuffer panel + area = panelArea panel + newPanel <- if not redraw then return panel else do - let surface = panelSurface panel - area = panelArea panel - layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0 + let layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0 panel' = panel { panelWidgetStates = layoutedWidgets } - -- draw background - liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0 - surfaceMarkDirty surface - - renderWith surface $ Widget.renderWidgets layoutedWidgets + renderWith buffer $ do + withPatternForSurface rootImage $ \pattern -> do + save + translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) + setSource pattern + paint + restore + Widget.renderWidgets layoutedWidgets - surfaceFlush surface return panel' - - -- copy pixmap to window - liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0 + + let screen = defaultScreen disp + visual = defaultVisual disp screen + surface <- liftIO $ withDimension area $ Util.createXlibSurface disp (panelWindow newPanel) visual + + -- copy buffer to window + renderWith surface $ withPatternForSurface buffer $ \pattern -> do + setSource pattern + paint + surfaceFinish surface + return newPanel modify $ \state -> state { phiPanels = panels' } @@ -185,18 +195,39 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do - updateRootPixmap disp + updateRootImage disp updatePanels disp True -updateRootPixmap :: Display -> PhiX () -updateRootPixmap disp = do +updateRootImage :: Display -> PhiX () +updateRootImage disp = do atoms <- asks phiAtoms + + let screen = defaultScreen disp + visual = defaultVisual disp screen rootwin = defaultRootWindow disp pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin - modify $ \state -> state { phiRootPixmap = pixmap } + (_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin + + -- update surface size + oldBg <- gets phiRootImage + imageWidth <- liftM fromIntegral $ imageSurfaceGetWidth oldBg + imageHeight <- liftM fromIntegral $ imageSurfaceGetHeight oldBg + when (imageWidth /= rootWidth || imageHeight /= rootHeight) $ do + surfaceFinish oldBg + newBg <- liftIO $ createImageSurface FormatRGB24 (fromIntegral rootWidth) (fromIntegral rootHeight) + modify $ \state -> state { phiRootImage = newBg } + + bg <- gets phiRootImage + rootSurface <- liftIO $ Util.createXlibSurface disp pixmap visual (fromIntegral rootWidth) (fromIntegral rootHeight) + + renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do + setSource pattern + paint + + surfaceFinish rootSurface createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState @@ -206,19 +237,11 @@ createPanel disp widgets screenRect = do let rect = panelBounds config screenRect win <- createPanelWindow disp rect - gc <- liftIO $ createGC disp win - let screen = defaultScreen disp - depth = defaultDepth disp screen - visual = defaultVisual disp screen - - pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth - surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual + buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24 return PanelState { panelWindow = win - , panelGC = gc - , panelPixmap = pixmap - , panelSurface = surface + , panelBuffer = buffer , panelArea = rect , panelScreenArea = screenRect , panelWidgetStates = widgets @@ -13,7 +13,7 @@ build-type: Simple library build-depends: base >= 4, template-haskell, mtl, time, old-locale, X11, cairo, pango exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11, - Phi.Widgets.Clock + Phi.Widgets.Clock, Phi.Widgets.Taskbar other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util hs-source-dirs: lib @@ -3,18 +3,18 @@ import Phi.Widget import Phi.Panel import Phi.Border import Phi.X11 + import Phi.Widgets.Clock +import Phi.Widgets.Taskbar main :: IO () main = do runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } - [border border1 [border border3 [], border border3 []], border border2 [], border brightBorder [theClock]] + [theTaskbar, brightBorder [theClock]] where + theTaskbar = taskbar defaultTaskbarConfig theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>" , lineSpacing = (-2) , clockSize = 75 } - brightBorder = BorderConfig (simpleBorderWidth 1) 1 (BorderWidth (-2) 3 0 3) (0.5, 0.5, 0.5, 0.65) (0.85, 0.85, 0.85, 0.8) 5 0 - border1 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2 - border2 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.5, 0.0, 0.25, 0.5) 7 1 - border3 = BorderConfig (simpleBorderWidth 0) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.0, 0.0, 0.5, 0.5) 3 1 + brightBorder = border $ BorderConfig (simpleBorderWidth 1) 1 (BorderWidth (-2) 3 0 3) (0.5, 0.5, 0.5, 0.65) (0.85, 0.85, 0.85, 0.8) 5 0 |