parconc-examples-0.4.4: miscmodules/WindowManager.hs

module WindowManager where

import Control.Concurrent.STM
import Data.Map as Map
import Data.Set as Set
import Data.Maybe

data Window
instance Eq Window
instance Ord Window

data Desktop
instance Eq Desktop
instance Ord Desktop

type Display = Map Desktop (TVar (Set Window))

-- <<moveWindowSTM
moveWindowSTM :: Display -> Window -> Desktop -> Desktop -> STM ()
moveWindowSTM disp win a b = do
  wa <- readTVar ma
  wb <- readTVar mb
  writeTVar ma (Set.delete win wa)
  writeTVar mb (Set.insert win wb)
 where
  ma = disp ! a
  mb = disp ! b
-- >>

-- <<moveWindow
moveWindow :: Display -> Window -> Desktop -> Desktop -> IO ()
moveWindow disp win a b = atomically $ moveWindowSTM disp win a b
-- >>

-- <<swapWindows
swapWindows :: Display
            -> Window -> Desktop
            -> Window -> Desktop
            -> IO ()
swapWindows disp w a v b = atomically $ do
  moveWindowSTM disp w a b
  moveWindowSTM disp v b a
-- >>

render :: Set Window -> IO ()
render = undefined

-- <<UserFocus
type UserFocus = TVar Desktop
-- >>

-- <<getWindows
getWindows :: Display -> UserFocus -> STM (Set Window)
getWindows disp focus = do
  desktop <- readTVar focus
  readTVar (disp ! desktop)
-- >>

-- <<renderThread
renderThread :: Display -> UserFocus -> IO ()
renderThread disp focus = do
  wins <- atomically $ getWindows disp focus    -- <1>
  loop wins                                     -- <2>
 where
  loop wins = do                                -- <3>
    render wins                                 -- <4>
    next <- atomically $ do
               wins' <- getWindows disp focus   -- <5>
               if (wins == wins')               -- <6>
                   then retry                   -- <7>
                   else return wins'            -- <8>
    loop next
-- >>