146 lines
4.6 KiB
Haskell
146 lines
4.6 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-}
|
|
|
|
module Phi.Widget ( Display(..)
|
|
, withDisplay
|
|
, getAtoms
|
|
, getScreenWindows
|
|
, getScreens
|
|
, unionArea
|
|
, Widget(..)
|
|
, CompoundWidget
|
|
, (<~>)
|
|
, Separator
|
|
, separator
|
|
) where
|
|
|
|
import Control.Arrow
|
|
import Control.Arrow.Transformer
|
|
import Control.CacheArrow
|
|
import Control.Concurrent.MVar
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
|
|
import Data.Traversable hiding (forM)
|
|
|
|
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, Xlib.Window)]
|
|
|
|
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
|
|
|
|
getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)]
|
|
getScreenWindows (Display _ _ screenWindows) = screenWindows
|
|
|
|
getScreens :: Display -> [Xlib.Rectangle]
|
|
getScreens = map fst . getScreenWindows
|
|
|
|
|
|
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, Eq a, Eq d) => Widget a d | a -> d where
|
|
initWidget :: a -> Phi -> Display -> IO d
|
|
|
|
minSize :: a -> d -> Int -> Xlib.Rectangle -> Int
|
|
|
|
weight :: a -> Float
|
|
weight _ = 0
|
|
|
|
layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d
|
|
layout _ priv _ _ _ = priv
|
|
|
|
render :: a -> d -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()
|
|
|
|
handleMessage :: a -> d -> Message -> d
|
|
handleMessage _ priv _ = priv
|
|
|
|
{-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface
|
|
createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
|
|
surface <- createImageSurface FormatARGB32 w h
|
|
renderWith surface $ do
|
|
setOperator OperatorClear
|
|
paint
|
|
setOperator OperatorOver
|
|
render widget state x y w h screen
|
|
return surface-}
|
|
|
|
data CompoundWidget a da b db = (Widget a da, Widget b db) => CompoundWidget !a !b
|
|
deriving instance Eq (CompoundWidget a da b db)
|
|
deriving instance Show (CompoundWidget a da b db)
|
|
|
|
data CompoundState a da b db = (Widget a da, Widget b db) => CompoundState !da !db !Int
|
|
deriving instance Eq (CompoundState a da b db)
|
|
|
|
instance Widget (CompoundWidget a da b db) (CompoundState a da b db) where
|
|
initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0)
|
|
|
|
minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen
|
|
|
|
weight (CompoundWidget a b) = weight' a + weight' b
|
|
|
|
layout c@(CompoundWidget a b) d@(CompoundState da db _) width height screen = CompoundState da' db' xb
|
|
where
|
|
sizesum = minSize c d height screen
|
|
wsum = let wsum = weight c
|
|
in if wsum > 0 then wsum else 1
|
|
|
|
surplus = width - sizesum
|
|
|
|
(xb, da') = layoutWidget a da
|
|
(_, db') = layoutWidget b db
|
|
|
|
layoutWidget w priv = let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(weight' w)/wsum
|
|
in (wWidth, layout w priv wWidth height screen)
|
|
|
|
render (CompoundWidget a b) (CompoundState da db xb) x y w h screen = do
|
|
save
|
|
render a da x y xb h screen
|
|
restore
|
|
translate (fromIntegral xb) 0
|
|
render b db (x+xb) y (w-xb) h screen
|
|
|
|
handleMessage (CompoundWidget a b) (CompoundState da db xb) message = CompoundState (handleMessage a da message) (handleMessage b db message) xb
|
|
|
|
weight' :: (Widget a da) => a -> Float
|
|
weight' = max 0 . weight
|
|
|
|
(<~>) :: (Widget a da, Widget b db) => a -> b -> CompoundWidget a da b db
|
|
a <~> b = CompoundWidget a b
|
|
|
|
data Separator = Separator !Int !Float deriving (Show, Eq)
|
|
|
|
instance Widget Separator () where
|
|
initWidget _ _ _ = return ()
|
|
|
|
minSize (Separator s _) _ _ _ = s
|
|
weight (Separator _ w) = w
|
|
render _ _ _ _ _ _ _ = return ()
|
|
|
|
separator :: Int -> Float -> Separator
|
|
separator = Separator
|