phi/lib/Phi/Widget.hs

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

module Phi.Widget ( XEvent(..)
                  , 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 Graphics.XHB
import Graphics.Rendering.Cairo

import Phi.Phi
import Phi.X11.Atoms


data Display = Display !Connection !Atoms

newtype XEvent = XEvent SomeEvent deriving Typeable

instance Show XEvent where
  show _ = "XEvent (..)"


withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
withDisplay (Display conn _) f = f conn

getAtoms :: Display -> Atoms
getAtoms (Display _ atoms) = atoms

data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable)


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


data SurfaceSlice = SurfaceSlice !Int !Surface

class Eq s => Widget w s c | w -> s, w -> c where
  initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> 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

deriving instance Eq RECTANGLE

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