phi/lib/Phi/Widget.hs

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

module Phi.Widget ( Rectangle(..)
                  , Display(..)
                  , 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.Monad
import Control.Monad.State.Strict hiding (lift)
import Control.Monad.IO.Class

import Data.Maybe
import Data.Typeable

import Graphics.Rendering.Cairo

import Phi.Phi
import Phi.X11.Atoms


data Rectangle = Rectangle { rect_x :: !Int
                           , rect_y :: !Int
                           , rect_width :: !Int
                           , rect_height :: !Int
                           } deriving (Show, Eq)

class Display d where
  type Window d :: *


unionArea :: Rectangle -> Rectangle -> Int
unionArea a b = uw*uh
  where
    uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
    uh = max 0 $ (min ay2 by2) - (max ay1 by1)
    
    Rectangle ax1 ay1 aw ah = a
    Rectangle bx1 by1 bw bh = b
    
    ax2 = ax1 + aw
    ay2 = ay1 + ah
    
    bx2 = bx1 + bw
    by2 = by1 + bh


data SurfaceSlice = SurfaceSlice !Int !Surface

class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where
  initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s
  
  initCache :: w -> c
  
  minSize :: w -> s -> Int -> Rectangle -> Int
  
  weight :: w -> Float
  weight _ = 0

  render :: w -> s -> Int -> Int -> Int -> Int -> 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, 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 -> Rectangle -> Render ())
                     -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, 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 -> 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 d = (Widget a sa ca d, Widget b sb cb d) => CompoundWidget !a !b

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

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


instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a sa ca b sb cb d) (CompoundCache a sa ca b sb cb d) d 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 d) => a -> Float
weight' = max 0 . weight

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

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

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


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