neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Restructured widget state

Browse source
This commit is contained in:
Matthias Schiffer 2011-07-14 00:09:20 +02:00
parent 90c25a997b
commit 55d15b73ca
7 changed files with 126 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
lib/Phi/Border.hs
View file

@ -1,9 +1,12 @@
{-# LANGUAGE TypeFamilies #-}
module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
, border
) where
import Phi.Panel
import Phi.Types
import Phi.Widget
import Graphics.Rendering.Cairo
@ -30,11 +33,14 @@ data Border = Border { margin :: !BorderWidth
, backgroundColor :: !Color
, cornerRadius :: !Double
, borderWeight :: !Float
, content :: !Panel
, content :: ![Widget]
}
instance PanelClass Border where
minSize border = minSize c + borderH p + 2*bw + borderH m
instance WidgetClass Border where
type WidgetData Border = ()
initialState _ = ()
minSize border = sum (map (\(Widget w) -> minSize w) c) + borderH p + 2*bw + borderH m
where
m = margin border
bw = borderWidth border
@ -43,7 +49,7 @@ instance PanelClass Border where
weight border = borderWeight border
render border w h = do
render border _ w h = do
newPath
arc (x + width - radius) (y + radius) radius (-pi/2) 0
arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
@ -73,5 +79,5 @@ instance PanelClass Border where
(fr, fg, fb, fa) = backgroundColor border
border :: BorderWidth -> Int -> BorderWidth -> Color -> Color -> Double -> Float -> Panel -> Panel
border m bw p border bc cr w c = Panel $ Border m bw p border bc cr w c
border :: BorderWidth -> Int -> BorderWidth -> Color -> Color -> Double -> Float -> [Widget] -> Widget
border m bw p border bc cr w c = Widget $ Border m bw p border bc cr w c

66
lib/Phi/Panel.hs
View file

@ -1,73 +1,15 @@
{-# LANGUAGE ExistentialQuantification #-}
module Phi.Panel ( Position(..)
, Color
, Panel(..)
, PanelClass(..)
, (<~>)
, PanelConfig(..)
module Phi.Panel ( PanelConfig(..)
, defaultPanelConfig
, separator
) where
import Data.Function
import Data.Monoid
import Graphics.Rendering.Cairo
data Position = Top | Bottom
type Color = (Double, Double, Double, Double)
class PanelClass a where
minSize :: a -> Int
weight :: a -> Float
weight _ = 0
render :: a -> Int -> Int -> Render ()
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
render (Panel p) w h = render p w h
render (CompoundPanel panels) _ _ = return ()
(<~>) :: Panel -> Panel -> Panel
(<~>) = mappend
import Phi.Types
import Phi.Widget
data PanelConfig = PanelConfig { panelPosition :: Position
, panelSize :: Int
, panelContent :: Panel
}
defaultPanelConfig :: PanelConfig
defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24, panelContent = mempty }
defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24 }
data Separator = Separator Int Float
instance PanelClass Separator where
minSize (Separator s _) = s
weight (Separator _ w) = w
render (Separator _ _) _ _ = return ()
separator :: Int -> Float -> Panel
separator s w = Panel $ Separator s w

8
lib/Phi/Types.hs Normal file
View file

@ -0,0 +1,8 @@
module Phi.Types ( Position(..)
, Color
) where
data Position = Top | Bottom
type Color = (Double, Double, Double, Double)

67
lib/Phi/Widget.hs Normal file
View file

@ -0,0 +1,67 @@
{-# LANGUAGE ExistentialQuantification, TypeFamilies #-}
module Phi.Widget ( Widget(..)
, WidgetClass(..)
, WidgetState(..)
, separator
, createWidgetState
, layoutWidgets
, renderWidgets
) where
import Control.Monad
import Graphics.Rendering.Cairo
class WidgetClass a where
type WidgetData a :: *
initialState :: a -> WidgetData a
minSize :: a -> Int
weight :: a -> Float
weight _ = 0
layout :: a -> Int -> Int -> WidgetData a
layout widget _ _ = initialState widget
render :: a -> WidgetData a -> Int -> Int -> Render ()
data Widget = forall a. WidgetClass a => Widget a
data WidgetState = forall a. WidgetClass a => WidgetState { stateWidget :: a
, stateWidth :: Int
, stateHeight :: Int
, statePrivateData :: WidgetData a
}
createWidgetState :: Widget -> WidgetState
createWidgetState (Widget w) = WidgetState { stateWidget = w
, stateWidth = 0
, stateHeight = 0
, statePrivateData = initialState w
}
layoutWidgets :: [WidgetState] -> Int -> Int -> [WidgetState]
layoutWidgets widgets w h = map layoutWidget widgets
where
layoutWidget state = state { stateWidth = w, stateHeight = h }
renderWidgets :: [WidgetState] -> Render ()
renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget, stateWidth = w, stateHeight = h, statePrivateData = priv } -> render widget priv w h
data Separator = Separator Int Float
instance WidgetClass Separator where
type WidgetData Separator = ()
initialState _ = ()
minSize (Separator s _) = s
weight (Separator _ w) = w
render _ _ _ _ = return ()
separator :: Int -> Float -> Widget
separator s w = Widget $ Separator s w

