99 lines
3.9 KiB
Haskell
99 lines
3.9 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
|
|
|
|
module Phi.Widget ( Widget(..)
|
|
, WidgetClass(..)
|
|
, WidgetState(..)
|
|
, separator
|
|
, createWidgetState
|
|
, layoutWidgets
|
|
, renderWidgets
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Data.Traversable
|
|
|
|
import Graphics.Rendering.Cairo
|
|
|
|
|
|
class Show a => WidgetClass a where
|
|
type WidgetData a :: *
|
|
|
|
initialState :: a -> WidgetData a
|
|
|
|
minSize :: a -> Int
|
|
|
|
weight :: a -> Float
|
|
weight _ = 0
|
|
|
|
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, Show (WidgetData a)) => Widget a
|
|
deriving instance Show Widget
|
|
|
|
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 -> Int -> Int -> [WidgetState]
|
|
layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets
|
|
where
|
|
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
|
|
, 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 deriving Show
|
|
|
|
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
|