phi/lib/Phi/Widget.hs

{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-}

module Phi.Widget ( Display(..)
                  , withDisplay
                  , getAtoms
                  , getScreenWindows
                  , getScreens
                  , unionArea
                  , Widget(..)
                  , WidgetClass(..)
                  , WidgetState(..)
                  , separator
                  , createWidgetState
                  , layoutWidgets
                  , renderWidgets
                  , handleMessageWidgets
                  ) 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) => WidgetClass 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

data Widget = forall a d. WidgetClass a d => Widget !a
deriving instance Show Widget

instance Eq Widget where
  _ == _ = False

data WidgetState = forall a d. WidgetClass a d =>
                   WidgetState { stateWidget      :: !a
                               , stateX           :: !Int
                               , stateY           :: !Int
                               , stateWidth       :: !Int
                               , stateHeight      :: !Int
                               , statePrivateData :: !d
                               , stateRender      :: !(CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface)
                               }

instance Eq WidgetState where
  _ == _ = False

createStateRender :: WidgetClass 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

createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
createWidgetState phi disp (Widget w) = do
  priv <- initWidget w phi disp
  return WidgetState { stateWidget = w
                     , stateX = 0
                     , stateY = 0
                     , stateWidth = 0
                     , stateHeight = 0
                     , statePrivateData = priv
                     , stateRender = createStateRender
                     }

layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> [WidgetState]
layoutWidgets widgets x y width height screen = snd $ mapAccumL layoutWidgetAndX x widgets
  where
    sizesum = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv} ) -> nneg $ minSize w priv height screen) 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, stateRender = render} ->
        let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(nneg $ weight w)/wsum
            priv' = layout w priv wWidth height screen
        in WidgetState w wX y wWidth height priv' render
    
    nneg :: (Num a, Ord a) => a -> a
    nneg x = max 0 x

renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Int -> Int -> Render [WidgetState]
renderWidgets widgets screen winX winY = forM widgets $ \(WidgetState widget x y w h priv render) -> do
  (surface, render') <- liftIO $ runKleisli (runCache render) (widget, priv, winX+x, winY+y, w, h, screen)
  
  save
  translate (fromIntegral x) (fromIntegral y)
  withPatternForSurface surface setSource
  paint
  restore
  
  return $ WidgetState widget x y w h priv render'

handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
handleMessageWidgets message = map handleMessageWidget
  where
    handleMessageWidget (WidgetState w x y width height priv render) = WidgetState w x y width height (handleMessage w priv message) render

data Separator = Separator Int Float deriving (Show, Eq)

instance WidgetClass Separator () where
  initWidget _ _ _ = return ()
  
  minSize (Separator s _) _ _ _ = s
  weight (Separator _ w) = w
  render _ _ _ _ _ _ _ = return ()

separator :: Int -> Float -> Widget
separator s w = Widget $ Separator s w