52
lib/Phi/X11.hs
View file

@ -20,7 +20,9 @@ import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Trans
import qualified Phi.Types as Phi
import qualified Phi.Panel as Panel
import qualified Phi.Widget as Widget
import Phi.X11.Atoms
import qualified Phi.Bindings.Util as Util
@ -31,12 +33,13 @@ data PhiState = PhiState { phiRootPixmap :: Pixmap
, phiPanels :: [PanelState]
}
data PanelState = PanelState { panelWindow :: Window
, panelGC :: GC
, panelPixmap :: Pixmap
, panelSurface :: Surface
, panelArea :: Rectangle
, panelScreenArea :: Rectangle
data PanelState = PanelState { panelWindow :: Window
, panelGC :: GC
, panelPixmap :: Pixmap
, panelSurface :: Surface
, panelArea :: Rectangle
, panelScreenArea :: Rectangle
, panelWidgetStates :: [Widget.WidgetState]
}
data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
@ -70,8 +73,8 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
}
initPhi :: XConfig -> Panel.PanelConfig -> IO ()
initPhi xconfig config = do
initPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
initPhi xconfig config widgets = do
disp <- openDisplay []
atoms <- initAtoms disp
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
@ -80,7 +83,7 @@ initPhi xconfig config = do
updateRootPixmap
screens <- liftIO $ phiXScreenInfo xconfig disp
panels <- mapM createPanel screens
panels <- mapM (createPanel widgets) screens
forM_ panels $ \panel -> do
setPanelProperties panel
liftIO $ mapWindow disp (panelWindow panel)
@ -104,28 +107,34 @@ initPhi xconfig config = do
updatePanels :: Bool -> Phi ()
updatePanels redraw = do
disp <- asks phiDisplay
panelConfig <- asks phiPanelConfig
rootPixmap <- gets phiRootPixmap
panels <- gets phiPanels
forM_ panels $ \panel -> do
when redraw $ do
panels' <- forM panels $ \panel -> do
newPanel <- if not redraw then return panel else do
let surface = panelSurface panel
area = panelArea panel
layoutedWidgets = Widget.layoutWidgets (panelWidgetStates panel) (fromIntegral $ rect_width area) (fromIntegral $ rect_height area)
panel' = panel { panelWidgetStates = layoutedWidgets }
-- draw background
liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0
surfaceMarkDirty surface
renderWith surface $ do
save
Panel.render (Panel.panelContent panelConfig) (fromIntegral $ rect_width area) (fromIntegral $ rect_height area)
Widget.renderWidgets layoutedWidgets
restore
surfaceFlush surface
return panel'
-- copy pixmap to window
liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0
return newPanel
modify $ \state -> state { phiPanels = panels' }
handlePropertyUpdate :: Event -> Phi ()
@ -149,8 +158,8 @@ updateRootPixmap = do
modify $ \state -> state { phiRootPixmap = pixmap }
createPanel :: Rectangle -> Phi PanelState
createPanel screenRect = do
createPanel :: [Widget.Widget] -> Rectangle -> Phi PanelState
createPanel widgets screenRect = do
config <- asks phiPanelConfig
disp <- asks phiDisplay
let rect = panelBounds config screenRect
@ -165,8 +174,7 @@ createPanel screenRect = do
pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth
surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual
return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect }
return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect, panelWidgetStates = map Widget.createWidgetState widgets }
createPanelWindow :: Rectangle -> Phi Window
createPanelWindow rect = do
@ -241,8 +249,8 @@ setStruts panel = do
makeBottomStruts _ = 0
makeStruts = case position of
Panel.Top -> makeTopStruts
Panel.Bottom -> makeBottomStruts
Phi.Top -> makeTopStruts
Phi.Bottom -> makeBottomStruts
liftIO $ do
changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts
@ -251,8 +259,8 @@ setStruts panel = do
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,
Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
Phi.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }
withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a

2
phi.cabal
View file

@ -12,7 +12,7 @@ build-type: Simple
library
build-depends: base >= 4, template-haskell, mtl, cairo, X11
exposed-modules: Phi.Panel, Phi.Border, Phi.X11
exposed-modules: Phi.Types, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
hs-source-dirs: lib

5
src/Phi.hs
View file

@ -1,3 +1,4 @@
import Phi.Types
import Phi.Panel
import Phi.Border
import Phi.X11
@ -6,5 +7,5 @@ import Data.Monoid
main :: IO ()
main = do
initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelContent = border (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 1 mempty }
--initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelContent = border (simpleBorderWidth 0) 0 (simpleBorderWidth 2) (1, 1, 1, 1) (0.75, 0.75, 0.75, 1) 0 1 mempty }
initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom}
[border (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 1 []]