phi/lib/Phi/Widget.hs

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

module Phi.Widget ( Display(..)
                  , withDisplay
                  , getAtoms
                  , XMessage(..)
                  , unionArea
                  , SurfaceSlice(..)
                  , Widget(..)
                  , CompoundWidget
                  , (<~>)
                  , IOCache
                  , RenderCache
                  , createIOCache
                  , runIOCache
                  , 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 Data.Typeable

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

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

data XMessage = UpdateScreens [(Xlib.Rectangle, Xlib.Window)] deriving (Show, Typeable)


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 Eq s => Widget w s c | w -> s, w -> c where
  initWidget :: w -> Phi -> Display -> [(Xlib.Rectangle, Xlib.Window)] -> IO s
  
  initCache :: w -> c
  
  minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
  
  weight :: w -> Float
  weight _ = 0

  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 s = IOCache (s, Int, Int, Int, Int, Xlib.Rectangle) Surface

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

runIOCache :: Eq a => a -> StateT (IOCache a b) IO b
runIOCache a = do
  cache <- get
  (b, cache') <- liftIO $ runKleisli (runCache cache) a
  put cache'
  return b

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

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

data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb
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 screens = liftM2 CompoundState (initWidget a phi disp screens) (initWidget b phi disp screens)
  
  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

  render c@(CompoundWidget a b) s@(CompoundState sa sb) x y w h screen = do
    let sizesum = minSize c s h screen
        wsum = let wsum = weight c
               in if wsum > 0 then wsum else 1
        surplus = w - sizesum
        xb = floor $ (fromIntegral $ minSize a sa h screen) + (fromIntegral surplus)*(weight' a)/wsum
    
    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) message = CompoundState (handleMessage a sa message) (handleMessage b sb message)

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 ()) 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