Further worked out module structure

lib/Phi/Panel.hs

@@ -4,10 +4,13 @@ module Phi.Panel ( Position(..)
                  , Panel(..)
                  , PanelClass(..)
                  , (<~>)
+                 , PanelConfig(..)
+                 , defaultPanelConfig
                  , separator
                  ) where
 
 import Data.Function
+import Data.Monoid
 
 data Position = Top | Bottom
 
@@ -17,22 +20,37 @@ class PanelClass a where
   weight :: a -> Float
   weight _ = 0
 
-data Panel = forall a. PanelClass a => Panel a
+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
-data CompoundPanel = CompoundPanel Panel Panel
-
-instance PanelClass CompoundPanel where
-  minSize (CompoundPanel a b) = ((+) `on` minSize) a b
-  weight (CompoundPanel a b) = ((+) `on` weight) a b
 
 (<~>) :: Panel -> Panel -> Panel
-a <~> b = Panel $ CompoundPanel a b
+(<~>) = mappend
 
 
+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

lib/Phi/X11.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module Phi.X11 ( PhiXConfig(..)
+module Phi.X11 ( XConfig(..)
-               , phiDefaultXConfig
+               , defaultXConfig
                , initPhi
                ) where
 
@@ -14,17 +14,15 @@ import Data.Maybe
 import Data.Bits
 
 import Control.Monad.State
+import Control.Monad.Reader
 import Control.Monad.Trans
 
 import qualified Phi.Panel as Panel
 
-data PhiXConfig = PhiXConfig { phiXScreenInfo   :: Display -> IO [Rectangle]
+data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
-                             , phiPanelPosition :: Panel.Position
+                       }
-                             , phiPanelSize     :: Int
-                             }
 
-data PhiState = PhiState { phiXConfig    :: PhiXConfig
+data PhiState = PhiState { phiDisplay    :: Display
-                         , phiDisplay    :: Display
                          , phiRootPixmap :: Pixmap
                          , phiPanels     :: [PanelState]
                          }
@@ -35,28 +33,43 @@ data PanelState = PanelState { panelWindow     :: Window
                              , panelScreenArea :: Rectangle
                              }
 
-newtype Phi a = Phi (StateT PhiState IO a)
+data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
-              deriving (Monad, MonadState PhiState, MonadIO)
+                           , phiXConfig     :: XConfig
+                           }
 
-runPhi :: PhiState -> Phi a -> IO (a, PhiState)
+newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
-runPhi st (Phi a) = runStateT a st
+                    deriving (Monad, MonadReader PhiConfig, MonadIO)
+
+runPhiReader :: PhiConfig -> PhiReader a -> IO a
+runPhiReader config (PhiReader a) = runReaderT a config
+
+newtype Phi a = Phi (StateT PhiState PhiReader a)
+              deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)
+
+runPhi :: PhiConfig -> PhiState -> Phi a -> IO (a, PhiState)
+runPhi config st (Phi a) = runPhiReader config $ runStateT a st
+
+liftIOContToPhi :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> Phi b) -> Phi b
+liftIOContToPhi f c = do
+  config <- ask
+  state <- get
+  (a, state') <- liftIO $ f $ \x -> runPhi config state $ c x
+  put state'
+  return a
 
 
-phiDefaultXConfig = PhiXConfig { phiXScreenInfo   = getScreenInfo
+defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
-                               , phiPanelPosition = Panel.Top
+                         }
-                               , phiPanelSize     = 24
-                               }
 
-
+initPhi :: XConfig -> Panel.PanelConfig -> IO ()
-initPhi :: PhiXConfig -> IO ()
+initPhi xconfig config = do
-initPhi config = do
   disp <- openDisplay []
   selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
   
-  runPhi PhiState { phiXConfig = config, phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do
+  runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config } PhiState { phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do
     updateRootPixmap
     
-    screens <- liftIO $ phiXScreenInfo config disp
+    screens <- liftIO $ phiXScreenInfo xconfig disp
     panels <- mapM createPanel screens
     forM_ panels $ \panel -> do
       setPanelProperties panel
@@ -64,8 +77,7 @@ initPhi config = do
     
     modify $ \state -> state { phiPanels = panels }
     
-    state <- get
+    liftIOContToPhi allocaXEvent $ \xevent -> do
-    liftIO $ allocaXEvent $ \xevent -> runPhi state $ do
       forever $ do
         liftIO $ nextEvent disp xevent
         event <- liftIO $ getEvent xevent
@@ -110,7 +122,7 @@ updateRootPixmap = do
 
 createPanel :: Rectangle -> Phi PanelState
 createPanel screen = do
-  config <- gets phiXConfig
+  config <- asks phiPanelConfig
   let rect = panelBounds config screen
   disp <- gets phiDisplay
   win <- createPanelWindow rect
@@ -177,9 +189,9 @@ setPanelProperties panel = do
 setStruts :: PanelState -> Phi ()
 setStruts panel = do
   disp <- gets phiDisplay
-  config <- gets phiXConfig
+  config <- asks phiPanelConfig
   let rootwin = defaultRootWindow disp
-      position = phiPanelPosition config
+      position = Panel.panelPosition config
       area = panelArea panel
   (_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
   
@@ -207,11 +219,11 @@ setStruts panel = do
     changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT_PARTIAL cARDINAL propModeReplace struts
 
 
-panelBounds :: PhiXConfig -> Rectangle -> Rectangle
+panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle
-panelBounds config screenBounds = case phiPanelPosition config of
+panelBounds config screenBounds = case Panel.panelPosition config of
-  Panel.Top -> screenBounds { rect_height = fromIntegral $ phiPanelSize config }
+  Panel.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
-  Panel.Bottom -> screenBounds { rect_height = fromIntegral $ phiPanelSize config,
+  Panel.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
-                                        rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ phiPanelSize config) }
+                                        rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }
 
 withRectangle :: Rectangle -> (Position -> Position -> Dimension -> Dimension -> a) -> a
 withRectangle r = withDimension r . withPosition r

src/Phi.hs

@@ -3,4 +3,4 @@ import Phi.X11
 
 main :: IO ()
 main = do
-  initPhi phiDefaultXConfig { phiPanelPosition = Bottom }
+  initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }