module Manatee.UI.Window where
import Control.Applicative hiding (empty)
import Control.Concurrent.STM
import Control.Monad.State
import Data.List
import Data.Maybe
import Graphics.UI.Gtk hiding (Window, windowNew, get)
import Manatee.Types
import Manatee.UI.FocusNotifier
import Manatee.UI.WindowNode
import Manatee.Toolkit.Data.ListZipper hiding (length, delete, get)
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.State
import Manatee.Toolkit.Gtk.Container
import Manatee.Toolkit.Gtk.Gtk
import qualified Manatee.Toolkit.Data.ListZipper as LZ
windowNew :: WindowNodeType -> WindowNodeDirection -> Maybe WindowNode -> Container -> TVar FocusNotifierList -> WindowListTuple -> IO (Window, WindowListTuple)
windowNew vnType direction parentNode container focusNotifierList (windowList, windowNodeList) =
runStateT_ (windowList, windowNodeList) $ do
node <- modifyM_ (\(wList, nList) -> do
(node, nnList) <- windowNodeNew parentNode vnType direction (nList, container)
return (node, (wList, nnList))) snd fst
notebook <- lift notebookNew
let window = Window node notebook
lift $ do
set notebook [notebookScrollable := True]
notifierFrame <- frameNewWithShadowType Nothing
windowGetContainer window `containerAdd` notifierFrame
notifierFrame `containerAdd` notebook
focusNotifierNew (windowGetId window) notifierFrame focusNotifierList
widgetShowAll (windowNodePaned node)
vnType <- lift $ windowNodeGetType node
modifyFst (\(wList, _) -> windowListAddWindow wList window vnType)
return window
windowRootNew :: WindowArgs -> TVar FocusNotifierList -> IO (Window, WindowListTuple)
windowRootNew (windowList, windowNodeList, container) focusNotifierList =
runStateT_ (windowList, windowNodeList) $ do
window <- modifyM_ (windowNew TNodeRoot DVertical Nothing container focusNotifierList) snd fst
modifyFst (\(wList, _) -> windowListFocus wList window)
return window
windowInit :: WindowArgs -> TVar FocusNotifierList -> IO (WindowList, WindowNodeList)
windowInit (windowList, windowNodeList, container) focusNotifierList =
runStateT' (windowList, windowNodeList) $
when (isEmpty windowList) $
modifyM (\(wList, nList) -> do
containerRemoveAll container
snd <$> windowRootNew (wList, nList, container) focusNotifierList)
windowSplitInternal :: WindowNodeDirection
-> Window
-> TVar WindowList
-> TVar WindowNodeList
-> TVar FocusNotifierList
-> Container
-> IO (Window, Window)
windowSplitInternal direction windowParent windowList windowNodeList focusNotifierList container = do
oldWindowList <- readTVarIO windowList
oldWindowNodeList <- readTVarIO windowNodeList
((wc1, wc2), (newWindowList, newWindowNodeList)) <- runStateT_ (oldWindowList, oldWindowNodeList) $ do
parentNode <- modifyM_ (\(wList, nList) -> do
(pNode, nnList) <- windowNodeGetSplitContainer
(windowNode windowParent)
direction
(nList, container)
return (pNode, (wList, nnList))) snd fst
windowChild1 <- modifyM_ (windowNew TNodeLeft direction (Just parentNode) container focusNotifierList) snd fst
windowChild2 <- modifyM_ (windowNew TNodeRight direction (Just parentNode) container focusNotifierList) snd fst
modifyFst (\(wList, _) -> windowListRemoveWindow windowParent wList)
lift $ widgetShowAll (windowNodePaned parentNode)
nodeList <- gets snd
lift $
containerApplySize container $ \width height -> do
windowNodeSetSizeRequest (windowNode windowChild1) nodeList (width, height)
windowNodeSetSizeRequest (windowNode windowChild2) nodeList (width, height)
return (windowChild1, windowChild2)
writeTVarIO windowList newWindowList
writeTVarIO windowNodeList newWindowNodeList
return (wc1, wc2)
windowRemoveInternal :: (Window, (Container, (WindowList, WindowNodeList))) -> IO WindowListTuple
windowRemoveInternal (window, (container, (windowList, windowNodeList))) =
runStateT' (windowList, windowNodeList) $
case windowListGetSize windowList of
0 -> lift $ putStrLn "Haven't any window exist."
_ -> do
modifySndM (\(_, nList) ->
windowNodeRemove (windowNode window) (nList, container) True)
modifyFst (\(wList, _) -> windowListRemoveWindow window wList)
windowRemoveOthers :: Window -> WindowArgs -> IO WindowListTuple
windowRemoveOthers window (windowList, windowNodeList, container) =
runStateT' (windowList, windowNodeList) $
case windowListGetSize windowList of
0 -> lift $ putStrLn "Haven't any window exist."
1 -> lift $ putStrLn "Haven't others window exist."
_ -> do
modifySndM (\(_, nList) -> windowNodeRemoveOthers (windowNode window) (nList, container))
modifyFst (\(wList, _) -> windowListRemoveOthersWindow wList)
modifyFst (\(wList, _) -> windowListFocus wList window)
windowGetContainer :: Window -> Paned
windowGetContainer = windowNodePaned . windowNode
windowGetId :: Window -> WindowId
windowGetId = windowNodeId . windowNode
windowListNew :: WindowList
windowListNew = empty
windowListAddWindow :: WindowList -> Window -> WindowNodeType -> WindowList
windowListAddWindow windowList window TNodeLeft = insertLeft window windowList
windowListAddWindow windowList window _ = insertRight window windowList
windowListRemoveOthersWindow :: WindowList -> WindowList
windowListRemoveOthersWindow windowList =
fromMaybe windowList (deleteOthers windowList)
windowListGetFocusWindow :: TVar WindowList -> TVar WindowNodeList -> TVar FocusNotifierList -> Container -> IO (Maybe Window)
windowListGetFocusWindow windowList windowNodeList focusNotifierList container = do
wList <- readTVarIO windowList
wnList <- readTVarIO windowNodeList
(newWindowList, newWindowNodeList) <- windowInit (wList, wnList, container) focusNotifierList
writeTVarIO windowList newWindowList
writeTVarIO windowNodeList newWindowNodeList
return $ getCurrent newWindowList
windowListGetWindow :: WindowId -> WindowList -> Maybe Window
windowListGetWindow id windowList =
find (\v -> windowNodeId (windowNode v) == id) (windowListGetList windowList)
windowListApplyWithId :: WindowList -> WindowId -> (Window -> IO ()) -> IO ()
windowListApplyWithId windowList id f =
windowListGetWindow id windowList ?>= f
windowListGetList :: WindowList -> [Window]
windowListGetList = toList
windowListShow ::WindowList -> IO ()
windowListShow = print . show . windowListGetList
windowListGetSize :: WindowList -> Int
windowListGetSize = LZ.length
windowListApplyWindow :: (Window -> IO ()) -> WindowList -> IO ()
windowListApplyWindow f windowList = mapM_ f $ windowListGetList windowList
windowListSelect :: WindowListSelectDirection -> Bool -> WindowList -> WindowList
windowListSelect direction circular windowList = newWindowList
where selectFunction =
case direction of
VLeft -> if circular
then getLeftCircular
else getLeft
VRight -> if circular
then getRightCircular
else getRight
newWindowList = case selectFunction windowList of
Just x -> windowListFocus windowList x
Nothing -> windowList
windowListNext :: WindowList -> WindowList
windowListNext = windowListSelect VRight False
windowListPrev :: WindowList -> WindowList
windowListPrev = windowListSelect VLeft False
windowListNextCircular :: WindowList -> WindowList
windowListNextCircular = windowListSelect VRight True
windowListPrevCircular :: WindowList -> WindowList
windowListPrevCircular = windowListSelect VLeft True
windowListFocus :: WindowList -> Window -> WindowList
windowListFocus windowList window =
fromMaybe windowList (focusNode window windowList)
windowListFocusId :: WindowList -> WindowId -> WindowList
windowListFocusId windowList windowId =
case windowListGetWindow windowId windowList of
Just w -> windowListFocus windowList w
Nothing -> windowList
windowListRemoveCurrentWindow :: WindowList -> WindowList
windowListRemoveCurrentWindow windowList = newWindowList
where
nextFocus = getRightCircular windowList
wList = fromMaybe windowList (LZ.delete windowList)
newWindowList = case nextFocus of
Just x -> windowListFocus wList x
Nothing -> wList
windowListRemoveWindow :: Window -> WindowList -> WindowList
windowListRemoveWindow window windowList = do
let newWindowList = fromMaybe windowList $ LZ.deleteNode window windowList
case LZ.getCurrent newWindowList of
Just _ -> newWindowList
Nothing ->
case LZ.getRightCircular newWindowList of
Just x -> windowListFocus newWindowList x
Nothing -> newWindowList