Restructured widget state

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
+instance WidgetClass Border where
-  minSize border = minSize c + borderH p + 2*bw + borderH m
+  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 :: BorderWidth -> Int -> BorderWidth -> Color -> Color -> Double -> Float -> [Widget] -> Widget
-border m bw p border bc cr w c = Panel $ Border m bw p border bc cr w c
+border m bw p border bc cr w c = Widget $ Border m bw p border bc cr w c

lib/Phi/Panel.hs

@@ -1,73 +1,15 @@
-{-# LANGUAGE ExistentialQuantification #-}
+module Phi.Panel ( PanelConfig(..)
-
-module Phi.Panel ( Position(..)
-                 , Color
-                 , Panel(..)
-                 , PanelClass(..)
-                 , (<~>)
-                 , PanelConfig(..)
                  , defaultPanelConfig
-                 , separator
                  ) where
 
-import Data.Function
+import Phi.Types
-import Data.Monoid
+import Phi.Widget
-
-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
 
 
 data PanelConfig = PanelConfig { panelPosition :: Position
                                , panelSize     :: Int
-                               , panelContent  :: Panel
                                }
 
 defaultPanelConfig :: PanelConfig
-defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24, panelContent = mempty }
+defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24 }
 
-data Separator = Separator Int Float
-
-instance PanelClass Separator where
-  minSize (Separator s _) = s
-  weight (Separator _ w) = w
-  render (Separator _ _) _ _ = return ()
-
-separator :: Int -> Float -> Panel
-separator s w = Panel $ Separator s w

lib/Phi/Types.hs

@@ -0,0 +1,8 @@
+module Phi.Types ( Position(..)
+                 , Color
+                 ) where
+
+
+data Position = Top | Bottom
+
+type Color = (Double, Double, Double, Double)

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

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
 
@@ -37,6 +39,7 @@ data PanelState = PanelState { panelWindow     :: Window
                              , 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 -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
-initPhi xconfig config = do
+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
+  panels' <- forM panels $ \panel -> do
-    when redraw $ 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 :: [Widget.Widget] -> Rectangle -> Phi PanelState
-createPanel screenRect = do
+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
+              Phi.Top -> makeTopStruts
-              Panel.Bottom -> makeBottomStruts
+              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 }
+  Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
-  Panel.Bottom -> 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

phi.cabal

@@ -12,7 +12,7 @@ build-type:          Simple
 
 library
   build-depends:     base >= 4, template-haskell, mtl, cairo, X11
-  exposed-modules:   Phi.Panel, Phi.Border, Phi.X11
+  exposed-modules:   Phi.Types, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
   other-modules:     Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
   hs-source-dirs:    lib
 

src/Phi.hs

@@ -1,3 +1,4 @@
+import Phi.Types
 import Phi.Panel
 import Phi.Border
 import Phi.X11
@@ -6,5 +7,5 @@ import Data.Monoid
 
 main :: IO ()
 main = do
-  initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelContent = border (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 1 mempty }
+  initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom}
-  --initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelContent = border (simpleBorderWidth 0) 0 (simpleBorderWidth 2) (1, 1, 1, 1) (0.75, 0.75, 0.75, 1) 0 1 mempty }
+    [border (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 1 []]