phi/lib/Phi/Widget.hs

{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}

module Phi.Widget ( Display
                  , Widget(..)
                  , WidgetClass(..)
                  , WidgetState(..)
                  , separator
                  , createWidgetState
                  , layoutWidgets
                  , renderWidgets
                  , handleMessageWidgets
                  ) where

import Control.Concurrent
import Control.Monad

import Data.Traversable

import qualified Graphics.X11.Xlib

import Graphics.Rendering.Cairo

import Phi.Phi


type Display = MVar Graphics.X11.Xlib.Display


class Show a => WidgetClass a where
  type WidgetData a :: *
  
  initWidget :: a -> Phi -> Display -> IO (WidgetData a)
  
  minSize :: a -> Int
  
  weight :: a -> Float
  weight _ = 0

  layout :: a -> WidgetData a -> Int -> Int -> WidgetData a
  layout _ priv _ _ = priv
  
  render :: a -> WidgetData a -> Int -> Int -> Render ()
  
  handleMessage :: a -> WidgetData a -> Message -> WidgetData a
  handleMessage _ priv _ = priv

data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => Widget a
deriving instance Show Widget

data WidgetState = forall a. (WidgetClass a, Show (WidgetData a)) => WidgetState { stateWidget      :: a
                                                                                 , stateX           :: Int
                                                                                 , stateY           :: Int
                                                                                 , stateWidth       :: Int
                                                                                 , stateHeight      :: Int
                                                                                 , statePrivateData :: WidgetData a
                                                                                 }
deriving instance Show WidgetState

createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
createWidgetState phi disp (Widget w) = do
  priv <- initWidget w phi disp
  return WidgetState { stateWidget = w
                     , stateX = 0
                     , stateY = 0
                     , stateWidth = 0
                     , stateHeight = 0
                     , statePrivateData = priv
                     }

layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> [WidgetState]
layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets
  where
    sizesum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . minSize $ w) widgets
    wsum = let wsum = sum $ map (\(WidgetState {stateWidget = w} ) ->  nneg . weight $ w) widgets
             in if wsum > 0 then wsum else 1
    
    surplus = width - sizesum
    
    layoutWidgetAndX wX state = let lw = layoutWidget wX state
                                    in (wX + stateWidth lw, lw)
    
    layoutWidget wX state = case state of
      WidgetState {stateWidget = w, statePrivateData = priv} ->
        let wWidth = floor $ (fromIntegral $ minSize w) + (fromIntegral surplus)*(nneg $ weight w)/wsum
            priv' = layout w priv wWidth height
        in WidgetState w wX y wWidth height priv'
    
    nneg :: (Num a, Ord a) => a -> a
    nneg x = max 0 x

renderWidgets :: [WidgetState] -> Render ()
renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget
                                                     , stateX = x
                                                     , stateY = y
                                                     , stateWidth = w
                                                     , stateHeight = h
                                                     , statePrivateData = priv } -> do
  save
  translate (fromIntegral x) (fromIntegral y)
  render widget priv w h
  restore

handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
handleMessageWidgets message = map handleMessageWidget
  where
    handleMessageWidget (WidgetState w x y width height priv) = WidgetState w x y width height $ handleMessage w priv message

data Separator = Separator Int Float deriving Show

instance WidgetClass Separator where
  type WidgetData Separator = ()
  initWidget _ _ _ = return ()
  
  minSize (Separator s _) = s
  weight (Separator _ w) = w
  render _ _ _ _ = return ()

separator :: Int -> Float -> Widget
separator s w = Widget $ Separator s w