diff options
| -rw-r--r-- | lib/Phi/Border.hs | 4 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 62 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 7 | ||||
| -rw-r--r-- | src/Phi.hs | 6 |
4 files changed, 56 insertions, 23 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index a110f2d..0e7fbdc 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -15,7 +15,7 @@ data BorderWidth = BorderWidth { borderTop :: !Int , borderRight :: !Int , borderBottom :: !Int , borderLeft :: !Int - } + } deriving Show simpleBorderWidth :: Int -> BorderWidth simpleBorderWidth w = BorderWidth w w w w @@ -34,7 +34,7 @@ data Border = Border { margin :: !BorderWidth , cornerRadius :: !Double , borderWeight :: !Float , content :: ![Widget] - } + } deriving Show instance WidgetClass Border where type WidgetData Border = () diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index a4850e7..5d924eb 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-} module Phi.Widget ( Widget(..) , WidgetClass(..) @@ -10,11 +10,12 @@ module Phi.Widget ( Widget(..) ) where import Control.Monad +import Data.Traversable import Graphics.Rendering.Cairo -class WidgetClass a where +class Show a => WidgetClass a where type WidgetData a :: * initialState :: a -> WidgetData a @@ -24,36 +25,67 @@ class WidgetClass a where weight :: a -> Float weight _ = 0 - layout :: a -> Int -> Int -> WidgetData a - layout widget _ _ = initialState widget + layout :: a -> WidgetData a -> Int -> Int -> WidgetData a + layout widget priv _ _ = priv render :: a -> WidgetData a -> Int -> Int -> Render () -data Widget = forall a. WidgetClass a => Widget a +data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => Widget a +deriving instance Show Widget -data WidgetState = forall a. WidgetClass a => WidgetState { stateWidget :: a - , stateWidth :: Int - , stateHeight :: Int - , statePrivateData :: WidgetData a - } +data WidgetState = forall a. (WidgetClass a, Show (WidgetData a)) => WidgetState { stateWidget :: a + , stateX :: Int + , stateY :: Int + , stateWidth :: Int + , stateHeight :: Int + , statePrivateData :: WidgetData a + } +deriving instance Show WidgetState createWidgetState :: Widget -> WidgetState createWidgetState (Widget w) = WidgetState { stateWidget = w + , stateX = 0 + , stateY = 0 , stateWidth = 0 , stateHeight = 0 , statePrivateData = initialState w } -layoutWidgets :: [WidgetState] -> Int -> Int -> [WidgetState] -layoutWidgets widgets w h = map layoutWidget widgets +layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> [WidgetState] +layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets where - layoutWidget state = state { stateWidth = w, stateHeight = h } + sizesum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . minSize $ w) widgets + wsum = let wsum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . weight $ w) widgets + in if wsum > 0 then wsum else 1 + + surplus = width - sizesum + + layoutWidgetAndX wX state = let lw = layoutWidget wX state + in (wX + stateWidth lw, lw) + + layoutWidget wX state = case state of + WidgetState {stateWidget = w, statePrivateData = priv} -> + let wWidth = floor $ (fromIntegral $ minSize w) + (fromIntegral surplus)*(nneg $ weight w)/wsum + priv' = layout w priv wWidth height + in WidgetState { stateWidget = w, stateX = wX, stateY = y, stateWidth = wWidth, stateHeight = height, statePrivateData = priv' } + + nneg :: (Num a, Ord a) => a -> a + nneg x = max 0 x renderWidgets :: [WidgetState] -> Render () -renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget, stateWidth = w, stateHeight = h, statePrivateData = priv } -> render widget priv w h +renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget + , stateX = x + , stateY = y + , stateWidth = w + , stateHeight = h + , statePrivateData = priv } -> do + save + translate (fromIntegral x) (fromIntegral y) + render widget priv w h + restore -data Separator = Separator Int Float +data Separator = Separator Int Float deriving Show instance WidgetClass Separator where type WidgetData Separator = () diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 057d1ee..b79001c 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -115,17 +115,14 @@ updatePanels redraw = 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) + layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0 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 - Widget.renderWidgets layoutedWidgets - restore + renderWith surface $ Widget.renderWidgets layoutedWidgets surfaceFlush surface return panel' @@ -1,4 +1,5 @@ import Phi.Types +import Phi.Widget import Phi.Panel import Phi.Border import Phi.X11 @@ -8,4 +9,7 @@ import Data.Monoid main :: IO () main = do 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 []] + [border1, border2] + where + border1 = border (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2 [] + border2 = border (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.5, 0.0, 0.25, 0.5) 7 1 [] |