phi/lib/Phi/Widget.hs

{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}

module Phi.Widget ( Display(..)
                  , withDisplay
                  , getAtoms
                  , getScreenWindows
                  , getScreens
                  , unionArea
                  , SurfaceSlice(..)
                  , Widget(..)
                  , CompoundWidget
                  , (<~>)
                  , IOCache
                  , RenderCache
                  , createIOCache
                  , createRenderCache
                  , renderCached
                  , Separator
                  , separator
                  ) where

import Control.Arrow
import Control.Arrow.Transformer
import Control.CacheArrow
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.State.Strict hiding (lift)
import Control.Monad.IO.Class

import Data.Maybe

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


data SurfaceSlice = SurfaceSlice !Int !Surface

class (Show w, Eq w, Eq s) => Widget w s c | w -> s, w -> c where
  initWidget :: w -> Phi -> Display -> IO s
  
  initCache :: w -> c
  
  minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
  
  weight :: w -> Float
  weight _ = 0

  layout :: w -> s -> Int -> Int -> Xlib.Rectangle -> s
  layout _ priv _ _ _ = priv
  
  render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
  
  handleMessage :: w -> s -> Message -> s
  handleMessage _ priv _ = priv

type IOCache = CacheArrow (Kleisli IO)
type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface

createIOCache :: Eq a => (a -> IO b) -> IOCache a b
createIOCache = lift . Kleisli

createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
                     -> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
  surface <- createImageSurface FormatARGB32 w h
  renderWith surface $ do
    setOperator OperatorClear
    paint
    setOperator OperatorOver
    f widget state x y w h screen
  return surface

renderCached :: (Eq w, Eq s) => w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT (RenderCache w s) IO [(Bool, SurfaceSlice)]
renderCached widget state x y w h screen = do
  cache <- get
  (surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (widget, state, x, y, w, h, screen)
  put cache'
  return [(updated, SurfaceSlice 0 surf)]

data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
deriving instance Eq (CompoundWidget a sa ca b sb cb)
deriving instance Show (CompoundWidget a sa ca b sb cb)

data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int
deriving instance Eq (CompoundState a sa ca b sb cb)

data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb


instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
  initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0)
  
  initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b)
  
  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) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb
    where
      sizesum = minSize c s height screen
      wsum = let wsum = weight c
             in if wsum > 0 then wsum else 1
    
      surplus = width - sizesum
      
      (xb, sa') = layoutWidget a sa
      (_, sb') = layoutWidget b sb
      
      layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum
                            in (wWidth, layout w s wWidth height screen)
  
  render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do
    CompoundCache ca cb <- get
    (surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen
    (surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen
    put $ CompoundCache ca' cb'
    return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb
    
  handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb

weight' :: (Widget a sa ca) => a -> Float
weight' = max 0 . weight

(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb
a <~> b = CompoundWidget a b

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

instance Widget Separator () (RenderCache Separator ()) where
  initWidget _ _ _ = return ()
  initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do
    setOperator OperatorClear
    paint
  
  minSize (Separator s _) _ _ _ = s
  weight (Separator _ w) = w
  render = renderCached


separator :: Int -> Float -> Separator
separator = Separator