153 lines
5.5 KiB
Haskell
153 lines
5.5 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
|
|
|
|
module Phi.Widget ( Display(..)
|
|
, withDisplay
|
|
, getAtoms
|
|
, getScreens
|
|
, unionArea
|
|
, Widget(..)
|
|
, WidgetClass(..)
|
|
, WidgetState(..)
|
|
, separator
|
|
, createWidgetState
|
|
, layoutWidgets
|
|
, renderWidgets
|
|
, handleMessageWidgets
|
|
) where
|
|
|
|
import Control.Concurrent.MVar
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
|
|
import Data.Traversable
|
|
|
|
import qualified Graphics.X11.Xlib as Xlib
|
|
import Graphics.Rendering.Cairo
|
|
|
|
import Phi.Phi
|
|
import Phi.X11.Atoms
|
|
|
|
|
|
data Display = Display (MVar Xlib.Display) Atoms [Xlib.Rectangle]
|
|
|
|
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
|
|
withDisplay (Display dispvar _ _) f = do
|
|
disp <- liftIO $ takeMVar dispvar
|
|
a <- f disp
|
|
liftIO $ putMVar dispvar disp
|
|
return a
|
|
|
|
getAtoms :: Display -> Atoms
|
|
getAtoms (Display _ atoms _) = atoms
|
|
|
|
getScreens :: Display -> [Xlib.Rectangle]
|
|
getScreens (Display _ _ screens) = screens
|
|
|
|
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
|
|
unionArea a b = fromIntegral $ uw*uh
|
|
where
|
|
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
|
|
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
|
|
|
|
Xlib.Rectangle ax1 ay1 aw ah = a
|
|
Xlib.Rectangle bx1 by1 bw bh = b
|
|
|
|
ax2 = ax1 + fromIntegral aw
|
|
ay2 = ay1 + fromIntegral ah
|
|
|
|
bx2 = bx1 + fromIntegral bw
|
|
by2 = by1 + fromIntegral bh
|
|
|
|
|
|
class Show a => WidgetClass a where
|
|
type WidgetData a :: *
|
|
|
|
initWidget :: a -> Phi -> Display -> IO (WidgetData a)
|
|
|
|
minSize :: a -> WidgetData a -> Int -> Int
|
|
|
|
weight :: a -> Float
|
|
weight _ = 0
|
|
|
|
layout :: a -> WidgetData a -> Int -> Int -> WidgetData a
|
|
layout _ priv _ _ = priv
|
|
|
|
render :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> Render ()
|
|
|
|
handleMessage :: a -> WidgetData a -> Message -> WidgetData a
|
|
handleMessage _ priv _ = priv
|
|
|
|
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 :: Phi -> Display -> Widget -> IO WidgetState
|
|
createWidgetState phi disp (Widget w) = do
|
|
phi' <- dupPhi phi
|
|
priv <- initWidget w phi' disp
|
|
return WidgetState { stateWidget = w
|
|
, stateX = 0
|
|
, stateY = 0
|
|
, stateWidth = 0
|
|
, stateHeight = 0
|
|
, statePrivateData = priv
|
|
}
|
|
|
|
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, statePrivateData = priv} ) -> nneg $ minSize w priv height) 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 priv height) + (fromIntegral surplus)*(nneg $ weight w)/wsum
|
|
priv' = layout w priv wWidth height
|
|
in WidgetState w wX y wWidth height priv'
|
|
|
|
nneg :: (Num a, Ord a) => a -> a
|
|
nneg x = max 0 x
|
|
|
|
renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Render ()
|
|
renderWidgets widgets screen = 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 screen
|
|
restore
|
|
|
|
handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
|
|
handleMessageWidgets message = map handleMessageWidget
|
|
where
|
|
handleMessageWidget (WidgetState w x y width height priv) = WidgetState w x y width height $ handleMessage w priv message
|
|
|
|
data Separator = Separator Int Float deriving Show
|
|
|
|
instance WidgetClass Separator where
|
|
type WidgetData Separator = ()
|
|
initWidget _ _ _ = return ()
|
|
|
|
minSize (Separator s _) _ _ = s
|
|
weight (Separator _ w) = w
|
|
render _ _ _ _ _ = return ()
|
|
|
|
separator :: Int -> Float -> Widget
|
|
separator s w = Widget $ Separator s w
|