Added AlphaBox widget

This commit is contained in:
Matthias Schiffer 2011-07-18 18:06:00 +02:00
parent fcb645e610
commit 9d1415a2d3
4 changed files with 56 additions and 6 deletions

View file

@ -125,4 +125,4 @@ roundRectangle x y width height radius = do
closePath
border :: BorderConfig -> [Widget] -> Widget
border config widgets = Widget $ Border config widgets
border config = Widget . Border config

View file

@ -0,0 +1,49 @@
{-# LANGUAGE TypeFamilies #-}
module Phi.Widgets.AlphaBox ( alphaBox
) where
import Phi.Types
import Phi.Widget
import Control.Monad
import Graphics.Rendering.Cairo
data AlphaBoxState = AlphaBoxState [WidgetState] deriving Show
data AlphaBox = AlphaBox Double [Widget] deriving Show
instance WidgetClass AlphaBox where
type WidgetData AlphaBox = AlphaBoxState
initWidget (AlphaBox _ widgets) phi disp = liftM AlphaBoxState $ mapM (createWidgetState phi disp) widgets
minSize (AlphaBox _ _) (AlphaBoxState widgetStates) height =
sum (map (\(WidgetState {stateWidget = w, statePrivateData = priv}) -> minSize w priv height) widgetStates)
weight (AlphaBox _ widgets) = sum (map (\(Widget w) -> weight w) widgets)
layout (AlphaBox _ _) (AlphaBoxState widgetStates) width height = AlphaBoxState $ layoutWidgets widgetStates 0 0 width height
render (AlphaBox alpha _) (AlphaBoxState widgetStates) w h screen = do
renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do
renderWith surface $ do
renderWidgets widgetStates screen
setOperator OperatorDestIn
setSourceRGBA 0 0 0 alpha
paint
withPatternForSurface surface setSource
paint
handleMessage _ (AlphaBoxState widgetStates) m = AlphaBoxState $ handleMessageWidgets m widgetStates
alphaBox :: Double -> [Widget] -> Widget
alphaBox alpha = Widget . AlphaBox alpha