phi/lib/Phi/Widget.hs

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

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

import Control.Arrow
import Control.Arrow.Transformer
import Control.CacheArrow
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class

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

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

{-createStateRender :: Widget 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-}

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)
  
  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
    surfacea <- render a sa x y xb h screen
    surfaceb <- render b sb (x+xb) y (w-xb) h screen
    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 () () where
  initWidget _ _ _ = return ()
  
  minSize (Separator s _) _ _ _ = s
  weight (Separator _ w) = w
  render _ _ _ _ width height _ = do
    surface <- createImageSurface FormatARGB32 width height
    renderWith surface $ do
      setOperator OperatorClear
      paint
    return [(True, SurfaceSlice 0 surface)]


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