Further worked out module structure
This commit is contained in:
parent
6de4eb5792
commit
19378fdcf1
3 changed files with 70 additions and 40 deletions
|
|
@ -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
|
||||
|
||||
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
|
||||
weight (CompoundPanel panels) = sum $ map weight panels
|
||||
|
||||
(<~>) :: 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
runPhi :: PhiState -> Phi a -> IO (a, PhiState)
|
||||
runPhi st (Phi a) = runStateT a st
|
||||
|
||||
|
||||
phiDefaultXConfig = PhiXConfig { phiXScreenInfo = getScreenInfo
|
||||
, phiPanelPosition = Panel.Top
|
||||
, phiPanelSize = 24
|
||||
data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
|
||||
, phiXConfig :: XConfig
|
||||
}
|
||||
|
||||
newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
|
||||
deriving (Monad, MonadReader PhiConfig, MonadIO)
|
||||
|
||||
initPhi :: PhiXConfig -> IO ()
|
||||
initPhi config = do
|
||||
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
|
||||
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@ import Phi.X11
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
initPhi phiDefaultXConfig { phiPanelPosition = Bottom }
|
||||
initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||
|
|
|
|||
Reference in a new issue