leksah-0.4.1: src/Graphics/UI/Frame/ViewFrame.hs
{-# OPTIONS_GHC #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Core.ViewFrame
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>
-- Stability : experimental
-- Portability : portable
--
--
-- | Splittable panes containing notebooks with any widgets
--
---------------------------------------------------------------------------------
module Graphics.UI.Frame.ViewFrame (
removePaneAdmin
, addPaneAdmin
, notebookInsertOrdered
-- * Convenience methods for accesing Pane state
, posTypeToPaneDirection
, paneDirectionToPosType
, paneFromName
, mbPaneFromName
, guiPropertiesFromName
-- * View Actions
, viewMove
, viewSplitHorizontal
, viewSplitVertical
, viewSplit
, viewSplit'
, handleNotebookSwitch
, viewCollapse
, viewCollapse'
, viewTabsPos
, viewSwitchTabs
-- * View Queries
, getStandardPanePath
, getActivePanePath
, getActivePanePathOrStandard
, figureOutPaneName
, getNotebook
, getPaned
, getActiveNotebook
, getPane
, getPanes
-- * View Actions
, bringPaneToFront
, newNotebook
-- * Accessing GUI elements
--, widgetFromPath
, getUIAction
, widgetGet
) where
import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite)
import Control.Monad.Reader
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import Data.Maybe
import Control.OldException(evaluate,catch)
import Prelude hiding(catch)
import Data.Unique
import Data.Typeable
import Graphics.UI.Frame.Panes
import Graphics.UI.Editor.Parameters
removePaneAdmin :: Pane alpha beta => alpha -> beta ()
removePaneAdmin pane = do
panes' <- getPanesSt
paneMap' <- getPaneMapSt
setPanesSt (Map.delete (paneName pane) panes')
setPaneMapSt (Map.delete (paneName pane) paneMap')
addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta ()
addPaneAdmin pane conn pp = do
panes' <- getPanesSt
paneMap' <- getPaneMapSt
unique <- liftIO newUnique
liftIO $ widgetSetName (getTopWidget pane) (show (hashUnique unique))
setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap')
setPanesSt (Map.insert (paneName pane) (PaneC pane) panes')
getPane :: RecoverablePane alpha beta delta => delta (Maybe alpha)
getPane = do
selectedPanes <- getPanes
if null selectedPanes || length selectedPanes > 1
then return Nothing
else (return (Just $ head selectedPanes))
getPanes :: RecoverablePane alpha beta delta => delta ([alpha])
getPanes = do
panes' <- getPanesSt
return (catMaybes
$ map (\(PaneC p) -> cast p)
$ Map.elems panes')
notebookInsertOrdered :: (NotebookClass self, WidgetClass child)
=> self
-> child -- child - the Widget to use as the contents of the page.
-> String -- tabLabel - the label for the page
-> Maybe Label
-> IO ()
notebookInsertOrdered nb widget label mbTabLabel = do
menuLabel <- labelNew (Just label)
tabLabel <- case mbTabLabel of
Nothing -> labelNew (Just label)
Just l -> return l
numPages <- notebookGetNPages nb
mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)]
widgets <- catch (evaluate (map fromJust mbWidgets))
(\e -> error "ViewFrame.notebookInsertOrdered: no widget")
mbLabels <- mapM (notebookGetTabLabelText nb) widgets
labels <- catch (evaluate (map fromJust mbLabels))
(\e -> error "ViewFrame.notebookInsertOrdered: no label")
let pos = case findIndex (\s -> s > label) labels of
Just i -> i
Nothing -> -1
realPos <- notebookInsertPageMenu nb widget tabLabel menuLabel pos
notebookSetCurrentPage nb realPos
-- | Constructs a unique pane name, which is an index and a string
figureOutPaneName :: Map String (IDEPane alpha) -> String -> Int -> (Int,String)
figureOutPaneName bufs bn ind =
let ind = foldr (\(PaneC buf) ind ->
if primPaneName buf == bn
then max ind ((getAddedIndex buf) + 1)
else ind)
0 (Map.elems bufs)
in if ind == 0
then (0,bn)
else (ind,bn ++ "(" ++ show ind ++ ")")
paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha)
paneFromName pn = do
mbPane <- mbPaneFromName pn
case mbPane of
Just p -> return p
Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn
mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha))
mbPaneFromName pn = do
panes <- getPanesSt
return (Map.lookup pn panes)
-- |
guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections)
guiPropertiesFromName pn = do
paneMap <- getPaneMapSt
case Map.lookup pn paneMap of
Just it -> return it
otherwise -> error $"Cant't find guiProperties from unique name " ++ pn
posTypeToPaneDirection PosLeft = LeftP
posTypeToPaneDirection PosRight = RightP
posTypeToPaneDirection PosTop = TopP
posTypeToPaneDirection PosBottom = BottomP
paneDirectionToPosType LeftP = PosLeft
paneDirectionToPosType RightP = PosRight
paneDirectionToPosType TopP = PosTop
paneDirectionToPosType BottomP = PosBottom
--
-- | Toggle the tabs of the current notebook
--
viewSwitchTabs :: PaneMonad alpha => alpha ()
viewSwitchTabs = do
mbNb <- getActiveNotebook
case mbNb of
Nothing -> return ()
Just nb -> liftIO $ do
b <- notebookGetShowTabs nb
notebookSetShowTabs nb (not b)
--
-- | Sets the tab position in the current notebook
--
viewTabsPos :: PaneMonad alpha => PositionType -> alpha ()
viewTabsPos pos = do
mbNb <- getActiveNotebook
case mbNb of
Nothing -> return ()
Just nb -> liftIO $notebookSetTabPos nb pos
--
-- | Split the currently active pane in horizontal direction
--
viewSplitHorizontal :: PaneMonad alpha => alpha ()
viewSplitHorizontal = viewSplit Horizontal
--
-- | Split the currently active pane in vertical direction
--
viewSplitVertical :: PaneMonad alpha => alpha ()
viewSplitVertical = viewSplit Vertical
--
-- | The active view can be split in two (horizontal or vertical)
--
viewSplit :: PaneMonad alpha => Direction -> alpha ()
viewSplit dir = do
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return ()
Just panePath -> viewSplit' panePath dir
viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha ()
viewSplit' panePath dir = do
activeNotebook <- getNotebook panePath
mbPD <- do
mbParent <- liftIO $ widgetGetParent activeNotebook
case mbParent of
Nothing -> return Nothing
Just parent -> do
(nb,paneDir) <- liftIO $ do
--trace ("Pane path " ++ show panePath) return ()
newpane <- case dir of
Horizontal -> do h <- vPanedNew
return (castToPaned h)
Vertical -> do v <- hPanedNew
return (castToPaned v)
let (name,altname,paneDir) = case dir of
Horizontal -> ("top","bottom",TopP)
Vertical -> ("left","right",LeftP)
rName <- widgetGetName activeNotebook
widgetSetName newpane rName
nb <- newNotebook
widgetSetName nb altname
panedPack2 newpane nb True True
containerRemove (castToContainer parent) activeNotebook
widgetSetName activeNotebook name
panedPack1 newpane activeNotebook True True
if not (null panePath)
then
if (last panePath == TopP || last panePath == LeftP)
then panedPack1 (castToPaned parent) newpane True True
else panedPack2 (castToPaned parent) newpane True True
else do
boxPackStart (castToBox parent) newpane PackGrow 0
boxReorderChild (castToVBox parent) newpane 2
widgetShowAll newpane
widgetGrabFocus activeNotebook
return (nb,paneDir)
handleFunc <- runInIO (handleNotebookSwitch nb)
liftIO $ afterSwitchPage nb handleFunc
return (Just (paneDir,dir))
case mbPD of
Just (paneDir,dir) -> do
let toPane = panePath ++ [paneDir]
adjustPane panePath toPane
adjustLayoutForSplit dir panePath
Nothing -> return ()
handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta ()
handleNotebookSwitch nb index = do
mbW <- liftIO $ notebookGetNthPage nb index
case mbW of
Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget"
Just w -> do
mbPane <- findPaneFor w
case mbPane of
Nothing -> return ()
Just (PaneC p) -> makeActive p
where
findPaneFor :: PaneMonad beta => Widget -> beta (Maybe (IDEPane beta))
findPaneFor w = do
panes' <- getPanesSt
n1 <- liftIO $ widgetGetName w
foldM (\r (PaneC p) -> do
n2 <- liftIO $ widgetGetName (getTopWidget p)
return (if n1 == n2 then (Just (PaneC p)) else r))
Nothing (Map.elems panes')
--
-- | Two notebooks can be collapsed to one
--
viewCollapse :: PaneMonad alpha => alpha ()
viewCollapse = do
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return ()
Just panePath -> do
viewCollapse' panePath
viewCollapse' :: PaneMonad alpha => PanePath -> alpha ()
viewCollapse' panePath = do
layout1 <- getLayoutSt
let newPanePath = reverse $tail $reverse panePath
let mbOtherSidePath = otherSide panePath
case mbOtherSidePath of
Nothing -> return ()
Just otherSidePath ->
let sp1 = getSubpath panePath layout1
sp2 = getSubpath otherSidePath layout1
in do
case sp1 of
Nothing -> return ()
Just sp -> viewCollapse' sp
case sp2 of
Nothing -> return ()
Just sp -> viewCollapse' sp
paneMap <- getPaneMapSt
activeNotebook <- getNotebook panePath
let paneNamesToMove = map (\(w,(p,_)) -> w)
$filter (\(w,(p,_)) -> p == otherSidePath)
$Map.toList paneMap
panesToMove <- mapM paneFromName paneNamesToMove
mapM_ (\(PaneC p) -> move panePath p) panesToMove
liftIO $ do
mbParent <- widgetGetParent activeNotebook
case mbParent of
Nothing -> error "collapse: no parent"
Just parent -> do
mbGrandparent <- widgetGetParent parent
case mbGrandparent of
Nothing -> error "collapse: no grandparent"
Just grandparent -> do
containerRemove (castToContainer grandparent) parent
containerRemove (castToContainer parent) activeNotebook
if length panePath > 1
then do
let dir = last newPanePath
if (dir == TopP || dir == LeftP)
then panedPack1 (castToPaned grandparent)
activeNotebook True True
else panedPack2 (castToPaned grandparent)
activeNotebook True True
widgetSetName activeNotebook $paneDirectionToWidgetName dir
else do
boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0
boxReorderChild (castToVBox grandparent) activeNotebook 2
widgetSetName activeNotebook "root"
adjustLayoutForCollapse newPanePath
adjustPane panePath newPanePath
--adjustPane otherSidePath newPanePath
--
-- | Moves the given Pane to the given path
--
move :: Pane alpha beta => PanePath -> alpha -> beta ()
move toPane idew = do
paneMap <- getPaneMapSt
let child = getTopWidget idew
(fromPane,cid) <- guiPropertiesFromName (paneName idew)
fromNB <- getNotebook fromPane
toNB <- getNotebook toPane
liftIO $ do
mbNum <- notebookPageNum fromNB child
case mbNum of
Nothing -> return ()
Just pn -> do
mbText <- notebookGetTabLabelText fromNB child
mbLabel <- notebookGetTabLabel fromNB child
case (mbText,mbLabel) of
(Just text, Just label) -> do
notebookRemovePage fromNB pn
notebookInsertOrdered toNB child text (Just (castToLabel label))
_ -> return ()
let paneMap1 = Map.delete (paneName idew) paneMap
setPaneMapSt $ Map.insert (paneName idew) (toPane,cid) paneMap1
--
-- | Moves the activePane in the given direction, if possible
-- | If their are many possibilities choose the leftmost and topmost
--
viewMove :: PaneMonad beta => PaneDirection -> beta ()
viewMove direction = do
mbPane <- getActivePaneSt
case mbPane of
Nothing -> do
return ()
Just (paneName,_) -> do
(PaneC pane) <- paneFromName paneName
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> do
return ()
Just panePath -> do
layout <- getLayoutSt
case findMoveTarget panePath layout direction of
Nothing -> do
return ()
Just moveTo -> move moveTo pane
--
-- | Find the target for a move
--
findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath
findMoveTarget panePath layout direction=
let reversedPath = reverse panePath
oppositeDir = otherDirection direction
cutPath = dropWhile (\d -> d /= oppositeDir) reversedPath
in if null cutPath
then Nothing
else let basePath = reverse (direction : tail cutPath)
layoutP = layoutFromPath basePath layout
in Just $basePath ++ findAppropriate layoutP oppositeDir
findAppropriate :: PaneLayout -> PaneDirection -> PanePath
findAppropriate (TerminalP _ _) _ = []
findAppropriate (HorizontalP t b _) LeftP = TopP : findAppropriate t LeftP
findAppropriate (HorizontalP t b _) RightP = TopP : findAppropriate t RightP
findAppropriate (HorizontalP t b _) BottomP = BottomP : findAppropriate b BottomP
findAppropriate (HorizontalP t b _) TopP = TopP : findAppropriate b TopP
findAppropriate (VerticalP l r _) LeftP = LeftP : findAppropriate l LeftP
findAppropriate (VerticalP l r _) RightP = RightP : findAppropriate r RightP
findAppropriate (VerticalP l r _) BottomP = LeftP : findAppropriate l BottomP
findAppropriate (VerticalP l r _) TopP = LeftP : findAppropriate l TopP
--
-- | Bring the pane to the front position in its notebook
--
bringPaneToFront :: Pane alpha beta => alpha -> IO ()
bringPaneToFront pane = do
let tv = getTopWidget pane
mbParent <- widgetGetParent tv
case mbParent of
Just parent -> do
let nb = castToNotebook parent
n <- notebookGetNPages nb
r <- filterM (\i -> do
mbp <- notebookGetNthPage nb i
case mbp of
Nothing -> return False
Just p -> do
mbs <- notebookGetTabLabelText nb p
case mbs of
Nothing -> return False
Just s -> return (s == paneName pane))
[0..(n-1)]
case r of
[i] -> notebookSetCurrentPage nb i
otherwise -> return ()
Nothing -> return ()
--
-- | Get a valid panePath from a standard path.
--
getStandardPanePath :: StandardPath -> PaneLayout -> PanePath
getStandardPanePath sp pl = reverse $ getStandard' sp pl []
where
getStandard' _ (TerminalP _ _) p = p
getStandard' (LeftP:sp) (VerticalP l r _) p = getStandard' sp l (LeftP:p)
getStandard' (RightP:sp) (VerticalP l r _) p = getStandard' sp r (RightP:p)
getStandard' (TopP:sp) (HorizontalP t b _) p = getStandard' sp t (TopP:p)
getStandard' (BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (BottomP:p)
-- if no match get leftmost topmost
getStandard' _ (VerticalP l r _) p = getStandard' [] l (LeftP:p)
getStandard' _ (HorizontalP t b _) p = getStandard' [] t (TopP:p)
--
-- | Construct a new notebook
--
newNotebook :: IO Notebook
newNotebook = do
nb <- notebookNew
notebookSetTabPos nb PosTop
notebookSetShowTabs nb True
notebookSetScrollable nb True
notebookSetPopup nb True
return nb
--
-- | Get another pane path which points to the other side at the same level
--
otherSide :: PanePath -> Maybe PanePath
otherSide [] = Nothing
otherSide p = let rp = reverse p
ae = otherDirection $head rp
in Just (reverse $ae : tail rp)
--
-- | Get the opposite direction of a pane direction
--
otherDirection :: PaneDirection -> PaneDirection
otherDirection LeftP = RightP
otherDirection RightP = LeftP
otherDirection TopP = BottomP
otherDirection BottomP = TopP
--
-- | Get the layout at the given pane path
--
layoutFromPath :: PanePath -> PaneLayout -> PaneLayout
layoutFromPath [] l = l
layoutFromPath (TopP:r) (HorizontalP t _ _) = layoutFromPath r t
layoutFromPath (BottomP:r) (HorizontalP _ b _) = layoutFromPath r b
layoutFromPath (LeftP:r) (VerticalP l _ _) = layoutFromPath r l
layoutFromPath (RightP:r) (VerticalP _ ri _) = layoutFromPath r ri
layoutFromPath pp l = error
$"inconsistent layout " ++ show pp ++ " " ++ show l
getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta
getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf
--
-- | Get the notebook widget for the given pane path
--
getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook
getNotebook p = getNotebookOrPaned p castToNotebook
--
-- | Get the (gtk) Paned widget for a given path
--
getPaned :: PaneMonad alpha => PanePath -> alpha Paned
getPaned p = getNotebookOrPaned p castToPaned
--
-- | Get the path to the active pane
--
getActivePanePath :: PaneMonad alpha => alpha (Maybe PanePath)
getActivePanePath = do
mbPane <- getActivePaneSt
case mbPane of
Nothing -> return Nothing
Just (paneName,_) -> do
(pp,_) <- guiPropertiesFromName paneName
return (Just (pp))
getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha (PanePath)
getActivePanePathOrStandard sp = do
mbApp <- getActivePanePath
case mbApp of
Just app -> return app
Nothing -> do
layout <- getLayoutSt
return (getStandardPanePath sp layout)
--
-- | Get the active notebook
--
getActiveNotebook :: PaneMonad alpha => alpha (Maybe Notebook)
getActiveNotebook = do
mbPanePath <- getActivePanePath
case mbPanePath of
Just panePath -> do
nb <- getNotebook panePath
return (Just nb)
Nothing -> return Nothing
--
-- | Translates a pane direction to the widget name
--
paneDirectionToWidgetName :: PaneDirection -> String
paneDirectionToWidgetName TopP = "top"
paneDirectionToWidgetName BottomP = "bottom"
paneDirectionToWidgetName LeftP = "left"
paneDirectionToWidgetName RightP = "right"
--
-- | Changes a pane path in the pane map
--
adjustPane :: PaneMonad alpha => PanePath -> PanePath -> alpha ()
adjustPane fromPane toPane = do
paneMap <- getPaneMapSt
let newMap = Map.map (\(pp,other) -> do
if pp == fromPane
then (toPane,other)
else (pp,other)) paneMap
setPaneMapSt newMap
--
-- | Changes the layout for a split
--
adjustLayoutForSplit :: PaneMonad alpha => Direction -> PanePath -> alpha ()
adjustLayoutForSplit dir path = do
layout <- getLayoutSt
let newTerm = case dir of
Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0
Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0
setLayoutSt $ adjust path layout newTerm
--
-- | Changes the layout for a collapse
--
adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha ()
adjustLayoutForCollapse path = do
layout <- getLayoutSt
setLayoutSt $ adjust path layout (TerminalP Nothing 0)
getSubpath :: PanePath -> PaneLayout -> Maybe PanePath
getSubpath path layout =
case layoutFromPath path layout of
TerminalP _ _ -> Nothing
HorizontalP _ _ _ -> Just (path ++ [TopP])
VerticalP _ _ _ -> Just (path ++ [LeftP])
--
-- | Changes the layout by replacing element at pane path with replace
--
adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout
adjust pp layout replace = adjust' pp layout
where
adjust' [] _ = replace
adjust' (TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0
adjust' (BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0
adjust' (LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0
adjust' (RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0
adjust' p l = error $"inconsistent layout " ++ show p ++ " " ++ show l
--
-- | Get the widget from a list of strings
--
widgetFromPath :: Widget -> [String] -> IO (Widget)
widgetFromPath w [] = return w
widgetFromPath w (h:t) = do
children <- containerGetChildren (castToContainer w)
names <- mapM widgetGetName children
let mbiInd = findIndex (== h) names
case mbiInd of
Nothing -> error $"Cant't find widget path " ++ show (h:t)
Just ind -> widgetFromPath (children !! ind) t
widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b)
widgetGet strL cf = do
w <- getWindowSt
r <- liftIO $widgetFromPath (castToWidget w) strL
return (cf r)
widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b)
widgetGetRel w sl cf = do
r <- widgetFromPath w sl
return (cf r)
getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a)
getUIAction str f = do
uiManager <- getUIManagerSt
liftIO $ do
findAction <- uiManagerGetAction uiManager str
case findAction of
Just act -> return (f act)
Nothing -> error $"getUIAction can't find action " ++ str