module Manatee.UI.WindowNode where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.State
import Data.Maybe
import Graphics.UI.Gtk hiding (on, get)
import Manatee.Types
import Manatee.Toolkit.Data.SetList
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 Text.Printf
zoomDefaultSize :: Int
zoomDefaultSize = 10
windowNodeNew :: Maybe WindowNode -> WindowNodeType -> WindowNodeDirection -> WindowNodeArgs -> IO (WindowNode, WindowNodeList)
windowNodeNew parentNode nType direction =
windowNodeNewInternal (Nothing, maybeApply parentNode windowNodeId, Nothing, Nothing, nType, direction)
windowNodeNewInternal :: WindowNodeAttr -> WindowNodeArgs -> IO (WindowNode, WindowNodeList)
windowNodeNewInternal (vId, pId, clId, crId, typ, direction) (windowNodeList, container) =
runStateT_ nodeList $ do
windowNode <- lift $ WindowNode id
<$> windowNodePanedNew direction
<*> newTVarIO pId
<*> newTVarIO clId
<*> newTVarIO crId
<*> newTVarIO typ
<*> pure direction
lift $ windowNodeConnectToParent windowNode (nodeList, container)
modify (`setListAddNode` windowNode)
return windowNode
where (id, nodeList) =
case vId of
Just vi -> (vi, windowNodeList)
Nothing -> setListGetNewCounter windowNodeList
windowNodeRemove :: WindowNode -> WindowNodeArgs -> Bool -> IO WindowNodeList
windowNodeRemove windowNode (windowNodeList, container) removeOtioseNode =
runStateT' windowNodeList $ do
vType <- lift $ windowNodeGetType windowNode
modify (`setListRemoveNode` windowNode)
getM (\x -> windowNodePanedRemove windowNode (x, container))
unless (vType == TNodeRoot) $ do
parentNode <- getM (windowNodeGetParentNode windowNode)
case parentNode of
Just n -> do
lift $ windowNodeRemoveFromParentNode windowNode n
when removeOtioseNode $ do
haveChildNode <- lift $ windowNodeIsHaveChildNode n
unless haveChildNode $ modifyM (\x -> windowNodeRemove n (x, container) True)
windowNodeRemoveOthers :: WindowNode -> WindowNodeArgs -> IO WindowNodeList
windowNodeRemoveOthers windowNode (windowNodeList, container) = do
windowNodeChangeToRoot windowNode (windowNodeList, container)
containerRemoveAll container
windowNodeConnectToRootContainer windowNode container
return $ setListRemoveOthersNode windowNodeList windowNode
windowNodeGetParentNode :: WindowNode -> WindowNodeList -> IO (Maybe WindowNode)
windowNodeGetParentNode windowNode windowNodeList =
readTVarIO (windowNodeParentId windowNode) >>=
(?>=> (return . windowNodeListGetNode windowNodeList))
windowNodeGetSplitContainer :: WindowNode -> WindowNodeDirection -> WindowNodeArgs -> IO (WindowNode, WindowNodeList)
windowNodeGetSplitContainer windowNode direction (windowNodeList, container) =
runStateT_ windowNodeList $
if windowNodeDirection windowNode == direction
then do
lift $ containerRemoveAll $ windowNodePaned windowNode
return windowNode
else do
modifyM (\x -> windowNodeRemove windowNode (x, container) False)
parentNode <- getM (windowNodeGetParentNode windowNode)
vType <- lift $ windowNodeGetType windowNode
modifyM_ (\x -> windowNodeNew parentNode vType direction (x, container)) snd fst
windowNodeChangeToRoot :: WindowNode -> WindowNodeArgs -> IO ()
windowNodeChangeToRoot windowNode (windowNodeList, container) = do
windowNodePanedRemove windowNode (windowNodeList, container)
writeTVarIO (windowNodeParentId windowNode) Nothing
writeTVarIO (windowNodeChildLeftId windowNode) Nothing
writeTVarIO (windowNodeChildRightId windowNode) Nothing
writeTVarIO (windowNodeType windowNode) TNodeRoot
windowNodeConnectToParent :: WindowNode -> WindowNodeArgs -> IO ()
windowNodeConnectToParent windowNode (windowNodeList, container) = do
vType <- windowNodeGetType windowNode
case vType of
TNodeRoot -> windowNodeConnectToRootContainer windowNode container
TNodeLeft -> windowNodeConnectToParentNodeLeft windowNode windowNodeList
TNodeRight -> windowNodeConnectToParentNodeRight windowNode windowNodeList
windowNodeConnectToRootContainer :: ContainerClass container => WindowNode -> container -> IO ()
windowNodeConnectToRootContainer windowNode =
(`containerAdd` windowNodePaned windowNode)
windowNodeConnectToParentNodeLeft :: WindowNode -> WindowNodeList -> IO ()
windowNodeConnectToParentNodeLeft windowNode windowNodeList =
windowNodeGetParentNode windowNode windowNodeList >>=
(?>= (\n -> do
let vParentPaned = windowNodePaned n
vPaned = windowNodePaned windowNode
id = windowNodeId windowNode
panedPack1 vParentPaned vPaned True True
writeTVarIO (windowNodeChildLeftId n) (Just id)))
windowNodeConnectToParentNodeRight :: WindowNode -> WindowNodeList -> IO ()
windowNodeConnectToParentNodeRight windowNode windowNodeList =
windowNodeGetParentNode windowNode windowNodeList >>=
(?>= (\n -> do
let vParentPaned = windowNodePaned n
vPaned = windowNodePaned windowNode
id = windowNodeId windowNode
panedPack2 vParentPaned vPaned True True
writeTVarIO (windowNodeChildRightId n) (Just id)
))
windowNodePanedNew :: WindowNodeDirection -> IO Paned
windowNodePanedNew DVertical
= castToPaned <$> vPanedNew
windowNodePanedNew _
= castToPaned <$> hPanedNew
windowNodePanedRemove :: WindowNode -> WindowNodeArgs -> IO ()
windowNodePanedRemove windowNode (windowNodeList, container) = do
let vPaned = windowNodePaned windowNode
vType <- windowNodeGetType windowNode
case vType of
TNodeRoot -> container `containerRemove` vPaned
_ ->
windowNodeGetParentNode windowNode windowNodeList >>=
(?>= (\n -> windowNodePaned n `containerRemove` vPaned))
windowNodeIsHaveChildNode :: WindowNode -> IO Bool
windowNodeIsHaveChildNode windowNode = do
childLeftId <- windowNodeGetChildLeftId windowNode
childRightId <- windowNodeGetChildRightId windowNode
return $ isJust childLeftId || isJust childRightId
windowNodeRemoveFromParentNode :: WindowNode -> WindowNode -> IO ()
windowNodeRemoveFromParentNode windowNode n = do
vnType <- windowNodeGetType windowNode
case vnType of
TNodeLeft -> writeTVarIO (windowNodeChildLeftId n) Nothing
TNodeRight -> writeTVarIO (windowNodeChildRightId n) Nothing
_ -> return ()
windowNodeGetType :: WindowNode -> IO WindowNodeType
windowNodeGetType =
readTVarIO . windowNodeType
windowNodeGetParentId :: WindowNode -> IO (Maybe WindowNodeId)
windowNodeGetParentId =
readTVarIO . windowNodeParentId
windowNodeGetChildLeftId :: WindowNode -> IO (Maybe WindowNodeId)
windowNodeGetChildLeftId =
readTVarIO . windowNodeChildLeftId
windowNodeGetChildRightId :: WindowNode -> IO (Maybe WindowNodeId)
windowNodeGetChildRightId =
readTVarIO . windowNodeChildRightId
windowNodeSetSizeRequest :: WindowNode -> WindowNodeList -> (Int, Int) -> IO ()
windowNodeSetSizeRequest currentNode nodeList (width, height) = do
(vSplitTimes, hSplitTimes) <- windowNodeGetSplitTimes currentNode nodeList (0, 0)
let requestHeight = height `div` (^) 2 vSplitTimes
requestWidth = width `div` (^) 2 hSplitTimes
widgetSetSizeRequest (windowNodePaned currentNode) requestWidth requestHeight
windowNodeGetSplitTimes :: WindowNode -> WindowNodeList -> (Int, Int) -> IO (Int, Int)
windowNodeGetSplitTimes windowNode nodeList (vSplit, hSplit) = do
parentNode <- windowNodeGetParentNode windowNode nodeList
case parentNode of
Just pn -> do
let direction = windowNodeDirection pn
splitTimes =
if direction == DVertical
then (vSplit + 1, hSplit)
else (vSplit, hSplit + 1)
nodeType <- readTVarIO $ windowNodeType pn
case nodeType of
TNodeRoot -> return splitTimes
_ -> windowNodeGetSplitTimes pn nodeList splitTimes
windowNodeShow :: WindowNode -> IO ()
windowNodeShow windowNode = do
let id = windowNodeId windowNode
parentId <- windowNodeGetParentId windowNode
leftId <- windowNodeGetChildLeftId windowNode
rightId <- windowNodeGetChildRightId windowNode
printf "Node (%s) <ParentId: %s, LeftCId: %s, RightCId: %s>\n" (show id) (show parentId) (show leftId) (show rightId)
windowNodeListNew :: WindowNodeList
windowNodeListNew = setListNew
windowNodeListGetNode :: WindowNodeList -> WindowNodeId -> Maybe WindowNode
windowNodeListGetNode windowNodeList id =
setListGetNode windowNodeList (\y -> windowNodeId y == id)
windowNodeListShow :: WindowNodeList -> IO ()
windowNodeListShow windowNodeList =
mapM_ windowNodeShow $ setListGetList windowNodeList
windowNodeGetZoomDirection :: WindowNode -> WindowNode -> IO ZoomDirection
windowNodeGetZoomDirection node parentNode = do
nodeType <- readTVarIO $ windowNodeType node
let nodeDirection = windowNodeDirection parentNode
return $ if nodeType == TNodeRight
then if nodeDirection == DVertical then ZDown else ZRight
else if nodeDirection == DVertical then ZUp else ZLeft
windowNodeGetMatchZoomDirectionSize :: ZoomDirection -> Bool -> (ZoomDirection, Int)
windowNodeGetMatchZoomDirectionSize zoomDirection isEnlarge
| zoomDirection == ZUp = (ZDown, if isEnlarge then zoomDefaultSize else zoomDefaultSize)
| zoomDirection == ZDown = (ZUp, if isEnlarge then zoomDefaultSize else zoomDefaultSize)
| zoomDirection == ZLeft = (ZRight, if isEnlarge then zoomDefaultSize else zoomDefaultSize)
| otherwise = (ZLeft, if isEnlarge then zoomDefaultSize else zoomDefaultSize)
windowNodeZoom :: WindowNodeList -> WindowNode -> ZoomDirection -> Bool -> IO ()
windowNodeZoom nodeList node enlargeDirection isEnlarge = do
let (matchDirection, adjustSize) = windowNodeGetMatchZoomDirectionSize enlargeDirection isEnlarge
nodeType <- readTVarIO $ windowNodeType node
case nodeType of
TNodeRoot -> return ()
_ ->
readTVarIO (windowNodeParentId node)
>?>= \ parentNodeId ->
setListGetNode nodeList (\x -> windowNodeId x == parentNodeId)
?>= \ parentNode -> do
direction <- windowNodeGetZoomDirection node parentNode
if direction == matchDirection
then panedAdjustSize (windowNodePaned parentNode) adjustSize
else windowNodeZoom nodeList parentNode enlargeDirection isEnlarge