summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Border.hs20
-rw-r--r--lib/Phi/Panel.hs66
-rw-r--r--lib/Phi/Types.hs8
-rw-r--r--lib/Phi/Widget.hs67
-rw-r--r--lib/Phi/X11.hs52
5 files changed, 122 insertions, 91 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 42a0e8e..a110f2d 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -1,9 +1,12 @@
+{-# LANGUAGE TypeFamilies #-}
+
module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
, border
) where
-import Phi.Panel
+import Phi.Types
+import Phi.Widget
import Graphics.Rendering.Cairo
@@ -30,11 +33,14 @@ data Border = Border { margin :: !BorderWidth
, backgroundColor :: !Color
, cornerRadius :: !Double
, borderWeight :: !Float
- , content :: !Panel
+ , content :: ![Widget]
}
-instance PanelClass Border where
- minSize border = minSize c + borderH p + 2*bw + borderH m
+instance WidgetClass Border where
+ type WidgetData Border = ()
+ initialState _ = ()
+
+ minSize border = sum (map (\(Widget w) -> minSize w) c) + borderH p + 2*bw + borderH m
where
m = margin border
bw = borderWidth border
@@ -43,7 +49,7 @@ instance PanelClass Border where
weight border = borderWeight border
- render border w h = do
+ render border _ w h = do
newPath
arc (x + width - radius) (y + radius) radius (-pi/2) 0
arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
@@ -73,5 +79,5 @@ instance PanelClass Border where
(fr, fg, fb, fa) = backgroundColor border
-border :: BorderWidth -> Int -> BorderWidth -> Color -> Color -> Double -> Float -> Panel -> Panel
-border m bw p border bc cr w c = Panel $ Border m bw p border bc cr w c \ No newline at end of file
+border :: BorderWidth -> Int -> BorderWidth -> Color -> Color -> Double -> Float -> [Widget] -> Widget
+border m bw p border bc cr w c = Widget $ Border m bw p border bc cr w c \ No newline at end of file
diff --git a/lib/Phi/Panel.hs b/lib/Phi/Panel.hs
index d54124f..a31ffad 100644
--- a/lib/Phi/Panel.hs
+++ b/lib/Phi/Panel.hs
@@ -1,73 +1,15 @@
-{-# LANGUAGE ExistentialQuantification #-}
-
-module Phi.Panel ( Position(..)
- , Color
- , Panel(..)
- , PanelClass(..)
- , (<~>)
- , PanelConfig(..)
+module Phi.Panel ( PanelConfig(..)
, defaultPanelConfig
- , separator
) where
-import Data.Function
-import Data.Monoid
-
-import Graphics.Rendering.Cairo
-
-
-data Position = Top | Bottom
-
-type Color = (Double, Double, Double, Double)
-
-class PanelClass a where
- minSize :: a -> Int
-
- weight :: a -> Float
- weight _ = 0
-
- render :: a -> Int -> Int -> Render ()
-
-data Panel = forall a. PanelClass a => Panel a | CompoundPanel [Panel]
-
-instance Monoid Panel where
- mempty = CompoundPanel []
- mappend a b = makePanel $ (toList a) ++ (toList b)
- where
- toList (Panel p) = [Panel p]
- toList (CompoundPanel panels) = panels
-
- makePanel [p] = p
- makePanel panels = CompoundPanel panels
-
-instance PanelClass Panel where
- minSize (Panel p) = minSize p
- minSize (CompoundPanel panels) = sum $ map minSize panels
-
- weight (Panel p) = weight p
- weight (CompoundPanel panels) = sum $ map weight panels
-
- render (Panel p) w h = render p w h
- render (CompoundPanel panels) _ _ = return ()
-
-(<~>) :: Panel -> Panel -> Panel
-(<~>) = mappend
+import Phi.Types
+import Phi.Widget
data PanelConfig = PanelConfig { panelPosition :: Position
, panelSize :: Int
- , panelContent :: Panel
}
defaultPanelConfig :: PanelConfig
-defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24, panelContent = mempty }
-
-data Separator = Separator Int Float
-
-instance PanelClass Separator where
- minSize (Separator s _) = s
- weight (Separator _ w) = w
- render (Separator _ _) _ _ = return ()
+defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24 }
-separator :: Int -> Float -> Panel
-separator s w = Panel $ Separator s w
diff --git a/lib/Phi/Types.hs b/lib/Phi/Types.hs
new file mode 100644
index 0000000..6e03918
--- /dev/null
+++ b/lib/Phi/Types.hs
@@ -0,0 +1,8 @@
+module Phi.Types ( Position(..)
+ , Color
+ ) where
+
+
+data Position = Top | Bottom
+
+type Color = (Double, Double, Double, Double)
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
new file mode 100644
index 0000000..a4850e7
--- /dev/null
+++ b/lib/Phi/Widget.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE ExistentialQuantification, TypeFamilies #-}
+
+module Phi.Widget ( Widget(..)
+ , WidgetClass(..)
+ , WidgetState(..)
+ , separator
+ , createWidgetState
+ , layoutWidgets
+ , renderWidgets
+ ) where
+
+import Control.Monad
+
+import Graphics.Rendering.Cairo
+
+
+class WidgetClass a where
+ type WidgetData a :: *
+
+ initialState :: a -> WidgetData a
+
+ minSize :: a -> Int
+
+ weight :: a -> Float
+ weight _ = 0
+
+ layout :: a -> Int -> Int -> WidgetData a
+ layout widget _ _ = initialState widget
+
+ render :: a -> WidgetData a -> Int -> Int -> Render ()
+
+data Widget = forall a. WidgetClass a => Widget a
+
+data WidgetState = forall a. WidgetClass a => WidgetState { stateWidget :: a
+ , stateWidth :: Int
+ , stateHeight :: Int
+ , statePrivateData :: WidgetData a
+ }
+
+createWidgetState :: Widget -> WidgetState
+createWidgetState (Widget w) = WidgetState { stateWidget = w
+ , stateWidth = 0
+ , stateHeight = 0
+ , statePrivateData = initialState w
+ }
+
+layoutWidgets :: [WidgetState] -> Int -> Int -> [WidgetState]
+layoutWidgets widgets w h = map layoutWidget widgets
+ where
+ layoutWidget state = state { stateWidth = w, stateHeight = h }
+
+renderWidgets :: [WidgetState] -> Render ()
+renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget, stateWidth = w, stateHeight = h, statePrivateData = priv } -> render widget priv w h
+
+
+data Separator = Separator Int Float
+
+instance WidgetClass Separator where
+ type WidgetData Separator = ()
+ initialState _ = ()
+
+ minSize (Separator s _) = s
+ weight (Separator _ w) = w
+ render _ _ _ _ = return ()
+
+separator :: Int -> Float -> Widget
+separator s w = Widget $ Separator s w
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index d272cb9..057d1ee 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -20,7 +20,9 @@ import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Trans
+import qualified Phi.Types as Phi
import qualified Phi.Panel as Panel
+import qualified Phi.Widget as Widget
import Phi.X11.Atoms
import qualified Phi.Bindings.Util as Util
@@ -31,12 +33,13 @@ data PhiState = PhiState { phiRootPixmap :: Pixmap
, phiPanels :: [PanelState]
}
-data PanelState = PanelState { panelWindow :: Window
- , panelGC :: GC
- , panelPixmap :: Pixmap
- , panelSurface :: Surface
- , panelArea :: Rectangle
- , panelScreenArea :: Rectangle
+data PanelState = PanelState { panelWindow :: Window
+ , panelGC :: GC
+ , panelPixmap :: Pixmap
+ , panelSurface :: Surface
+ , panelArea :: Rectangle
+ , panelScreenArea :: Rectangle
+ , panelWidgetStates :: [Widget.WidgetState]
}
data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
@@ -70,8 +73,8 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
}
-initPhi :: XConfig -> Panel.PanelConfig -> IO ()
-initPhi xconfig config = do
+initPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
+initPhi xconfig config widgets = do
disp <- openDisplay []
atoms <- initAtoms disp
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
@@ -80,7 +83,7 @@ initPhi xconfig config = do
updateRootPixmap
screens <- liftIO $ phiXScreenInfo xconfig disp
- panels <- mapM createPanel screens
+ panels <- mapM (createPanel widgets) screens
forM_ panels $ \panel -> do
setPanelProperties panel
liftIO $ mapWindow disp (panelWindow panel)
@@ -104,28 +107,34 @@ initPhi xconfig config = do
updatePanels :: Bool -> Phi ()
updatePanels redraw = do
disp <- asks phiDisplay
- panelConfig <- asks phiPanelConfig
rootPixmap <- gets phiRootPixmap
panels <- gets phiPanels
- forM_ panels $ \panel -> do
- when redraw $ do
+ panels' <- forM panels $ \panel -> do
+ newPanel <- if not redraw then return panel else do
let surface = panelSurface panel
area = panelArea panel
+ layoutedWidgets = Widget.layoutWidgets (panelWidgetStates panel) (fromIntegral $ rect_width area) (fromIntegral $ rect_height area)
+ panel' = panel { panelWidgetStates = layoutedWidgets }
+
-- draw background
liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0
surfaceMarkDirty surface
renderWith surface $ do
save
- Panel.render (Panel.panelContent panelConfig) (fromIntegral $ rect_width area) (fromIntegral $ rect_height area)
+ Widget.renderWidgets layoutedWidgets
restore
surfaceFlush surface
-
+ return panel'
+
-- copy pixmap to window
liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0
+ return newPanel
+
+ modify $ \state -> state { phiPanels = panels' }
handlePropertyUpdate :: Event -> Phi ()
@@ -149,8 +158,8 @@ updateRootPixmap = do
modify $ \state -> state { phiRootPixmap = pixmap }
-createPanel :: Rectangle -> Phi PanelState
-createPanel screenRect = do
+createPanel :: [Widget.Widget] -> Rectangle -> Phi PanelState
+createPanel widgets screenRect = do
config <- asks phiPanelConfig
disp <- asks phiDisplay
let rect = panelBounds config screenRect
@@ -165,8 +174,7 @@ createPanel screenRect = do
pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth
surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual
- return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect }
-
+ return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect, panelWidgetStates = map Widget.createWidgetState widgets }
createPanelWindow :: Rectangle -> Phi Window
createPanelWindow rect = do
@@ -241,8 +249,8 @@ setStruts panel = do
makeBottomStruts _ = 0
makeStruts = case position of
- Panel.Top -> makeTopStruts
- Panel.Bottom -> makeBottomStruts
+ Phi.Top -> makeTopStruts
+ Phi.Bottom -> makeBottomStruts
liftIO $ do
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts
@@ -251,8 +259,8 @@ setStruts panel = do
panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle
panelBounds config screenBounds = case Panel.panelPosition config of
- Panel.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
- Panel.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
+ Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
+ Phi.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }
withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 09:50:24 +0100