diff options
author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-07-12 16:47:24 +0200 |
---|---|---|
committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-07-12 16:47:24 +0200 |
commit | 19378fdcf11af2ef78d1b7e6cbda06952bb4e692 (patch) | |
tree | 94727397b9e4852ad494f6503f955e46607da2af /lib/Phi/X11.hs | |
parent | 6de4eb5792d88a70eaf9cc19784371a9a0eaba43 (diff) | |
download | phi-19378fdcf11af2ef78d1b7e6cbda06952bb4e692.tar phi-19378fdcf11af2ef78d1b7e6cbda06952bb4e692.zip |
Further worked out module structure
Diffstat (limited to 'lib/Phi/X11.hs')
-rw-r--r-- | lib/Phi/X11.hs | 72 |
1 files changed, 42 insertions, 30 deletions
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 |