leksah-0.4: 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
#if __GLASGOW_HASKELL__ >= 609
import Control.OldException(evaluate,catch)
#else
import Control.Exception(evaluate,catch)
#endif
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 $"Cant'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