diff options
Diffstat (limited to 'lib/Phi')
| -rw-r--r-- | lib/Phi/Panel.hs | 32 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 72 |
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 |