summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Widget.hs
blob: 7bce659775141006f0778a04be66f7a8a674e1d1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}

module Phi.Widget ( Display(..)
                  , withDisplay
                  , getAtoms
                  , getScreenWindows
                  , getScreens
                  , unionArea
                  , Widget(..)
                  , WidgetClass(..)
                  , WidgetState(..)
                  , separator
                  , createWidgetState
                  , layoutWidgets
                  , renderWidgets
                  , handleMessageWidgets
                  ) where

import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class

import Data.Traversable

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


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

  layout :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> WidgetData a
  layout _ priv _ _ _ = priv
  
  render :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> 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
  phi' <- dupPhi phi
  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 -> Xlib.Rectangle -> [WidgetState]
layoutWidgets widgets x y width height screen = snd $ mapAccumL layoutWidgetAndX x widgets
  where
    sizesum = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv} ) -> nneg $ minSize w priv height screen) 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 priv height screen) + (fromIntegral surplus)*(nneg $ weight w)/wsum
            priv' = layout w priv wWidth height screen
        in WidgetState w wX y wWidth height priv'
    
    nneg :: (Num a, Ord a) => a -> a
    nneg x = max 0 x

renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Render ()
renderWidgets widgets screen = 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 screen
  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