summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Panel.hs32
-rw-r--r--lib/Phi/X11.hs72
2 files changed, 67 insertions, 37 deletions
diff --git a/lib/Phi/Panel.hs b/lib/Phi/Panel.hs
index 42f4f98..b15f6ab 100644
--- a/lib/Phi/Panel.hs
+++ b/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,21 +20,36 @@ 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
+(<~>) :: Panel -> Panel -> Panel
+(<~>) = mappend
-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
+data PanelConfig = PanelConfig { panelPosition :: Position
+ , panelSize :: Int
+ , panelContent :: Panel
+ }
+defaultPanelConfig :: PanelConfig
+defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24, panelContent = mempty }
data Separator = Separator Int Float
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 129e00e..53fed21 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Phi.X11 ( PhiXConfig(..)
- , phiDefaultXConfig
+module Phi.X11 ( XConfig(..)
+ , 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]
- , phiPanelPosition :: Panel.Position
- , phiPanelSize :: Int
- }
+data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
+ }
-data PhiState = PhiState { phiXConfig :: PhiXConfig
- , phiDisplay :: Display
+data PhiState = PhiState { 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)
- deriving (Monad, MonadState PhiState, MonadIO)
+data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
+ , phiXConfig :: XConfig
+ }
+
+newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
+ deriving (Monad, MonadReader PhiConfig, MonadIO)
+
+runPhiReader :: PhiConfig -> PhiReader a -> IO a
+runPhiReader config (PhiReader a) = runReaderT a config
-runPhi :: PhiState -> Phi a -> IO (a, PhiState)
-runPhi st (Phi a) = runStateT a st
+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
-phiDefaultXConfig = PhiXConfig { phiXScreenInfo = getScreenInfo
- , phiPanelPosition = Panel.Top
- , phiPanelSize = 24
- }
+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
-initPhi :: PhiXConfig -> IO ()
-initPhi config = do
+defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
+ }
+
+initPhi :: XConfig -> Panel.PanelConfig -> IO ()
+initPhi xconfig 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
- liftIO $ allocaXEvent $ \xevent -> runPhi state $ do
+ liftIOContToPhi allocaXEvent $ \xevent -> 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 config screenBounds = case phiPanelPosition config of
- Panel.Top -> screenBounds { rect_height = fromIntegral $ phiPanelSize config }
- Panel.Bottom -> screenBounds { rect_height = fromIntegral $ phiPanelSize config,
- rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ phiPanelSize config) }
+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,
+ 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