ltk-0.16.1.0: src/Graphics/UI/Frame/ViewFrame.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Core.ViewFrame
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
--
-- | Splittable panes containing notebooks with any widgets
--
---------------------------------------------------------------------------------
module Graphics.UI.Frame.ViewFrame (
removePaneAdmin
, addPaneAdmin
, notebookInsertOrdered
, markLabel
-- * Convenience methods for accesing Pane state
, posTypeToPaneDirection
, paneDirectionToPosType
, paneFromName
, mbPaneFromName
, guiPropertiesFromName
-- * View Actions
, viewMove
, viewMoveTo
, viewSplitHorizontal
, viewSplitVertical
--, viewSplit
, viewSplit'
, viewNewGroup
, newGroupOrBringToFront
, bringGroupToFront
, viewNest
, viewNest'
, viewDetach
, viewDetach'
, handleNotebookSwitch
, viewCollapse
, viewCollapse'
, viewTabsPos
, viewSwitchTabs
, closeGroup
, allGroupNames
-- * View Queries
, getBestPanePath
, getBestPathForId
, getActivePanePath
, getActivePanePathOrStandard
, figureOutPaneName
, getNotebook
, getPaned
, getActiveNotebook
, getActivePane
, setActivePane
, getUiManager
, getWindows
, getMainWindow
, getActiveWindow
, getActiveScreen
, getLayout
, getPanesSt
, getPaneMapSt
, getPanePrim
, getPanes
-- * View Actions
, bringPaneToFront
, newNotebook
, newNotebook'
-- * Accessing GUI elements
--, widgetFromPath
, getUIAction
, widgetGet
, initGtkRc
) where
import Prelude ()
import Prelude.Compat
import Control.Applicative (Applicative)
import qualified Data.Map as Map
import Data.List (findIndex, isPrefixOf, deleteBy, stripPrefix, elemIndex)
import Data.Maybe
import Data.Unique
import Data.Typeable
import Data.Text (Text)
import Graphics.UI.Frame.Panes
import Graphics.UI.Editor.Parameters
import System.CPUTime (getCPUTime)
import MyMissing (forceJust, forceHead)
import Graphics.UI.Editor.MakeEditor
(mkField, FieldDescription(..), buildEditor)
import Graphics.UI.Editor.Simple (stringEditor, textEditor)
import Control.Event (registerEvent)
import Graphics.UI.Editor.Basics
(eventText, GUIEventSelector(..))
import qualified Data.Set as Set (unions, member)
import Data.Set (Set(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (unless, when, liftM, foldM)
import Control.Applicative ((<$>))
import qualified Control.Monad.Reader as Gtk (liftIO)
import qualified Data.Text as T (pack, stripPrefix, unpack)
import Data.Monoid ((<>))
import Data.Foldable (forM_)
import Control.Arrow (Arrow(..))
import GI.Gtk
(panedNew, gridNew, widgetSetValign, widgetSetHalign, noWidget,
windowGetScreen, Bin(..), CssProvider(..), uIManagerGetAction,
Action, toWidget, selectionDataGetText, SelectionData,
WidgetDragDataReceivedCallback, onWidgetDragDataReceived,
widgetDragDestSetTargetList, widgetDragDestSet,
setNotebookEnablePopup, notebookSetScrollable,
widgetSetSizeRequest, notebookNew, windowPresent, getWidgetVisible,
notebookRemovePage, Window(..), widgetGetToplevel,
onWidgetDeleteEvent, widgetGetAllocation, windowSetDefaultSize,
setWidgetName, windowNew, Widget(..), dialogResponse,
dialogGetContentArea, setWindowTitle, setWindowTransientFor,
dialogNew, Window, windowSetTransientFor, setMessageDialogText,
constructDialogUseHeaderBar, MessageDialog(..), widgetDestroy,
dialogRun, afterNotebookSwitchPage, widgetGrabFocus,
boxReorderChild, Box(..), notebookSetMenuLabel,
notebookSetTabLabel, notebookInsertPage, Paned(..), panedPack1,
containerRemove, notebookPageNum, Notebook(..), panedPack2,
hPanedNew, toPaned, Container(..), vPanedNew, widgetGetParent,
notebookGetCurrentPage, notebookSetTabPos, PositionType(..),
notebookSetShowTabs, notebookGetShowTabs, Label(..),
containerGetChildren, binGetChild, notebookGetTabLabel,
labelSetMarkup, labelSetUseMarkup, onWidgetButtonReleaseEvent,
onButtonClicked, selectionDataSetText, onWidgetDragDataGet,
widgetDragSourceSetTargetList, targetListAddTextTargets,
targetListNew, widgetDragSourceSet, setWidgetHalign,
setWidgetValign, cssProviderLoadFromData, boxPackStart,
containerAdd, containerSetBorderWidth, styleContextAddProvider,
widgetGetStyleContext, cssProviderNew, pattern STOCK_CLOSE,
imageNewFromStock, imageNewFromPixbuf, iconThemeLoadIcon,
iconThemeGetDefault, buttonSetAlignment, buttonSetRelief,
buttonSetFocusOnClick, buttonNew, hBoxNew,
eventBoxSetVisibleWindow, eventBoxNew, miscSetPadding,
miscSetAlignment, EventBox, notebookSetCurrentPage, widgetShowAll,
notebookInsertPageMenu, widgetGetName, notebookGetNthPage,
notebookGetNPages, labelNew, Label, IsWidget, IsNotebook,
widgetSetName)
#ifdef MIN_VERSION_GTK_3_20
import GI.Gtk.Objects.Widget (widgetSetFocusOnClick)
#else
import GI.Gtk.Objects.Button (buttonSetFocusOnClick)
#endif
import GI.Gtk.Enums
(Orientation(..), WindowType(..), ResponseType(..),
ButtonsType(..), MessageType(..), PositionType(..), Align(..),
IconSize(..), ReliefStyle(..))
import GI.Gtk.Flags (DestDefaults(..), IconLookupFlags(..))
import GI.Gdk.Flags (ModifierType(..), DragAction(..))
import GI.Gdk
(DragContext, Screen, getEventButtonState)
import Graphics.UI.Frame.Rectangle (getRectangleWidth, getRectangleHeight)
import Data.GI.Base
(unsafeManagedPtrCastPtr, withManagedPtr, castTo, unsafeCastTo,
ManagedPtrNewtype, UnexpectedNullPointerReturn(..), GObject(..),
new', nullToNothing)
import Control.Exception (catch)
import Data.Int (Int32)
import Data.Word (Word32)
import Data.Function (on)
import Data.Coerce (coerce)
import Data.GI.Gtk.ModelView.Types (equalManagedPtr)
import GI.Gtk.Objects.Dialog (Dialog(..), constructDialogUseHeaderBar)
import GI.Gtk.Objects.MessageDialog
(constructMessageDialogButtons, setMessageDialogMessageType)
import GI.Gtk.Objects.Label (noLabel)
import GI.Gtk.Objects.Widget (widgetSetTooltipText)
-- import Debug.Trace (trace)
trace (a::String) b = b
groupPrefix = "_group_"
withoutGroupPrefix :: Text -> Text
withoutGroupPrefix s = fromMaybe s (groupPrefix `T.stripPrefix` s)
initGtkRc :: IO ()
initGtkRc = return ()
removePaneAdmin :: RecoverablePane alpha beta delta => alpha -> delta ()
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 Bool
addPaneAdmin pane conn pp = do
panes' <- getPanesSt
paneMap' <- getPaneMapSt
topWidget <- getTopWidget pane
widgetSetName topWidget (paneName pane)
let b1 = case Map.lookup (paneName pane) paneMap' of
Nothing -> True
Just it -> False
let b2 = case Map.lookup (paneName pane) panes' of
Nothing -> True
Just it -> False
if b1 && b2
then do
setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap')
setPanesSt (Map.insert (paneName pane) (PaneC pane) panes')
return True
else trace
("ViewFrame>addPaneAdmin:pane with this name already exist" <>
T.unpack (paneName pane))
$ return False
getPanePrim :: RecoverablePane alpha beta delta => delta (Maybe alpha)
getPanePrim = 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 (mapMaybe (\ (PaneC p) -> cast p) (Map.elems panes'))
notebookInsertOrdered :: PaneMonad alpha => (IsNotebook self, IsWidget child)
=> self
-> child -- child - the Widget to use as the contents of the page.
-> Text
-> Maybe Label -- the label for the page as Text or Label
-> Maybe Text -- ^ Text for tooltip when hovering
-> Bool
-> alpha ()
notebookInsertOrdered nb widget labelStr mbLabel mbTooltipText isGroup = do
label <- case mbLabel of
Nothing -> labelNew (Just labelStr)
Just l -> return l
menuLabel <- labelNew (Just labelStr)
numPages <- notebookGetNPages nb
mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)]
let widgets = map (`forceJust` "ViewFrame.notebookInsertOrdered: no widget") mbWidgets
labelStrs <- mapM widgetGetName widgets
let pos = fromMaybe (-1)
(findIndex
(\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr)
labelStrs)
labelBox <- if isGroup then groupLabel labelStr else mkLabelBox label labelStr
realPos <- notebookInsertPageMenu nb widget (Just labelBox) (Just menuLabel) (fromIntegral pos)
widgetSetTooltipText labelBox mbTooltipText
widgetShowAll labelBox
notebookSetCurrentPage nb realPos
-- | Returns a label box
mkLabelBox :: PaneMonad alpha => Label -> Text -> alpha EventBox
mkLabelBox lbl paneName = do
widgetSetHalign lbl AlignStart
widgetSetValign lbl AlignStart
labelBox <- eventBoxNew
eventBoxSetVisibleWindow labelBox False
innerBox <- gridNew
tabButton <- buttonNew
widgetSetName tabButton "leksah-close-button"
#ifdef MIN_VERSION_GTK_3_20
widgetSetFocusOnClick tabButton False
#else
buttonSetFocusOnClick tabButton False
#endif
buttonSetRelief tabButton ReliefStyleNone
widgetSetHalign tabButton AlignEnd
widgetSetValign tabButton AlignCenter
iconTheme <- iconThemeGetDefault
image <- iconThemeLoadIcon iconTheme "window-close" 10 [IconLookupFlagsUseBuiltin] >>= imageNewFromPixbuf
provider <- cssProviderNew
cssProviderLoadFromData provider (
".button {\n" <>
"padding: 0px;\n" <>
"border-width: 0px;\n" <>
"}\n" <>
"GtkImage {\n" <>
"padding: 0px;\n" <>
"}\n")
context <- widgetGetStyleContext tabButton
styleContextAddProvider context provider 600
context <- widgetGetStyleContext image
styleContextAddProvider context provider 600
setWidgetValign tabButton AlignCenter
setWidgetValign lbl AlignCenter
containerSetBorderWidth tabButton 0
containerAdd tabButton image
containerAdd innerBox lbl
containerAdd innerBox tabButton
containerAdd labelBox innerBox
setWidgetHalign innerBox AlignCenter
widgetDragSourceSet labelBox [ModifierTypeButton1Mask] Nothing [DragActionCopy,DragActionMove]
tl <- targetListNew Nothing
targetListAddTextTargets tl 0
widgetDragSourceSetTargetList labelBox $ Just tl
onWidgetDragDataGet labelBox (\ cont sel id timeStamp -> do
trace ("drag paneName=" <> T.unpack paneName) $ return ()
selectionDataSetText sel paneName (-1)
return ())
cl <- runInIO closeHandler
onButtonClicked tabButton (cl ())
onWidgetButtonReleaseEvent labelBox $ \e -> do
modifiers <- getEventButtonState e
let middleButton = ModifierTypeButton2Mask
when (middleButton `elem` modifiers) (cl ())
return False
return labelBox
where
closeHandler :: PaneMonad alpha => () -> alpha ()
closeHandler _ = case groupPrefix `T.stripPrefix` paneName of
Just group -> closeGroup group
Nothing -> do
(PaneC pane) <- paneFromName paneName
closePane pane
return ()
groupLabel :: PaneMonad beta => Text -> beta EventBox
groupLabel group = do
label <- labelNew Nothing
labelSetUseMarkup label True
labelSetMarkup label ("<b>" <> group <> "</b>")
labelBox <- mkLabelBox label (groupPrefix <> group)
widgetShowAll labelBox
return labelBox
-- | Add the change mark or removes it
markLabel :: (MonadIO m, IsWidget alpha, IsNotebook beta) => beta -> alpha -> Bool -> m ()
markLabel nb topWidget modified =
notebookGetTabLabel nb topWidget >>= \case
Nothing -> return ()
Just box -> liftIO (unsafeCastTo Bin box) >>= nullToNothing . binGetChild >>= \case
Nothing -> return ()
Just container -> do
children <- liftIO (unsafeCastTo Container container) >>= containerGetChildren
label <- liftIO . unsafeCastTo Label $ forceHead (tail children) "ViewFrame>>markLabel: empty children"
text <- widgetGetName topWidget
labelSetUseMarkup label True
labelSetMarkup label
(if modified
then "<span foreground=\"red\">" <> text <> "</span>"
else text)
-- | Constructs a unique pane name, which is an index and a string
figureOutPaneName :: PaneMonad alpha => Text -> Int -> alpha (Int,Text)
figureOutPaneName bn ind = do
bufs <- getPanesSt
let ind = foldr (\(PaneC buf) ind ->
if primPaneName buf == bn
then max ind (getAddedIndex buf + 1)
else ind)
0 (Map.elems bufs)
if ind == 0
then return (0,bn)
else return (ind,bn <> "(" <> T.pack (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 " ++ T.unpack 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 " ++ T.unpack pn
posTypeToPaneDirection PositionTypeLeft = LeftP
posTypeToPaneDirection PositionTypeRight = RightP
posTypeToPaneDirection PositionTypeTop = TopP
posTypeToPaneDirection PositionTypeBottom = BottomP
paneDirectionToPosType LeftP = PositionTypeLeft
paneDirectionToPosType RightP = PositionTypeRight
paneDirectionToPosType TopP = PositionTypeTop
paneDirectionToPosType BottomP = PositionTypeBottom
--
-- | Toggle the tabs of the current notebook
--
viewSwitchTabs :: PaneMonad alpha => alpha ()
viewSwitchTabs = do
mbNb <- getActiveNotebook
case mbNb of
Nothing -> return ()
Just nb -> 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 -> notebookSetTabPos nb pos
--
-- | Split the currently active pane in horizontal direction
--
viewSplitHorizontal :: PaneMonad alpha => alpha ()
viewSplitHorizontal = viewSplit OrientationHorizontal
--
-- | Split the currently active pane in vertical direction
--
viewSplitVertical :: PaneMonad alpha => alpha ()
viewSplitVertical = viewSplit OrientationVertical
--
-- | The active view can be split in two (horizontal or vertical)
--
viewSplit :: PaneMonad alpha => Orientation -> alpha ()
viewSplit orientation = do
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return ()
Just panePath -> viewSplit' panePath orientation
viewSplit' :: PaneMonad alpha => PanePath -> Orientation -> alpha ()
viewSplit' panePath orientation = do
l <- getLayout
case layoutFromPath panePath l of
(TerminalP _ _ _ (Just _) _) -> trace "ViewFrame>>viewSplit': can't split detached: " return ()
_ -> do
activeNotebook <- getNotebook' "viewSplit" panePath
ind <- notebookGetCurrentPage activeNotebook
parent <- widgetGetParent activeNotebook >>= liftIO . unsafeCastTo Container . fromJust
let (name,altname,paneDir,
oldPath,newPath) = case orientation of
OrientationHorizontal ->
( "top"
, "bottom"
, TopP
, panePath ++ [SplitP TopP]
, panePath ++ [SplitP BottomP])
OrientationVertical ->
( "left"
, "right"
, LeftP
, panePath ++ [SplitP LeftP]
, panePath ++ [SplitP RightP])
adjustNotebooks panePath oldPath
frameState <- getFrameState
notebookPtr <- liftIO $ unsafeManagedPtrCastPtr activeNotebook
setPanePathFromNB $ Map.insert notebookPtr oldPath (panePathFromNB frameState)
nb <- newNotebook newPath
newpane <- panedNew $ case orientation of
OrientationHorizontal -> OrientationVertical
OrientationVertical -> OrientationHorizontal
rName <- widgetGetName activeNotebook
widgetSetName newpane rName
widgetSetName nb altname
panedPack2 newpane nb True False
nbIndex <- liftIO (castTo Notebook parent) >>= \case
Just notebook -> notebookPageNum notebook activeNotebook
Nothing -> trace "ViewFrame>>viewSplit': parent not a notebook: " $ return (-1)
containerRemove parent activeNotebook
widgetSetName activeNotebook name
panedPack1 newpane activeNotebook True False
case (reverse panePath, nbIndex) of
(SplitP dir:_, _) -> do
paned <- liftIO $ unsafeCastTo Paned parent
if dir `elem` [TopP, LeftP]
then panedPack1 paned newpane True False
else panedPack2 paned newpane True False
(GroupP group:_, n) | n >= 0 -> do
parentNotebook <- liftIO $ unsafeCastTo Notebook parent
label <- groupLabel group
notebookInsertPage parentNotebook newpane (Just label) n
label2 <- groupMenuLabel group
notebookSetMenuLabel parentNotebook newpane label2
return ()
([], _) -> do
box <- liftIO $ unsafeCastTo Box parent
boxPackStart box newpane True True 0
boxReorderChild box newpane 2
_ -> error "No notebook index found in viewSplit"
widgetShowAll newpane
widgetGrabFocus activeNotebook
if nbIndex >= 0
then do
parentNotebook <- liftIO $ unsafeCastTo Notebook parent
notebookSetCurrentPage parentNotebook nbIndex
else trace "ViewFrame>>viewSplit': parent not a notebook2: " $ return ()
handleFunc <- runInIO (handleNotebookSwitch nb)
afterNotebookSwitchPage nb (\w i -> handleFunc $ fromIntegral i)
adjustPanes panePath (panePath ++ [SplitP paneDir])
adjustLayoutForSplit paneDir panePath
notebookGetNthPage activeNotebook ind >>= \case
Nothing -> return ()
Just widget -> do
name <- widgetGetName widget
mbPane <- mbPaneFromName name
case mbPane of
Just (PaneC pane) -> viewMoveTo (panePath ++ [SplitP (otherDirection paneDir)]) pane
Nothing -> return ()
--
-- | Two notebooks can be collapsed to one
--
viewCollapse :: PaneMonad alpha => alpha ()
viewCollapse = do
mbPanePath <- getActivePanePath
forM_ mbPanePath viewCollapse'
viewCollapse' :: PaneMonad alpha => PanePath -> alpha ()
viewCollapse' panePath = trace "viewCollapse' called" $ do
layout1 <- getLayoutSt
case layoutFromPath panePath layout1 of
(TerminalP _ _ _ (Just _) _) -> trace "ViewFrame>>viewCollapse': can't collapse detached: "
return ()
_ -> do
let newPanePath = init panePath
let mbOtherSidePath = otherSide panePath
case mbOtherSidePath of
Nothing -> trace "ViewFrame>>viewCollapse': no other side path found: " return ()
Just otherSidePath -> do
nbop <- getNotebookOrPaned otherSidePath return
nb <- liftIO $ castTo Notebook nbop
case nb of
Nothing -> trace "ViewFrame>>viewCollapse': other side path not collapsedXX: " $
case layoutFromPath otherSidePath layout1 of
VerticalP{} -> do
viewCollapse' (otherSidePath ++ [SplitP LeftP])
viewCollapse' panePath
HorizontalP{} -> do
viewCollapse' (otherSidePath ++ [SplitP TopP])
viewCollapse' panePath
_ -> trace "ViewFrame>>viewCollapse': impossible1 " return ()
Just otherSideNotebook -> do
paneMap <- getPaneMapSt
activeNotebook <- getNotebook' "viewCollapse' 1" panePath
-- 1. Move panes and groups to one side (includes changes to paneMap and layout)
let paneNamesToMove = map (\(w,(p,_)) -> w)
$filter (\(w,(p,_)) -> otherSidePath == p)
$Map.toList paneMap
panesToMove <- mapM paneFromName paneNamesToMove
mapM_ (\(PaneC p) -> viewMoveTo panePath p) panesToMove
let groupNames = map (\n -> groupPrefix <> n) $
getGroupsFrom otherSidePath layout1
mapM_ (\n -> move' (n,activeNotebook)) groupNames
-- 2. Remove unused notebook from admin
st <- getFrameState
notebookPtr <- liftIO $ unsafeManagedPtrCastPtr otherSideNotebook
let ! newMap = Map.delete notebookPtr (panePathFromNB st)
setPanePathFromNB newMap
-- 3. Remove one level and reparent notebook
parent <- widgetGetParent activeNotebook >>= liftIO . unsafeCastTo Container . fromJust
grandparent <- widgetGetParent parent >>= liftIO . unsafeCastTo Container . fromJust
nbIndex <- liftIO $ castTo Notebook grandparent >>= \case
Just notebook -> notebookPageNum notebook parent
Nothing -> return (-1)
containerRemove grandparent parent
containerRemove parent activeNotebook
if length panePath > 1
then do
let lasPathElem = last newPanePath
case (lasPathElem, nbIndex) of
(SplitP dir, _) | dir == TopP || dir == LeftP -> do
paned <- liftIO $ unsafeCastTo Paned grandparent
panedPack1 paned activeNotebook True False
(SplitP dir, _) | dir == BottomP || dir == RightP -> do
paned <- liftIO $ unsafeCastTo Paned grandparent
panedPack2 paned activeNotebook True False
(GroupP group, n) | n >= 0 -> do
grandParentNotebook <- liftIO $ unsafeCastTo Notebook grandparent
label <- groupLabel group
notebookInsertPage grandParentNotebook activeNotebook (Just label) n
notebookSetCurrentPage grandParentNotebook n
return ()
_ -> error "collapse: Unable to find page index"
widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem
else do
box <- liftIO $ unsafeCastTo Box grandparent
boxPackStart box activeNotebook True True 0
boxReorderChild box activeNotebook 2
widgetSetName activeNotebook "root"
-- 4. Change panePathFromNotebook
adjustNotebooks panePath newPanePath
-- 5. Change paneMap
adjustPanes panePath newPanePath
-- 6. Change layout
adjustLayoutForCollapse panePath
getGroupsFrom :: PanePath -> PaneLayout -> [Text]
getGroupsFrom path layout =
case layoutFromPath path layout of
t@(TerminalP{}) -> Map.keys (paneGroups t)
HorizontalP{} -> []
VerticalP{} -> []
viewNewGroup :: PaneMonad alpha => alpha ()
viewNewGroup = do
mainWindow <- getMainWindow
mbGroupName <- groupNameDialog mainWindow
case
mbGroupName of
Just groupName -> do
layout <- getLayoutSt
if groupName `Set.member` allGroupNames layout
then do
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeClose]
setMessageDialogMessageType md MessageTypeWarning
setMessageDialogText md $ "Group name not unique " <> groupName
windowSetTransientFor md (Just mainWindow)
dialogRun md
widgetDestroy md
return ()
else viewNest groupName
Nothing -> return ()
newGroupOrBringToFront :: PaneMonad alpha => Text -> PanePath -> alpha (Maybe PanePath,Bool)
newGroupOrBringToFront groupName pp = do
layout <- getLayoutSt
if groupName `Set.member` allGroupNames layout
then do
mbPP <- bringGroupToFront groupName
return (mbPP,False)
else let realPath = getBestPanePath pp layout in do
viewNest' realPath groupName
return (Just (realPath ++ [GroupP groupName]),True)
bringGroupToFront :: PaneMonad alpha => Text -> alpha (Maybe PanePath)
bringGroupToFront groupName = do
layout <- getLayoutSt
case findGroupPath groupName layout of
Just path -> do
widget <- getNotebookOrPaned path return
setCurrentNotebookPages widget
return (Just path)
Nothing -> return Nothing
-- Yet another stupid little dialog
groupNameDialog :: (Applicative m, MonadIO m) => Window -> m (Maybe Text)
groupNameDialog parent = do
dia <- new' Dialog [constructDialogUseHeaderBar 0]
setWindowTransientFor dia parent
setWindowTitle dia "Group"
upper <- dialogGetContentArea dia >>= liftIO . unsafeCastTo Box
(widget,inj,ext,_) <- buildEditor fields ""
okButton <- dialogAddButton' dia "New" ResponseTypeOk
boxPackStart upper widget True True 7
widgetShowAll dia
resp <- dialogRun dia
value <- liftIO $ ext ""
widgetDestroy dia
case toEnum $ fromIntegral resp of
ResponseTypeOk | value /= Just "" -> return value
_ -> return Nothing
where
fields :: FieldDescription Text
fields = VFD emptyParams [
mkField
(paraName <<<- ParaName "Group name "
$ emptyParams)
id
const
(textEditor (const True) True)]
viewNest :: PaneMonad alpha => Text -> alpha ()
viewNest group = do
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return ()
Just panePath -> viewNest' panePath group
viewNest' :: PaneMonad alpha => PanePath -> Text -> alpha ()
viewNest' panePath group = do
activeNotebook <- getNotebook' "viewNest' 1" panePath
parent <- widgetGetParent activeNotebook
layout <- getLayoutSt
let paneLayout = layoutFromPath panePath layout
case paneLayout of
TerminalP {} -> do
nb <- newNotebook (panePath ++ [GroupP group])
widgetSetName nb (groupPrefix <> group)
notebookInsertOrdered activeNotebook nb group noLabel Nothing True
widgetShowAll nb
--widgetGrabFocus activeNotebook
handleFunc <- runInIO (handleNotebookSwitch nb)
afterNotebookSwitchPage nb (\w i -> handleFunc $ fromIntegral i)
adjustLayoutForNest group panePath
_ -> return ()
closeGroup :: PaneMonad alpha => Text -> alpha ()
closeGroup groupName = do
layout <- getLayout
let mbPath = findGroupPath groupName layout
mainWindow <- getMainWindow
case mbPath of
Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " <> T.unpack groupName) return ()
Just path -> do
panesMap <- getPaneMapSt
let nameAndpathList = filter (\(a,pp) -> path `isPrefixOf` pp)
$ map (second fst) (Map.assocs panesMap)
continue <- case nameAndpathList of
(_:_) -> do
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeYesNo]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ "Group " <> groupName <> " not empty. Close with all contents?"
windowSetTransientFor md (Just mainWindow)
rid <- dialogRun md
widgetDestroy md
case toEnum $ fromIntegral rid of
ResponseTypeYes -> return True
otherwise -> return False
[] -> return True
when continue $ do
panes <- mapM (paneFromName . fst) nameAndpathList
results <- mapM (\ (PaneC p) -> closePane p) panes
when (and results) $ do
nbOrPaned <- getNotebookOrPaned path return
parent <- widgetGetParent nbOrPaned >>= liftIO. unsafeCastTo Container . fromJust
containerRemove parent nbOrPaned
setLayoutSt (removeGL path layout)
ppMap <- getPanePathFromNB
setPanePathFromNB (Map.filter (\pa -> not (path `isPrefixOf` pa)) ppMap)
viewDetach :: PaneMonad alpha => alpha (Maybe (Window, Notebook))
viewDetach = do
id <- liftIO $ show <$> getCPUTime
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return Nothing
Just panePath -> viewDetach' panePath (T.pack id)
viewDetach' :: PaneMonad alpha => PanePath -> Text -> alpha (Maybe (Window, Notebook))
viewDetach' panePath id = do
activeNotebook <- getNotebook' "viewDetach'" panePath
parent <- widgetGetParent activeNotebook >>= liftIO . unsafeCastTo Container . fromJust
layout <- getLayoutSt
let paneLayout = layoutFromPath panePath layout
case paneLayout of
TerminalP{detachedSize = size} -> do
window <- windowNew WindowTypeToplevel
setWindowTitle window "Leksah detached window"
setWidgetName window id
case size of
Just (width, height) -> windowSetDefaultSize window (fromIntegral width) (fromIntegral height)
Nothing -> do
a <- widgetGetAllocation activeNotebook
curWidth <- getRectangleWidth a
curHeight <- getRectangleHeight a
windowSetDefaultSize window curWidth curHeight
containerRemove parent activeNotebook
containerAdd window activeNotebook
widgetShowAll window
handleFunc <- runInIO (handleReattach id window)
onWidgetDeleteEvent window $ \e -> handleFunc ()
windows <- getWindowsSt
setWindowsSt $ windows ++ [window]
adjustLayoutForDetach id panePath
return (Just (window, activeNotebook))
_ -> return Nothing
handleReattach :: PaneMonad alpha => Text -> Window -> () -> alpha Bool
handleReattach windowId window _ = do
layout <- getLayout
case findDetachedPath windowId layout of
Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " <> T.unpack windowId)
$ do
windows <- getWindowsSt
setWindowsSt $ deleteBy equalManagedPtr window windows
return False
Just pp -> do
nb <- getNotebook' "handleReattach" pp
parent <- getNotebookOrPaned (init pp) (unsafeCastTo Container)
containerRemove window nb
containerAdd parent nb
adjustLayoutForReattach pp
windows <- getWindowsSt
setWindowsSt $ deleteBy equalManagedPtr window windows
case last pp of
GroupP groupName -> do
label <- groupLabel groupName
parentNotebook <- liftIO $ unsafeCastTo Notebook parent
notebookSetTabLabel parentNotebook nb (Just label)
otherwise -> return ()
return False -- "now destroy the window"
getActiveWindow :: PaneMonad alpha => alpha (Maybe Window)
getActiveWindow = do
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return Nothing
Just panePath -> do
activeNotebook <- getNotebook' "getActiveWindow" panePath
widgetGetToplevel activeNotebook >>= liftIO . castTo Window
getActiveScreen :: PaneMonad alpha => alpha (Maybe Screen)
getActiveScreen = do
mbWindow <- getActiveWindow
case mbWindow of
Nothing -> return Nothing
Just window -> Just <$> windowGetScreen window
groupMenuLabel :: PaneMonad beta => Text -> beta (Maybe Label)
groupMenuLabel group = liftM Just (labelNew (Just group))
handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta ()
handleNotebookSwitch nb index =
notebookGetNthPage nb (fromIntegral index) >>= \case
Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget"
Just w -> do
name <- widgetGetName w
mbPane <- findPaneFor name
case mbPane of
Nothing -> return ()
Just (PaneC p) -> makeActive p
where
findPaneFor :: PaneMonad beta => Text -> beta (Maybe (IDEPane beta))
findPaneFor n1 = do
panes' <- getPanesSt
foldM (\r (PaneC p) -> do
n2 <- widgetGetName =<< getTopWidget p
return (if n1 == n2 then Just (PaneC p) else r))
Nothing (Map.elems panes')
--
-- | 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 -> return ()
Just (paneName,_) -> do
(PaneC pane) <- paneFromName paneName
mbPanePath <- getActivePanePath
case mbPanePath of
Nothing -> return ()
Just panePath -> do
layout <- getLayoutSt
case findMoveTarget panePath layout direction of
Nothing -> return ()
Just moveTo -> viewMoveTo moveTo pane
--
-- | Find the target for a move
--
findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath
findMoveTarget panePath layout direction=
let oppositeDir = otherDirection direction
canMove [] = []
canMove reversedPath =
case head reversedPath of
SplitP d | d == oppositeDir
-> SplitP direction : tail reversedPath
GroupP group -> []
_ -> canMove (tail reversedPath)
basePath = reverse (canMove $ reverse panePath)
in case basePath of
[] -> Nothing
_ -> let layoutP = layoutFromPath basePath layout
in Just $basePath ++ findAppropriate layoutP oppositeDir
--
-- | Moves the given Pane to the given path
--
viewMoveTo :: RecoverablePane alpha beta delta => PanePath -> alpha -> delta ()
viewMoveTo toPanePath pane = do
let name = paneName pane
toNB <- getNotebook' "move" toPanePath
move' (name,toNB)
--
-- | Moves the given Pane to the given path, care for groups (layout, paneMap)
--
move' :: PaneMonad alpha => (PaneName,Notebook) -> alpha ()
move' (paneName,toNB) = do
paneMap <- getPaneMapSt
panes <- getPanesSt
layout <- getLayout
frameState <- getFrameState
case groupPrefix `T.stripPrefix` paneName of
Just group ->
case findGroupPath group layout of
Nothing -> trace ("ViewFrame>>move': group not found: " <> T.unpack group) return ()
Just fromPath -> do
groupNBOrPaned <- getNotebookOrPaned fromPath return
fromNB <- getNotebook' "move'" (init fromPath)
toNBPtr <- liftIO $ unsafeManagedPtrCastPtr toNB
case toNBPtr `Map.lookup` panePathFromNB frameState of
Nothing -> trace "ViewFrame>>move': panepath for Notebook not found1" return ()
Just toPath ->
when (not (fromNB `equalManagedPtr` toNB || fromPath `isPrefixOf` toPath)) $ do
num <- notebookPageNum fromNB groupNBOrPaned
if num < 0
then trace "ViewFrame>>move': group notebook not found" return ()
else do
notebookRemovePage fromNB num
label <- groupLabel group
notebookInsertOrdered toNB groupNBOrPaned group noLabel Nothing True
notebookSetTabLabel toNB groupNBOrPaned (Just label)
adjustPanes fromPath (toPath ++ [GroupP group])
adjustLayoutForGroupMove fromPath toPath group
adjustNotebooks fromPath (toPath ++ [GroupP group])
layout2 <- getLayout
return ()
Nothing ->
case paneName `Map.lookup` panes of
Nothing -> trace ("ViewFrame>>move': pane not found: " <> T.unpack paneName) return ()
Just (PaneC pane) -> do
toNBPtr <- liftIO $ unsafeManagedPtrCastPtr toNB
case toNBPtr `Map.lookup` panePathFromNB frameState of
Nothing -> trace "ViewFrame>>move': panepath for Notebook not found2" return ()
Just toPath ->
case paneName `Map.lookup`paneMap of
Nothing -> trace ("ViewFrame>>move': pane data not found: " <> T.unpack paneName)
return ()
Just (fromPath,_) -> do
child <- getTopWidget pane
(fromPane,cid) <- guiPropertiesFromName paneName
fromNB <- getNotebook' "move'" fromPane
unless (fromNB `equalManagedPtr` toNB) $ do
num <- notebookPageNum fromNB child
if num < 0
then trace "ViewFrame>>move': widget not found" return ()
else do
notebookRemovePage fromNB num
notebookInsertOrdered toNB child paneName noLabel (paneTooltipText pane) False
let paneMap1 = Map.delete paneName paneMap
setPaneMapSt $ Map.insert paneName (toPath,cid) paneMap1
findAppropriate :: PaneLayout -> PaneDirection -> PanePath
findAppropriate (TerminalP {}) _ = []
findAppropriate (HorizontalP t b _) LeftP = SplitP TopP : findAppropriate t LeftP
findAppropriate (HorizontalP t b _) RightP = SplitP TopP : findAppropriate t RightP
findAppropriate (HorizontalP t b _) BottomP = SplitP BottomP : findAppropriate b BottomP
findAppropriate (HorizontalP t b _) TopP = SplitP TopP : findAppropriate b TopP
findAppropriate (VerticalP l r _) LeftP = SplitP LeftP : findAppropriate l LeftP
findAppropriate (VerticalP l r _) RightP = SplitP RightP : findAppropriate r RightP
findAppropriate (VerticalP l r _) BottomP = SplitP LeftP : findAppropriate l BottomP
findAppropriate (VerticalP l r _) TopP = SplitP LeftP : findAppropriate l TopP
--
-- | Bring the pane to the front position in its notebook
--
bringPaneToFront :: RecoverablePane alpha beta delta => alpha -> delta ()
bringPaneToFront pane = do
tv <- getTopWidget pane
w <- widgetGetToplevel tv
visible <- getWidgetVisible w
when visible $ liftIO (unsafeCastTo Window w) >>= windowPresent
setCurrentNotebookPages tv
setCurrentNotebookPages :: (MonadIO m, IsWidget widget) => widget -> m ()
setCurrentNotebookPages widget = do
mbParent <- widgetGetParent widget
case mbParent of
Just parent -> do
setCurrentNotebookPages parent
liftIO (castTo Notebook parent) >>= \case
Just notebook ->
notebookPageNum notebook widget >>= \case
-1 -> return ()
pageNum -> notebookSetCurrentPage notebook pageNum
Nothing -> return ()
Nothing -> return ()
--
-- | Get a valid panePath from a standard path.
--
getBestPanePath :: StandardPath -> PaneLayout -> PanePath
getBestPanePath sp pl = reverse $ getStandard' sp pl []
where
getStandard' (GroupP group:sp) (TerminalP {paneGroups = groups}) p
| group `Map.member` groups = getStandard' sp (groups Map.! group) (GroupP group:p)
getStandard' _ (TerminalP {}) p = p
getStandard' (SplitP LeftP:sp) (VerticalP l r _) p = getStandard' sp l (SplitP LeftP:p)
getStandard' (SplitP RightP:sp) (VerticalP l r _) p = getStandard' sp r (SplitP RightP:p)
getStandard' (SplitP TopP:sp) (HorizontalP t b _) p = getStandard' sp t (SplitP TopP:p)
getStandard' (SplitP BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (SplitP BottomP:p)
-- if no match get leftmost topmost
getStandard' _ (VerticalP l r _) p = getStandard' [] l (SplitP LeftP:p)
getStandard' _ (HorizontalP t b _) p = getStandard' [] t (SplitP TopP:p)
--
-- | Get a standard path.
--
getBestPathForId :: PaneMonad alpha => Text -> alpha PanePath
getBestPathForId id = do
p <- panePathForGroup id
l <- getLayout
return (getBestPanePath p l)
--
-- | Construct a new notebook
--
newNotebook' :: IO Notebook
newNotebook' = do
nb <- notebookNew
widgetSetSizeRequest nb 50 50
notebookSetTabPos nb PositionTypeTop
notebookSetShowTabs nb True
notebookSetScrollable nb True
setNotebookEnablePopup nb True
return nb
--
-- | Construct a new notebook,
--
newNotebook :: PaneMonad alpha => PanePath -> alpha Notebook
newNotebook pp = do
st <- getFrameState
nb <- liftIO newNotebook'
nbPtr <- liftIO $ unsafeManagedPtrCastPtr nb
setPanePathFromNB $ Map.insert nbPtr pp (panePathFromNB st)
func <- runInIO move'
tl <- targetListNew Nothing
targetListAddTextTargets tl 0
widgetDragDestSet nb [DestDefaultsAll] Nothing [DragActionCopy, DragActionMove]
widgetDragDestSetTargetList nb $ Just tl
onWidgetDragDataReceived nb (dragFunc nb func)
return nb
where
dragFunc ::
Notebook ->
((PaneName,Notebook) -> IO ()) ->
DragContext ->
Int32 ->
Int32 ->
SelectionData ->
Word32 ->
Word32 ->
IO ()
dragFunc nb func cont x y data_ id timeStamp =
selectionDataGetText data_ >>= \case
Nothing -> return ()
Just str -> do
trace ("dragFunc str=" <> T.unpack str) $ return ()
func (str,nb)
terminalsWithPanePath :: PaneLayout -> [(PanePath,PaneLayout)]
terminalsWithPanePath pl = map (first reverse) $ terminalsWithPP [] pl
where
terminalsWithPP pp t@(TerminalP groups _ _ _ _) = (pp, t) : concatMap (terminalsFromGroup pp)
(Map.toList groups)
terminalsWithPP pp (VerticalP l r _) = terminalsWithPP (SplitP LeftP : pp) l
++ terminalsWithPP (SplitP RightP : pp) r
terminalsWithPP pp (HorizontalP t b _) = terminalsWithPP (SplitP TopP : pp) t
++ terminalsWithPP (SplitP BottomP : pp) b
terminalsFromGroup pp (name,layout) = terminalsWithPP (GroupP name : pp) layout
findGroupPath :: Text -> PaneLayout -> Maybe PanePath
findGroupPath group layout =
let terminalPairs = terminalsWithPanePath layout
in case filter filterFunc terminalPairs of
[] -> Nothing
[(pp, _)] -> Just (pp ++ [GroupP group])
_ -> error ("ViewFrame>>group name not unique: " ++ T.unpack group)
where
filterFunc (_, TerminalP groups _ _ _ _) = group `Set.member` Map.keysSet groups
filterFunc _ = error "ViewFrame>>findGroupPath: impossible"
findDetachedPath :: Text -> PaneLayout -> Maybe PanePath
findDetachedPath id layout =
let terminalPairs = terminalsWithPanePath layout
in case filter filterFunc terminalPairs of
[] -> Nothing
[(pp, _)] -> Just pp
_ -> error ("ViewFrame>>window id not unique: " ++ T.unpack id)
where
filterFunc (_, TerminalP _ _ _ (Just lid) _) = lid == id
filterFunc _ = False
allGroupNames :: PaneLayout -> Set Text
allGroupNames pl = Set.unions $ map getFunc (terminalsWithPanePath pl)
where
getFunc (_, TerminalP groups _ _ _ _) = Map.keysSet groups
getFunc _ = error "ViewFrame>>allGroupNames: impossible"
--
-- | 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
in case head rp of
SplitP d -> Just (reverse $ SplitP (otherDirection d) : tail rp)
_ -> Nothing
--
-- | 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 (GroupP group:r) (TerminalP {paneGroups = groups})
| group `Map.member` groups = layoutFromPath r (groups Map.! group)
layoutFromPath (SplitP TopP:r) (HorizontalP t _ _) = layoutFromPath r t
layoutFromPath (SplitP BottomP:r) (HorizontalP _ b _) = layoutFromPath r b
layoutFromPath (SplitP LeftP:r) (VerticalP l _ _) = layoutFromPath r l
layoutFromPath (SplitP RightP:r) (VerticalP _ ri _) = layoutFromPath r ri
layoutFromPath pp l = error
$"inconsistent layout (layoutFromPath) " ++ show pp ++ " " ++ show l
layoutsFromPath :: PanePath -> PaneLayout -> [PaneLayout]
layoutsFromPath (GroupP group:r) layout@(TerminalP {paneGroups = groups})
| group `Map.member` groups
= layout:layoutsFromPath r (groups Map.! group)
layoutsFromPath [] layout = [layout]
layoutsFromPath (SplitP TopP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r t
layoutsFromPath (SplitP BottomP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r b
layoutsFromPath (SplitP LeftP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r l
layoutsFromPath (SplitP RightP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r ri
layoutsFromPath pp l = error
$"inconsistent layout (layoutsFromPath) " ++ show pp ++ " " ++ show l
getWidgetNameList :: PanePath -> PaneLayout -> [Text]
getWidgetNameList path layout = reverse $ nameList (reverse path) (reverse $ layoutsFromPath path layout)
where
nameList [] _ = reverse ["Leksah Main Window","topBox","root"]
nameList (pe:_) (TerminalP{detachedId = Just id}:_) = [panePathElementToWidgetName pe, id]
nameList (pe:rpath) (_:rlayout) = panePathElementToWidgetName pe : nameList rpath rlayout
nameList _ _ = error $ "inconsistent layout (getWidgetNameList) " ++ show path ++ " " ++ show layout
getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> IO beta) -> alpha beta
getNotebookOrPaned p cf = do
layout <- getLayout
(widgetGet $ getWidgetNameList p layout) cf
--
-- | Get the notebook widget for the given pane path
--
getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook
getNotebook p = getNotebookOrPaned p (unsafeCastTo Notebook)
getNotebook' :: PaneMonad alpha => Text -> PanePath -> alpha Notebook
getNotebook' str p = getNotebookOrPaned p (unsafeCastTo Notebook)
--
-- | Get the (gtk) Paned widget for a given path
--
getPaned :: PaneMonad alpha => PanePath -> alpha Paned
getPaned p = getNotebookOrPaned p $ unsafeCastTo Paned
--
-- | 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 (getBestPanePath sp layout)
--
-- | Get the active notebook
--
getActiveNotebook :: PaneMonad alpha => alpha (Maybe Notebook)
getActiveNotebook = do
mbPanePath <- getActivePanePath
case mbPanePath of
Just panePath -> do
nb <- getNotebook' "getActiveNotebook" panePath
return (Just nb)
Nothing -> return Nothing
--
-- | Translates a pane direction to the widget name
--
paneDirectionToWidgetName :: PaneDirection -> Text
paneDirectionToWidgetName TopP = "top"
paneDirectionToWidgetName BottomP = "bottom"
paneDirectionToWidgetName LeftP = "left"
paneDirectionToWidgetName RightP = "right"
panePathElementToWidgetName :: PanePathElement -> Text
panePathElementToWidgetName (SplitP dir) = paneDirectionToWidgetName dir
panePathElementToWidgetName (GroupP group) = groupPrefix <> group
--
-- | Changes a pane path in the pane map
--
adjustPanes :: PaneMonad alpha => PanePath -> PanePath -> alpha ()
adjustPanes fromPane toPane = do
paneMap <- getPaneMapSt
setPaneMapSt (Map.map (\(pp,other) ->
case stripPrefix fromPane pp of
Just rest -> (toPane ++ rest,other)
_ -> (pp,other)) paneMap)
adjustNotebooks :: PaneMonad alpha => PanePath -> PanePath -> alpha ()
adjustNotebooks fromPane toPane = do
npMap <- trace ("+++ adjustNotebooks from: " <> show fromPane <> " to " <> show toPane)
getPanePathFromNB
setPanePathFromNB (Map.map (\pp ->
case stripPrefix fromPane pp of
Just rest -> toPane ++ rest
_ -> pp) npMap)
--
-- | Changes the layout for a split
--
adjustLayoutForSplit :: PaneMonad alpha => PaneDirection -> PanePath -> alpha ()
adjustLayoutForSplit dir path = do
layout <- getLayoutSt
let paneLayout = layoutFromPath path layout
newLayout = TerminalP Map.empty Nothing 0 Nothing Nothing
newTerm = case dir of
LeftP -> VerticalP paneLayout newLayout 0
RightP -> VerticalP newLayout paneLayout 0
TopP -> HorizontalP paneLayout newLayout 0
BottomP -> HorizontalP newLayout paneLayout 0
setLayoutSt $ adjustLayout path layout newTerm
--
-- | Changes the layout for a nest
--
adjustLayoutForNest :: PaneMonad alpha => Text -> PanePath -> alpha ()
adjustLayoutForNest group path = do
layout <- getLayoutSt
let paneLayout = layoutFromPath path layout
newTerm = case paneLayout of
(TerminalP {paneGroups = groups}) -> paneLayout {
paneGroups = Map.insert group (TerminalP Map.empty Nothing 0 Nothing Nothing) groups}
_ -> error "Unexpected layout type in adjustLayoutForNest"
setLayoutSt $ adjustLayout path layout newTerm
--
-- | Changes the layout for a detach
--
adjustLayoutForDetach :: PaneMonad alpha => Text -> PanePath -> alpha ()
adjustLayoutForDetach id path = do
layout <- getLayoutSt
let paneLayout = layoutFromPath path layout
newTerm = case paneLayout of
(TerminalP {}) -> paneLayout {detachedId = Just id}
_ -> error "Unexpected layout type in adjustLayoutForDetach"
setLayoutSt $ adjustLayout path layout newTerm
--
-- | Changes the layout for a reattach
--
adjustLayoutForReattach :: PaneMonad alpha => PanePath -> alpha ()
adjustLayoutForReattach path = do
layout <- getLayoutSt
let paneLayout = layoutFromPath path layout
newTerm = case paneLayout of
(TerminalP {}) -> paneLayout {detachedId = Nothing, detachedSize = Nothing}
_ -> error "Unexpected layout type in adjustLayoutForReattach"
setLayoutSt $ adjustLayout path layout newTerm
--
-- | Changes the layout for a collapse
--
adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha ()
adjustLayoutForCollapse oldPath = do
layout <- getLayoutSt
let pathLayout = layoutFromPath oldPath layout
setLayoutSt $ adjustLayout (init oldPath) layout pathLayout
--
-- | Changes the layout for a move
--
adjustLayoutForGroupMove :: PaneMonad alpha => PanePath -> PanePath -> Text -> alpha ()
adjustLayoutForGroupMove fromPath toPath group = do
layout <- getLayout
let layoutToMove = layoutFromPath fromPath layout
let newLayout = removeGL fromPath layout
setLayoutSt (addGL layoutToMove (toPath ++ [GroupP group]) newLayout)
--
-- | Changes the layout for a remove
--
adjustLayoutForGroupRemove :: PaneMonad alpha => PanePath -> Text -> alpha ()
adjustLayoutForGroupRemove fromPath group = do
layout <- getLayout
setLayoutSt (removeGL fromPath layout)
--
-- | Remove group layout at a certain path
--
removeGL :: PanePath -> PaneLayout -> PaneLayout
removeGL [GroupP group] t@(TerminalP oldGroups _ _ _ _)
| group `Map.member` oldGroups = t{paneGroups = group `Map.delete` oldGroups}
removeGL (GroupP group:r) old@(TerminalP {paneGroups = groups})
| group `Map.member` groups = old{paneGroups = Map.adjust (removeGL r) group groups}
removeGL (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (removeGL r tp) bp 0
removeGL (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (removeGL r bp) 0
removeGL (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (removeGL r lp) rp 0
removeGL (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (removeGL r rp) 0
removeGL p l = error $"ViewFrame>>removeGL: inconsistent layout " ++ show p ++ " " ++ show l
--
-- | Add group layout at a certain path
--
addGL :: PaneLayout -> PanePath -> PaneLayout -> PaneLayout
addGL toAdd [GroupP group] t@(TerminalP oldGroups _ _ _ _) = t{paneGroups = Map.insert group toAdd oldGroups}
addGL toAdd (GroupP group:r) old@(TerminalP {paneGroups = groups})
| group `Map.member` groups = old{paneGroups = Map.adjust (addGL toAdd r) group groups}
addGL toAdd (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (addGL toAdd r tp) bp 0
addGL toAdd (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (addGL toAdd r bp) 0
addGL toAdd (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (addGL toAdd r lp) rp 0
addGL toAdd (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (addGL toAdd r rp) 0
addGL _ p l = error $"ViewFrame>>addGL: inconsistent layout" ++ show p ++ " " ++ show l
--
-- | Changes the layout by replacing element at pane path (pp) with replace
--
adjustLayout :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout
adjustLayout pp layout replace = adjust' pp layout
where
adjust' [] _ = replace
adjust' (GroupP group:r) old@(TerminalP {paneGroups = groups})
| group `Map.member` groups =
old{paneGroups = Map.adjust (adjustPaneGroupLayout r) group groups}
adjust' (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0
adjust' (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0
adjust' (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0
adjust' (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0
adjust' p l = error $"inconsistent layout (adjust) " ++ show p ++ " " ++ show l
adjustPaneGroupLayout = adjust'
--
-- | Get the widget from a list of strings
--
widgetFromPath :: MonadIO m => Widget -> [Text] -> m Widget
widgetFromPath w [] = return w
widgetFromPath w path = do
children <- liftIO (unsafeCastTo Container w) >>= containerGetChildren
chooseWidgetFromPath children path
chooseWidgetFromPath :: MonadIO m => [Widget] -> [Text] -> m Widget
chooseWidgetFromPath _ [] = error "Cant't find widget (empty path)"
chooseWidgetFromPath widgets (h:t) = do
names <- mapM widgetGetName widgets
let mbiInd = elemIndex h names
case mbiInd of
Nothing -> error $"Cant't find widget path " ++ show (h:t) ++ " found only " ++ show names
Just ind -> widgetFromPath (widgets !! ind) t
widgetGet :: PaneMonad alpha => [Text] -> (Widget -> IO b) -> alpha b
widgetGet strL cf = do
windows <- getWindowsSt
widgets <- liftIO $ mapM toWidget windows
r <- liftIO $ chooseWidgetFromPath widgets strL
liftIO (cf r)
widgetGetRel :: Widget -> [Text] -> (Widget -> b) -> IO b
widgetGetRel w sl cf = do
r <- widgetFromPath w sl
return (cf r)
getUIAction :: PaneMonad alpha => Text -> (Action -> IO a) -> alpha a
getUIAction str f = do
uiManager <- getUiManagerSt
findAction <- uIManagerGetAction uiManager str
case findAction of
Just act -> liftIO $ f act
Nothing -> error $"getUIAction can't find action " ++ T.unpack str
getThis :: PaneMonad delta => (FrameState delta -> alpha) -> delta alpha
getThis sel = do
st <- getFrameState
return (sel st)
setThis :: PaneMonad delta => (FrameState delta -> alpha -> FrameState delta) -> alpha -> delta ()
setThis sel value = do
st <- getFrameState
trace ("!!! setFrameState " <> show (sel st value)) $ setFrameState (sel st value)
getWindowsSt = getThis windows
setWindowsSt = setThis (\st value -> st{windows = value})
getUiManagerSt = getThis uiManager
getPanesSt = getThis panes
setPanesSt = setThis (\st value -> st{panes = value})
getPaneMapSt = getThis paneMap
setPaneMapSt = setThis (\st value -> st{paneMap = value})
getActivePaneSt = getThis activePane
setActivePaneSt = setThis (\st value -> st{activePane = value})
getLayoutSt = getThis layout
setLayoutSt = setThis (\st value -> st{layout = value})
getPanePathFromNB = getThis panePathFromNB
setPanePathFromNB = setThis (\st value -> st{panePathFromNB = value})
getActivePane = getActivePaneSt
setActivePane = setActivePaneSt
getUiManager = getUiManagerSt
getWindows = getWindowsSt
getMainWindow = liftM head getWindows
getLayout = getLayoutSt