ltk 0.15.0.3 → 0.15.0.4
raw patch · 2 files changed
+1472/−1468 lines, 2 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Graphics.UI.Frame.ViewFrame: viewMoveTo :: RecoverablePane alpha beta delta => PanePath -> alpha -> delta ()
Files
- ltk.cabal +1/−1
- src/Graphics/UI/Frame/ViewFrame.hs +1471/−1467
ltk.cabal view
@@ -1,5 +1,5 @@ name: ltk-version: 0.15.0.3+version: 0.15.0.4 cabal-version: >= 1.8 build-type: Simple license: GPL
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -1,1467 +1,1471 @@-{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- --- 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 -, 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 Graphics.UI.Gtk - (castToNotebook, uiManagerGetAction, Action, Paned, - selectionDataGetText, SelectionDataM, InfoId, Point, DragContext, - dragDataReceived, dragDestSetTargetList, dragDestSet, - notebookSetPopup, notebookSetScrollable, notebookNew, - windowPresent, widgetVisible, notebookRemovePage, Notebook, - windowGetScreen, Screen, castToWindow, gTypeWindow, - widgetGetToplevel, deleteEvent, widgetGetAllocation, - windowSetDefaultSize, widgetName, windowNew, Widget, - dialogResponse, dialogGetActionArea, castToHBox, - dialogGetContentArea, windowTitle, windowTransientFor, dialogNew, - Window, widgetDestroy, dialogRun, messageDialogNew, castToWidget, - switchPage, widgetGrabFocus, castToVBox, boxReorderChild, - castToBox, notebookSetMenuLabel, notebookSetTabLabel, - notebookInsertPage, panedPack1, castToContainer, containerRemove, - notebookPageNum, panedPack2, hPanedNew, castToPaned, vPanedNew, - widgetGetParent, notebookGetCurrentPage, notebookSetTabPos, - PositionType, notebookSetShowTabs, notebookGetShowTabs, - castToLabel, containerGetChildren, castToBin, binGetChild, - notebookGetTabLabel, labelSetMarkup, labelSetUseMarkup, - buttonActivated, selectionDataSetText, dragDataGet, - dragSourceSetTargetList, targetListAddTextTargets, targetListNew, - dragSourceSet, boxPackStart, containerAdd, containerSetBorderWidth, - widgetSetVAlign, widgetGetStyleContext, stockClose, - imageNewFromStock, imageNewFromPixbuf, iconThemeLoadIcon, - iconThemeGetDefault, buttonSetAlignment, buttonSetRelief, - buttonSetFocusOnClick, buttonNew, hBoxNew, - eventBoxSetVisibleWindow, eventBoxNew, miscSetPadding, castToMisc, - miscSetAlignment, EventBox, notebookSetCurrentPage, widgetShowAll, - notebookInsertPageMenu, widgetGetName, notebookGetNthPage, - notebookGetNPages, labelNew, Label, WidgetClass, NotebookClass, - widgetSetName, IconSize(..), ResponseId(..), Rectangle(..), - DragAction(..), DestDefaults(..), PositionType(..), Packing(..), - ReliefStyle(..), IconLookupFlags(..), after, on, ButtonsType(..), - MessageType(..), AttrOp(..), get, set) -import qualified Data.Map as Map -import Data.List -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.Glib (GObjectClass(..), isA) -import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook) -import System.CPUTime (getCPUTime) -import Graphics.UI.Gtk.Gdk.EventM- (Modifier(..), eventModifierMouse, TimeStamp(..)) -import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString) -import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider) -import Graphics.UI.Gtk.General.Enums (Align(..)) -import MyMissing (forceJust, forceHead) -import Graphics.UI.Editor.MakeEditor - (mkField, FieldDescription(..), buildEditor) -import Graphics.UI.Editor.Simple (stringEditor, textEditor, okCancelFields) -import Control.Event (registerEvent) -import Graphics.UI.Editor.Basics - (eventText, GUIEventSelector(..)) -import qualified Data.Set as Set (unions, member) -import Data.Set (Set(..)) -import Graphics.UI.Gtk.Gdk.Events (Event(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (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 Graphics.UI.Gtk.Abstract.Widget (buttonReleaseEvent) -import Data.Foldable (forM_)-import Control.Arrow (Arrow(..))- ---import Debug.Trace (trace) -trace (a::Text) 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 - liftIO $ widgetSetName (getTopWidget pane) (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" <>- 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 => (NotebookClass self, WidgetClass 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 - -> Bool - -> alpha () -notebookInsertOrdered nb widget labelStr mbLabel isGroup = do - label <- case mbLabel of - Nothing -> liftIO $ labelNew (Just labelStr) - Just l -> return l - menuLabel <- liftIO $ labelNew (Just labelStr) - numPages <- liftIO $ notebookGetNPages nb - mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)] - let widgets = map (`forceJust` "ViewFrame.notebookInsertOrdered: no widget") mbWidgets - labelStrs <- liftIO $ mapM widgetGetName widgets - let pos = fromMaybe (-1)- (findIndex- (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr)- labelStrs) - labelBox <- if isGroup then groupLabel labelStr else mkLabelBox label labelStr - liftIO $ do - markLabel nb labelBox False - realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos - widgetShowAll labelBox - notebookSetCurrentPage nb realPos - --- | Returns a label box -mkLabelBox :: PaneMonad alpha => Label -> Text -> alpha EventBox -mkLabelBox lbl paneName = do - (tb,lb) <- liftIO $ do - miscSetAlignment (castToMisc lbl) 0.0 0.0 - miscSetPadding (castToMisc lbl) 0 0 - - labelBox <- eventBoxNew - eventBoxSetVisibleWindow labelBox False - innerBox <- hBoxNew False 0 - - tabButton <- buttonNew - widgetSetName tabButton ("leksah-close-button"::Text) - buttonSetFocusOnClick tabButton False - buttonSetRelief tabButton ReliefNone - buttonSetAlignment tabButton (0.0,0.0) - - iconTheme <- iconThemeGetDefault - mbIcon <- iconThemeLoadIcon iconTheme ("window-close"::Text) 10 IconLookupUseBuiltin - image <- case mbIcon of - Just i -> imageNewFromPixbuf i - Nothing -> imageNewFromStock stockClose IconSizeMenu - - provider <- cssProviderNew - cssProviderLoadFromString provider ( - ".button {\n" <> - "-GtkButton-default-border : 0px;\n" <> - "-GtkButton-default-outside-border : 0px;\n" <> - "-GtkButton-inner-border: 0px;\n" <> - "-GtkWidget-focus-line-width : 0px;\n" <> - "-GtkWidget-focus-padding : 0px;\n" <> - "padding: 0px;\n" <> - "border-width: 0px;\n" <> - "}\n" <> - "GtkImage {\n" <> - "padding: 0px;\n" <> - "}\n" :: Text) - context <- widgetGetStyleContext tabButton - styleContextAddProvider context provider 600 - context <- widgetGetStyleContext image - styleContextAddProvider context provider 600 - widgetSetVAlign tabButton AlignCenter - widgetSetVAlign lbl AlignCenter-- containerSetBorderWidth tabButton 0 - containerAdd tabButton image - - boxPackStart innerBox lbl PackGrow 0 - boxPackStart innerBox tabButton PackNatural 5 - - containerAdd labelBox innerBox - dragSourceSet labelBox [Button1] [ActionCopy,ActionMove] - tl <- targetListNew - targetListAddTextTargets tl 0 - dragSourceSetTargetList labelBox tl - on labelBox dragDataGet (\ cont id timeStamp -> do - selectionDataSetText paneName - return ()) - return (tabButton,labelBox) - cl <- runInIO closeHandler - liftIO $ on tb buttonActivated (cl ()) - liftIO $ on lb buttonReleaseEvent $ do - modifiers <- eventModifierMouse - let middleButton = Button2 - when (middleButton `elem` modifiers) (liftIO $ cl ()) - return False - - return lb - 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 <- liftIO $ labelNew (Nothing::Maybe Text) - liftIO $ labelSetUseMarkup label True - liftIO $ labelSetMarkup label ("<b>" <> group <> "</b>") - labelBox <- mkLabelBox label (groupPrefix <> group) - liftIO $ widgetShowAll labelBox - return labelBox - --- | Add the change mark or removes it -markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () -markLabel nb topWidget modified = do - mbBox <- notebookGetTabLabel nb topWidget - case mbBox of - Nothing -> return () - Just box -> do - mbContainer <- binGetChild (castToBin box) - case mbContainer of - Nothing -> return () - Just container -> do - children <- containerGetChildren container - let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children" - (text :: Text) <- widgetGetName topWidget - labelSetUseMarkup (castToLabel label) True - labelSetMarkup (castToLabel 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 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 - l <- getLayout - case layoutFromPath panePath l of - (TerminalP _ _ _ (Just _) _) -> trace "ViewFrame>>viewSplit': can't split detached: " return () - _ -> do - activeNotebook <- getNotebook' "viewSplit" panePath - ind <- liftIO $ notebookGetCurrentPage activeNotebook - mbPD <- do - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> trace "ViewFrame>>viewSplit': parent not found: " return Nothing - Just parent -> do - (nb,paneDir) <- do - let (name,altname,paneDir, - oldPath,newPath) = case dir of - Horizontal -> ("top", - "bottom", - TopP, - panePath ++ [SplitP TopP], - panePath ++ [SplitP BottomP]) - Vertical -> ("left", - "right", - LeftP, - panePath ++ [SplitP LeftP], - panePath ++ [SplitP RightP]) - adjustNotebooks panePath oldPath - frameState <- getFrameState - setPanePathFromNB $ Map.insert activeNotebook oldPath (panePathFromNB frameState) - nb <- newNotebook newPath - (np,nbi) <- liftIO $ do - newpane <- case dir of - Horizontal -> do h <- vPanedNew - return (castToPaned h) - Vertical -> do v <- hPanedNew - return (castToPaned v) - rName::Text <- widgetGetName activeNotebook - widgetSetName newpane rName - widgetSetName nb (altname :: Text) - panedPack2 newpane nb True True - nbIndex <- if parent `isA` gTypeNotebook - then notebookPageNum (castToNotebook' "viewSplit'1" parent) activeNotebook - else trace "ViewFrame>>viewSplit': parent not a notebook: " return Nothing - containerRemove (castToContainer parent) activeNotebook - widgetSetName activeNotebook (name :: Text) - panedPack1 newpane activeNotebook True True - return (newpane,nbIndex) - case (reverse panePath, nbi) of - (SplitP dir:_, _) - | dir `elem` [TopP, LeftP] -> liftIO $ panedPack1 (castToPaned parent) np True True - | otherwise -> liftIO $ panedPack2 (castToPaned parent) np True True - (GroupP group:_, Just n) -> do - liftIO $ notebookInsertPage (castToNotebook' "viewSplit' 2" parent) np group n - label <- groupLabel group - liftIO $ notebookSetTabLabel (castToNotebook' "viewSplit' 3" parent) np label - label2 <- groupMenuLabel group - liftIO $ notebookSetMenuLabel (castToNotebook' "viewSplit' 4" parent) np label2 - return () - ([], _) -> do - liftIO $ boxPackStart (castToBox parent) np PackGrow 0 - liftIO $ boxReorderChild (castToVBox parent) np 2 - _ -> error "No notebook index found in viewSplit" - liftIO $ do - widgetShowAll np - widgetGrabFocus activeNotebook - case nbi of - Just n -> do - notebookSetCurrentPage (castToNotebook' "viewSplit' 5" parent) n - return () - _ -> trace "ViewFrame>>viewSplit': parent not a notebook2: "return () - return (nb,paneDir) - handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ after nb switchPage handleFunc - return (Just (paneDir,dir)) - case mbPD of - Just (paneDir,pdir) -> do - adjustPanes panePath (panePath ++ [SplitP paneDir]) - adjustLayoutForSplit paneDir panePath - mbWidget <- liftIO $ notebookGetNthPage activeNotebook ind - when (isJust mbWidget) $ do - name <- liftIO $ widgetGetName (fromJust mbWidget) - mbPane <- mbPaneFromName name - case mbPane of - Just (PaneC pane) -> move (panePath ++ [SplitP (otherDirection paneDir)]) pane - Nothing -> return () - 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 castToWidget - let nb = if nbop `isA` gTypeNotebook - then Just (castToNotebook' "viewCollapse' 0" nbop) - else Nothing - 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 - otherwise -> 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) -> move 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 - let ! newMap = Map.delete otherSideNotebook (panePathFromNB st) - setPanePathFromNB newMap - -- 3. Remove one level and reparent notebook - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> error "collapse: no parent" - Just parent -> do - mbGrandparent <- liftIO $ widgetGetParent parent - case mbGrandparent of - Nothing -> error "collapse: no grandparent" - Just grandparent -> do - nbIndex <- if grandparent `isA` gTypeNotebook - then liftIO $ notebookPageNum (castToNotebook' "viewCollapse'' 1" grandparent) parent - else return Nothing - liftIO $ containerRemove (castToContainer grandparent) parent - liftIO $ containerRemove (castToContainer parent) activeNotebook - if length panePath > 1 - then do - let lasPathElem = last newPanePath - case (lasPathElem, nbIndex) of - (SplitP dir, _) | dir == TopP || dir == LeftP -> - liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True True - (SplitP dir, _) | dir == BottomP || dir == RightP -> - liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True True - (GroupP group, Just n) -> do - liftIO $ notebookInsertPage (castToNotebook' "viewCollapse'' 2" grandparent) activeNotebook group n - label <- groupLabel group - liftIO $ do - notebookSetTabLabel (castToNotebook' "viewCollapse'' 3" grandparent) activeNotebook label - notebookSetCurrentPage (castToNotebook' "viewCollapse'' 4" grandparent) n - return () - _ -> error "collapse: Unable to find page index" - liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem - else liftIO $ do - boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 - boxReorderChild (castToVBox grandparent) activeNotebook 2 - widgetSetName activeNotebook ("root" :: Text) - -- 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 <- liftIO $ groupNameDialog mainWindow - case - mbGroupName of - Just groupName -> do - layout <- getLayoutSt - if groupName `Set.member` allGroupNames layout - then liftIO $ do - md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose - ("Group name not unique " <> groupName) - 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 castToWidget - liftIO $ setCurrentNotebookPages widget - return (Just path) - Nothing -> return Nothing - - --- Yet another stupid little dialog - -groupNameDialog :: Window -> IO (Maybe Text) -groupNameDialog parent = liftIO $ do - dia <- dialogNew - set dia [ windowTransientFor := parent - , windowTitle := ("Enter group name" :: Text) ] - upper <- castToVBox <$> dialogGetContentArea dia - lower <- castToHBox <$> dialogGetActionArea dia - (widget,inj,ext,_) <- buildEditor moduleFields "" - (widget2,_,_,notifier) <- buildEditor okCancelFields () - registerEvent notifier ButtonPressed (\e -> do - case eventText e of - "Ok" -> dialogResponse dia ResponseOk - _ -> dialogResponse dia ResponseCancel - return e) - boxPackStart upper widget PackGrow 7 - boxPackStart lower widget2 PackNatural 7 - widgetShowAll dia - resp <- dialogRun dia - value <- ext "" - widgetDestroy dia - case resp of - ResponseOk | value /= Just "" -> return value - _ -> return Nothing - where - moduleFields :: FieldDescription Text - moduleFields = VFD emptyParams [ - mkField - (paraName <<<- ParaName "New group " - $ 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 - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> return () - Just parent -> do - layout <- getLayoutSt - let paneLayout = layoutFromPath panePath layout - case paneLayout of - (TerminalP {}) -> do - nb <- newNotebook (panePath ++ [GroupP group]) - liftIO $ widgetSetName nb (groupPrefix <> group) - notebookInsertOrdered activeNotebook nb group Nothing True - liftIO $ widgetShowAll nb - --widgetGrabFocus activeNotebook - handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ after nb switchPage handleFunc - 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: " <> 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 - (_:_) -> liftIO $ do - md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo - ("Group " <> groupName <> " not empty. Close with all contents?") - rid <- dialogRun md - widgetDestroy md - case rid of - ResponseYes -> 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 castToWidget - mbParent <- liftIO $ widgetGetParent nbOrPaned - case mbParent of - Nothing -> error "ViewFrame>>closeGroup: closeGroup: no parent" - Just parent -> liftIO $ containerRemove (castToContainer parent) nbOrPaned - setLayoutSt (removeGL path layout) - ppMap <- getPanePathFromNB - setPanePathFromNB (Map.filter (\pa -> not (path `isPrefixOf` pa)) ppMap) - -viewDetach :: PaneMonad alpha => alpha (Maybe (Window,Widget)) -viewDetach = do - id <- liftIO $ fmap 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,Widget)) -viewDetach' panePath id = do - activeNotebook <- getNotebook' "viewDetach'" panePath - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> return Nothing - Just parent -> do - layout <- getLayoutSt - let paneLayout = layoutFromPath panePath layout - case paneLayout of - (TerminalP{detachedSize = size}) -> do - window <- liftIO $ do - window <- windowNew - set window [ windowTitle := ("Leksah detached window" :: Text) - , widgetName := Just id ] - case size of - Just (width, height) -> windowSetDefaultSize window width height - Nothing -> do - (Rectangle _ _ curWidth curHeight) <- widgetGetAllocation activeNotebook - windowSetDefaultSize window curWidth curHeight - containerRemove (castToContainer parent) activeNotebook - containerAdd window activeNotebook - widgetShowAll window - return window - handleFunc <- runInIO (handleReattach id window) - liftIO . on window deleteEvent . liftIO $ handleFunc () - windows <- getWindowsSt - setWindowsSt $ windows ++ [window] - adjustLayoutForDetach id panePath - return (Just (window, castToWidget 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: " <> windowId) - $ do - windows <- getWindowsSt - setWindowsSt $ delete window windows - return False - Just pp -> do - nb <- getNotebook' "handleReattach" pp - parent <- getNotebookOrPaned (init pp) castToContainer - liftIO $ containerRemove (castToContainer window) nb - liftIO $ containerAdd parent nb - adjustLayoutForReattach pp - windows <- getWindowsSt - setWindowsSt $ delete window windows - case last pp of - GroupP groupName -> do - label <- groupLabel groupName - liftIO $ notebookSetTabLabel (castToNotebook' "handleReattach" parent) nb 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 - top <- liftIO $ widgetGetToplevel activeNotebook - if top `isA` gTypeWindow- then return . Just $ castToWindow top- else return Nothing - -getActiveScreen :: PaneMonad alpha => alpha (Maybe Screen) -getActiveScreen = do - mbWindow <- getActiveWindow - case mbWindow of - Nothing -> return Nothing - Just window -> liftIO $ Just <$> windowGetScreen window - -groupMenuLabel :: PaneMonad beta => Text -> beta (Maybe Label) -groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) - -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 - name <- liftIO $ 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 <- liftIO $ 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 -> move 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 --- -move :: RecoverablePane alpha beta delta => PanePath -> alpha -> delta () -move 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: " <> group) return () - Just fromPath -> do - groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget - fromNB <- getNotebook' "move'" (init fromPath) - case toNB `Map.lookup` panePathFromNB frameState of - Nothing -> trace "ViewFrame>>move': panepath for Notebook not found1" return () - Just toPath -> - when (fromNB /= toNB && not (fromPath `isPrefixOf` toPath)) $ do - mbNum <- liftIO $ notebookPageNum fromNB groupNBOrPaned - case mbNum of - Nothing -> trace "ViewFrame>>move': group notebook not found" return () - Just num -> do - liftIO $ notebookRemovePage fromNB num - label <- groupLabel group - notebookInsertOrdered toNB groupNBOrPaned group Nothing True - liftIO $ notebookSetTabLabel toNB groupNBOrPaned 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: " <> paneName) return () - Just (PaneC pane) -> - case toNB `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: " <> paneName) - return () - Just (fromPath,_) -> do - let child = getTopWidget pane - (fromPane,cid) <- guiPropertiesFromName paneName - fromNB <- getNotebook' "move'" fromPane - when (fromNB /= toNB) $ do - mbNum <- liftIO $ notebookPageNum fromNB child - case mbNum of - Nothing -> trace "ViewFrame>>move': widget not found" return () - Just num -> do - liftIO $ notebookRemovePage fromNB num - notebookInsertOrdered toNB child paneName Nothing 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 -> IO () -bringPaneToFront pane = do - let tv = getTopWidget pane - w <- widgetGetToplevel tv - visible <- w `get` widgetVisible - when visible . windowPresent $ castToWindow w - setCurrentNotebookPages tv - - -setCurrentNotebookPages widget = do - mbParent <- widgetGetParent widget - case mbParent of - Just parent -> do - setCurrentNotebookPages parent - when (parent `isA` gTypeNotebook) $ do- mbPageNum <- notebookPageNum- (castToNotebook' "setCurrentNotebookPage 1" parent)- widget- case mbPageNum of- Just pageNum -> do- notebookSetCurrentPage- (castToNotebook' "setCurrentNotebookPage 2" parent)- pageNum- return ()- 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 - notebookSetTabPos nb PosTop - notebookSetShowTabs nb True - notebookSetScrollable nb True - notebookSetPopup nb True - return nb - --- --- | Construct a new notebook, --- -newNotebook :: PaneMonad alpha => PanePath -> alpha Notebook -newNotebook pp = do - st <- getFrameState - nb <- liftIO newNotebook' - setPanePathFromNB $ Map.insert nb pp (panePathFromNB st) - func <- runInIO move' - liftIO $ do - tl <- targetListNew - targetListAddTextTargets tl 0 - dragDestSet nb [DestDefaultAll] [ActionCopy, ActionMove] - dragDestSetTargetList nb tl - on nb dragDataReceived (dragFunc nb func) - return nb - where - dragFunc :: - Notebook -> - ((PaneName,Notebook) -> IO ()) -> - DragContext -> - Point -> - InfoId -> - TimeStamp ->- SelectionDataM () - dragFunc nb func cont point id timeStamp = do - mbText <- selectionDataGetText - case mbText of - Nothing -> return () - Just str -> do - Gtk.liftIO $ func (str,nb) - return () - -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 -> 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 (castToNotebook' ("getNotebook " <> T.pack (show p))) - -getNotebook' :: PaneMonad alpha => Text -> PanePath -> alpha Notebook -getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " <> str <> " " <> T.pack (show p))) - - --- --- | 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 (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: " <> T.pack (show fromPane) <> " to " <> T.pack (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 :: Widget -> [Text] -> IO Widget -widgetFromPath w [] = return w -widgetFromPath w path = do - children <- containerGetChildren (castToContainer w) - chooseWidgetFromPath children path - -chooseWidgetFromPath :: [Widget] -> [Text] -> IO 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 -> b) -> alpha b -widgetGet strL cf = do - windows <- getWindowsSt - r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL - return (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 -> 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 " ++ 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 " <> T.pack (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 - -castToNotebook' :: GObjectClass obj => Text -> obj -> Notebook -castToNotebook' str obj = if obj `isA` gTypeNotebook - then castToNotebook obj - else error . T.unpack $ "Not a notebook " <> str - +{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- 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 Graphics.UI.Gtk+ (castToNotebook, uiManagerGetAction, Action, Paned,+ selectionDataGetText, SelectionDataM, InfoId, Point, DragContext,+ dragDataReceived, dragDestSetTargetList, dragDestSet,+ notebookSetPopup, notebookSetScrollable, notebookNew,+ windowPresent, widgetVisible, notebookRemovePage, Notebook,+ windowGetScreen, Screen, castToWindow, gTypeWindow,+ widgetGetToplevel, deleteEvent, widgetGetAllocation,+ windowSetDefaultSize, widgetName, windowNew, Widget,+ dialogResponse, dialogGetActionArea, castToHBox,+ dialogGetContentArea, windowTitle, windowTransientFor, dialogNew,+ Window, widgetDestroy, dialogRun, messageDialogNew, castToWidget,+ switchPage, widgetGrabFocus, castToVBox, boxReorderChild,+ castToBox, notebookSetMenuLabel, notebookSetTabLabel,+ notebookInsertPage, panedPack1, castToContainer, containerRemove,+ notebookPageNum, panedPack2, hPanedNew, castToPaned, vPanedNew,+ widgetGetParent, notebookGetCurrentPage, notebookSetTabPos,+ PositionType, notebookSetShowTabs, notebookGetShowTabs,+ castToLabel, containerGetChildren, castToBin, binGetChild,+ notebookGetTabLabel, labelSetMarkup, labelSetUseMarkup,+ buttonActivated, selectionDataSetText, dragDataGet,+ dragSourceSetTargetList, targetListAddTextTargets, targetListNew,+ dragSourceSet, boxPackStart, containerAdd, containerSetBorderWidth,+ widgetSetVAlign, widgetGetStyleContext, stockClose,+ imageNewFromStock, imageNewFromPixbuf, iconThemeLoadIcon,+ iconThemeGetDefault, buttonSetAlignment, buttonSetRelief,+ buttonSetFocusOnClick, buttonNew, hBoxNew,+ eventBoxSetVisibleWindow, eventBoxNew, miscSetPadding, castToMisc,+ miscSetAlignment, EventBox, notebookSetCurrentPage, widgetShowAll,+ notebookInsertPageMenu, widgetGetName, notebookGetNthPage,+ notebookGetNPages, labelNew, Label, WidgetClass, NotebookClass,+ widgetSetName, IconSize(..), ResponseId(..), Rectangle(..),+ DragAction(..), DestDefaults(..), PositionType(..), Packing(..),+ ReliefStyle(..), IconLookupFlags(..), after, on, ButtonsType(..),+ MessageType(..), AttrOp(..), get, set)+import qualified Data.Map as Map+import Data.List+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.Glib (GObjectClass(..), isA)+import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook)+import System.CPUTime (getCPUTime)+import Graphics.UI.Gtk.Gdk.EventM+ (Modifier(..), eventModifierMouse, TimeStamp(..))+import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString)+import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider)+import Graphics.UI.Gtk.General.Enums (Align(..))+import MyMissing (forceJust, forceHead)+import Graphics.UI.Editor.MakeEditor+ (mkField, FieldDescription(..), buildEditor)+import Graphics.UI.Editor.Simple (stringEditor, textEditor, okCancelFields)+import Control.Event (registerEvent)+import Graphics.UI.Editor.Basics+ (eventText, GUIEventSelector(..))+import qualified Data.Set as Set (unions, member)+import Data.Set (Set(..))+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (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 Graphics.UI.Gtk.Abstract.Widget+ (widgetSetSizeRequest, buttonReleaseEvent)+import Data.Foldable (forM_)+import Control.Arrow (Arrow(..))++--import Debug.Trace (trace)+trace (a::Text) 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+ liftIO $ widgetSetName (getTopWidget pane) (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" <>+ 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 => (NotebookClass self, WidgetClass 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+ -> Bool+ -> alpha ()+notebookInsertOrdered nb widget labelStr mbLabel isGroup = do+ label <- case mbLabel of+ Nothing -> liftIO $ labelNew (Just labelStr)+ Just l -> return l+ menuLabel <- liftIO $ labelNew (Just labelStr)+ numPages <- liftIO $ notebookGetNPages nb+ mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)]+ let widgets = map (`forceJust` "ViewFrame.notebookInsertOrdered: no widget") mbWidgets+ labelStrs <- liftIO $ mapM widgetGetName widgets+ let pos = fromMaybe (-1)+ (findIndex+ (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr)+ labelStrs)+ labelBox <- if isGroup then groupLabel labelStr else mkLabelBox label labelStr+ liftIO $ do+ markLabel nb labelBox False+ realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos+ widgetShowAll labelBox+ notebookSetCurrentPage nb realPos++-- | Returns a label box+mkLabelBox :: PaneMonad alpha => Label -> Text -> alpha EventBox+mkLabelBox lbl paneName = do+ (tb,lb) <- liftIO $ do+ miscSetAlignment (castToMisc lbl) 0.0 0.0+ miscSetPadding (castToMisc lbl) 0 0++ labelBox <- eventBoxNew+ eventBoxSetVisibleWindow labelBox False+ innerBox <- hBoxNew False 0++ tabButton <- buttonNew+ widgetSetName tabButton ("leksah-close-button"::Text)+ buttonSetFocusOnClick tabButton False+ buttonSetRelief tabButton ReliefNone+ buttonSetAlignment tabButton (0.0,0.0)++ iconTheme <- iconThemeGetDefault+ mbIcon <- iconThemeLoadIcon iconTheme ("window-close"::Text) 10 IconLookupUseBuiltin+ image <- case mbIcon of+ Just i -> imageNewFromPixbuf i+ Nothing -> imageNewFromStock stockClose IconSizeMenu++ provider <- cssProviderNew+ cssProviderLoadFromString provider (+ ".button {\n" <>+ "-GtkButton-default-border : 0px;\n" <>+ "-GtkButton-default-outside-border : 0px;\n" <>+ "-GtkButton-inner-border: 0px;\n" <>+ "-GtkWidget-focus-line-width : 0px;\n" <>+ "-GtkWidget-focus-padding : 0px;\n" <>+ "padding: 0px;\n" <>+ "border-width: 0px;\n" <>+ "}\n" <>+ "GtkImage {\n" <>+ "padding: 0px;\n" <>+ "}\n" :: Text)+ context <- widgetGetStyleContext tabButton+ styleContextAddProvider context provider 600+ context <- widgetGetStyleContext image+ styleContextAddProvider context provider 600+ widgetSetVAlign tabButton AlignCenter+ widgetSetVAlign lbl AlignCenter++ containerSetBorderWidth tabButton 0+ containerAdd tabButton image++ boxPackStart innerBox lbl PackGrow 0+ boxPackStart innerBox tabButton PackNatural 5++ containerAdd labelBox innerBox+ dragSourceSet labelBox [Button1] [ActionCopy,ActionMove]+ tl <- targetListNew+ targetListAddTextTargets tl 0+ dragSourceSetTargetList labelBox tl+ on labelBox dragDataGet (\ cont id timeStamp -> do+ selectionDataSetText paneName+ return ())+ return (tabButton,labelBox)+ cl <- runInIO closeHandler+ liftIO $ on tb buttonActivated (cl ())+ liftIO $ on lb buttonReleaseEvent $ do+ modifiers <- eventModifierMouse+ let middleButton = Button2+ when (middleButton `elem` modifiers) (liftIO $ cl ())+ return False++ return lb+ 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 <- liftIO $ labelNew (Nothing::Maybe Text)+ liftIO $ labelSetUseMarkup label True+ liftIO $ labelSetMarkup label ("<b>" <> group <> "</b>")+ labelBox <- mkLabelBox label (groupPrefix <> group)+ liftIO $ widgetShowAll labelBox+ return labelBox++-- | Add the change mark or removes it+markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO ()+markLabel nb topWidget modified = do+ mbBox <- notebookGetTabLabel nb topWidget+ case mbBox of+ Nothing -> return ()+ Just box -> do+ mbContainer <- binGetChild (castToBin box)+ case mbContainer of+ Nothing -> return ()+ Just container -> do+ children <- containerGetChildren container+ let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children"+ (text :: Text) <- widgetGetName topWidget+ labelSetUseMarkup (castToLabel label) True+ labelSetMarkup (castToLabel 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 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+ l <- getLayout+ case layoutFromPath panePath l of+ (TerminalP _ _ _ (Just _) _) -> trace "ViewFrame>>viewSplit': can't split detached: " return ()+ _ -> do+ activeNotebook <- getNotebook' "viewSplit" panePath+ ind <- liftIO $ notebookGetCurrentPage activeNotebook+ mbPD <- do+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> trace "ViewFrame>>viewSplit': parent not found: " return Nothing+ Just parent -> do+ (nb,paneDir) <- do+ let (name,altname,paneDir,+ oldPath,newPath) = case dir of+ Horizontal -> ("top",+ "bottom",+ TopP,+ panePath ++ [SplitP TopP],+ panePath ++ [SplitP BottomP])+ Vertical -> ("left",+ "right",+ LeftP,+ panePath ++ [SplitP LeftP],+ panePath ++ [SplitP RightP])+ adjustNotebooks panePath oldPath+ frameState <- getFrameState+ setPanePathFromNB $ Map.insert activeNotebook oldPath (panePathFromNB frameState)+ nb <- newNotebook newPath+ (np,nbi) <- liftIO $ do+ newpane <- case dir of+ Horizontal -> do h <- vPanedNew+ return (castToPaned h)+ Vertical -> do v <- hPanedNew+ return (castToPaned v)+ rName::Text <- widgetGetName activeNotebook+ widgetSetName newpane rName+ widgetSetName nb (altname :: Text)+ panedPack2 newpane nb True False+ nbIndex <- if parent `isA` gTypeNotebook+ then notebookPageNum (castToNotebook' "viewSplit'1" parent) activeNotebook+ else trace "ViewFrame>>viewSplit': parent not a notebook: " return Nothing+ containerRemove (castToContainer parent) activeNotebook+ widgetSetName activeNotebook (name :: Text)+ panedPack1 newpane activeNotebook True False+ return (newpane,nbIndex)+ case (reverse panePath, nbi) of+ (SplitP dir:_, _) -> liftIO $ do+ if dir `elem` [TopP, LeftP]+ then panedPack1 (castToPaned parent) np True False+ else panedPack2 (castToPaned parent) np True False+ (GroupP group:_, Just n) -> do+ liftIO $ notebookInsertPage (castToNotebook' "viewSplit' 2" parent) np group n+ label <- groupLabel group+ liftIO $ notebookSetTabLabel (castToNotebook' "viewSplit' 3" parent) np label+ label2 <- groupMenuLabel group+ liftIO $ notebookSetMenuLabel (castToNotebook' "viewSplit' 4" parent) np label2+ return ()+ ([], _) -> do+ liftIO $ boxPackStart (castToBox parent) np PackGrow 0+ liftIO $ boxReorderChild (castToVBox parent) np 2+ _ -> error "No notebook index found in viewSplit"+ liftIO $ do+ widgetShowAll np+ widgetGrabFocus activeNotebook+ case nbi of+ Just n -> do+ notebookSetCurrentPage (castToNotebook' "viewSplit' 5" parent) n+ return ()+ _ -> trace "ViewFrame>>viewSplit': parent not a notebook2: "return ()+ return (nb,paneDir)+ handleFunc <- runInIO (handleNotebookSwitch nb)+ liftIO $ after nb switchPage handleFunc+ return (Just (paneDir,dir))+ case mbPD of+ Just (paneDir,pdir) -> do+ adjustPanes panePath (panePath ++ [SplitP paneDir])+ adjustLayoutForSplit paneDir panePath+ mbWidget <- liftIO $ notebookGetNthPage activeNotebook ind+ when (isJust mbWidget) $ do+ name <- liftIO $ widgetGetName (fromJust mbWidget)+ mbPane <- mbPaneFromName name+ case mbPane of+ Just (PaneC pane) -> viewMoveTo (panePath ++ [SplitP (otherDirection paneDir)]) pane+ Nothing -> return ()+ 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 castToWidget+ let nb = if nbop `isA` gTypeNotebook+ then Just (castToNotebook' "viewCollapse' 0" nbop)+ else Nothing+ 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+ otherwise -> 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+ let ! newMap = Map.delete otherSideNotebook (panePathFromNB st)+ setPanePathFromNB newMap+ -- 3. Remove one level and reparent notebook+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> error "collapse: no parent"+ Just parent -> do+ mbGrandparent <- liftIO $ widgetGetParent parent+ case mbGrandparent of+ Nothing -> error "collapse: no grandparent"+ Just grandparent -> do+ nbIndex <- if grandparent `isA` gTypeNotebook+ then liftIO $ notebookPageNum (castToNotebook' "viewCollapse'' 1" grandparent) parent+ else return Nothing+ liftIO $ containerRemove (castToContainer grandparent) parent+ liftIO $ containerRemove (castToContainer parent) activeNotebook+ if length panePath > 1+ then do+ let lasPathElem = last newPanePath+ case (lasPathElem, nbIndex) of+ (SplitP dir, _) | dir == TopP || dir == LeftP ->+ liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True False+ (SplitP dir, _) | dir == BottomP || dir == RightP ->+ liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True False+ (GroupP group, Just n) -> do+ liftIO $ notebookInsertPage (castToNotebook' "viewCollapse'' 2" grandparent) activeNotebook group n+ label <- groupLabel group+ liftIO $ do+ notebookSetTabLabel (castToNotebook' "viewCollapse'' 3" grandparent) activeNotebook label+ notebookSetCurrentPage (castToNotebook' "viewCollapse'' 4" grandparent) n+ return ()+ _ -> error "collapse: Unable to find page index"+ liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem+ else liftIO $ do+ boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0+ boxReorderChild (castToVBox grandparent) activeNotebook 2+ widgetSetName activeNotebook ("root" :: Text)+ -- 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 <- liftIO $ groupNameDialog mainWindow+ case+ mbGroupName of+ Just groupName -> do+ layout <- getLayoutSt+ if groupName `Set.member` allGroupNames layout+ then liftIO $ do+ md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose+ ("Group name not unique " <> groupName)+ 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 castToWidget+ liftIO $ setCurrentNotebookPages widget+ return (Just path)+ Nothing -> return Nothing+++-- Yet another stupid little dialog++groupNameDialog :: Window -> IO (Maybe Text)+groupNameDialog parent = liftIO $ do+ dia <- dialogNew+ set dia [ windowTransientFor := parent+ , windowTitle := ("Enter group name" :: Text) ]+ upper <- castToVBox <$> dialogGetContentArea dia+ lower <- castToHBox <$> dialogGetActionArea dia+ (widget,inj,ext,_) <- buildEditor moduleFields ""+ (widget2,_,_,notifier) <- buildEditor okCancelFields ()+ registerEvent notifier ButtonPressed (\e -> do+ case eventText e of+ "Ok" -> dialogResponse dia ResponseOk+ _ -> dialogResponse dia ResponseCancel+ return e)+ boxPackStart upper widget PackGrow 7+ boxPackStart lower widget2 PackNatural 7+ widgetShowAll dia+ resp <- dialogRun dia+ value <- ext ""+ widgetDestroy dia+ case resp of+ ResponseOk | value /= Just "" -> return value+ _ -> return Nothing+ where+ moduleFields :: FieldDescription Text+ moduleFields = VFD emptyParams [+ mkField+ (paraName <<<- ParaName "New group "+ $ 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+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> return ()+ Just parent -> do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath panePath layout+ case paneLayout of+ (TerminalP {}) -> do+ nb <- newNotebook (panePath ++ [GroupP group])+ liftIO $ widgetSetName nb (groupPrefix <> group)+ notebookInsertOrdered activeNotebook nb group Nothing True+ liftIO $ widgetShowAll nb+ --widgetGrabFocus activeNotebook+ handleFunc <- runInIO (handleNotebookSwitch nb)+ liftIO $ after nb switchPage handleFunc+ 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: " <> 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+ (_:_) -> liftIO $ do+ md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo+ ("Group " <> groupName <> " not empty. Close with all contents?")+ rid <- dialogRun md+ widgetDestroy md+ case rid of+ ResponseYes -> 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 castToWidget+ mbParent <- liftIO $ widgetGetParent nbOrPaned+ case mbParent of+ Nothing -> error "ViewFrame>>closeGroup: closeGroup: no parent"+ Just parent -> liftIO $ containerRemove (castToContainer parent) nbOrPaned+ setLayoutSt (removeGL path layout)+ ppMap <- getPanePathFromNB+ setPanePathFromNB (Map.filter (\pa -> not (path `isPrefixOf` pa)) ppMap)++viewDetach :: PaneMonad alpha => alpha (Maybe (Window,Widget))+viewDetach = do+ id <- liftIO $ fmap 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,Widget))+viewDetach' panePath id = do+ activeNotebook <- getNotebook' "viewDetach'" panePath+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> return Nothing+ Just parent -> do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath panePath layout+ case paneLayout of+ (TerminalP{detachedSize = size}) -> do+ window <- liftIO $ do+ window <- windowNew+ set window [ windowTitle := ("Leksah detached window" :: Text)+ , widgetName := Just id ]+ case size of+ Just (width, height) -> windowSetDefaultSize window width height+ Nothing -> do+ (Rectangle _ _ curWidth curHeight) <- widgetGetAllocation activeNotebook+ windowSetDefaultSize window curWidth curHeight+ containerRemove (castToContainer parent) activeNotebook+ containerAdd window activeNotebook+ widgetShowAll window+ return window+ handleFunc <- runInIO (handleReattach id window)+ liftIO . on window deleteEvent . liftIO $ handleFunc ()+ windows <- getWindowsSt+ setWindowsSt $ windows ++ [window]+ adjustLayoutForDetach id panePath+ return (Just (window, castToWidget 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: " <> windowId)+ $ do+ windows <- getWindowsSt+ setWindowsSt $ delete window windows+ return False+ Just pp -> do+ nb <- getNotebook' "handleReattach" pp+ parent <- getNotebookOrPaned (init pp) castToContainer+ liftIO $ containerRemove (castToContainer window) nb+ liftIO $ containerAdd parent nb+ adjustLayoutForReattach pp+ windows <- getWindowsSt+ setWindowsSt $ delete window windows+ case last pp of+ GroupP groupName -> do+ label <- groupLabel groupName+ liftIO $ notebookSetTabLabel (castToNotebook' "handleReattach" parent) nb 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+ top <- liftIO $ widgetGetToplevel activeNotebook+ if top `isA` gTypeWindow+ then return . Just $ castToWindow top+ else return Nothing++getActiveScreen :: PaneMonad alpha => alpha (Maybe Screen)+getActiveScreen = do+ mbWindow <- getActiveWindow+ case mbWindow of+ Nothing -> return Nothing+ Just window -> liftIO $ Just <$> windowGetScreen window++groupMenuLabel :: PaneMonad beta => Text -> beta (Maybe Label)+groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group))++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+ name <- liftIO $ 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 <- liftIO $ 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: " <> group) return ()+ Just fromPath -> do+ groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget+ fromNB <- getNotebook' "move'" (init fromPath)+ case toNB `Map.lookup` panePathFromNB frameState of+ Nothing -> trace "ViewFrame>>move': panepath for Notebook not found1" return ()+ Just toPath ->+ when (fromNB /= toNB && not (fromPath `isPrefixOf` toPath)) $ do+ mbNum <- liftIO $ notebookPageNum fromNB groupNBOrPaned+ case mbNum of+ Nothing -> trace "ViewFrame>>move': group notebook not found" return ()+ Just num -> do+ liftIO $ notebookRemovePage fromNB num+ label <- groupLabel group+ notebookInsertOrdered toNB groupNBOrPaned group Nothing True+ liftIO $ notebookSetTabLabel toNB groupNBOrPaned 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: " <> paneName) return ()+ Just (PaneC pane) ->+ case toNB `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: " <> paneName)+ return ()+ Just (fromPath,_) -> do+ let child = getTopWidget pane+ (fromPane,cid) <- guiPropertiesFromName paneName+ fromNB <- getNotebook' "move'" fromPane+ when (fromNB /= toNB) $ do+ mbNum <- liftIO $ notebookPageNum fromNB child+ case mbNum of+ Nothing -> trace "ViewFrame>>move': widget not found" return ()+ Just num -> do+ liftIO $ notebookRemovePage fromNB num+ notebookInsertOrdered toNB child paneName Nothing 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 -> IO ()+bringPaneToFront pane = do+ let tv = getTopWidget pane+ w <- widgetGetToplevel tv+ visible <- w `get` widgetVisible+ when visible . windowPresent $ castToWindow w+ setCurrentNotebookPages tv+++setCurrentNotebookPages widget = do+ mbParent <- widgetGetParent widget+ case mbParent of+ Just parent -> do+ setCurrentNotebookPages parent+ when (parent `isA` gTypeNotebook) $ do+ mbPageNum <- notebookPageNum+ (castToNotebook' "setCurrentNotebookPage 1" parent)+ widget+ case mbPageNum of+ Just pageNum -> do+ notebookSetCurrentPage+ (castToNotebook' "setCurrentNotebookPage 2" parent)+ pageNum+ return ()+ 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 PosTop+ notebookSetShowTabs nb True+ notebookSetScrollable nb True+ notebookSetPopup nb True+ return nb++--+-- | Construct a new notebook,+--+newNotebook :: PaneMonad alpha => PanePath -> alpha Notebook+newNotebook pp = do+ st <- getFrameState+ nb <- liftIO newNotebook'+ setPanePathFromNB $ Map.insert nb pp (panePathFromNB st)+ func <- runInIO move'+ liftIO $ do+ tl <- targetListNew+ targetListAddTextTargets tl 0+ dragDestSet nb [DestDefaultAll] [ActionCopy, ActionMove]+ dragDestSetTargetList nb tl+ on nb dragDataReceived (dragFunc nb func)+ return nb+ where+ dragFunc ::+ Notebook ->+ ((PaneName,Notebook) -> IO ()) ->+ DragContext ->+ Point ->+ InfoId ->+ TimeStamp ->+ SelectionDataM ()+ dragFunc nb func cont point id timeStamp = do+ mbText <- selectionDataGetText+ case mbText of+ Nothing -> return ()+ Just str -> do+ Gtk.liftIO $ func (str,nb)+ return ()++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 -> 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 (castToNotebook' ("getNotebook " <> T.pack (show p)))++getNotebook' :: PaneMonad alpha => Text -> PanePath -> alpha Notebook+getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " <> str <> " " <> T.pack (show p)))+++--+-- | 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 (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: " <> T.pack (show fromPane) <> " to " <> T.pack (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 :: Widget -> [Text] -> IO Widget+widgetFromPath w [] = return w+widgetFromPath w path = do+ children <- containerGetChildren (castToContainer w)+ chooseWidgetFromPath children path++chooseWidgetFromPath :: [Widget] -> [Text] -> IO 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 -> b) -> alpha b+widgetGet strL cf = do+ windows <- getWindowsSt+ r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL+ return (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 -> 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 " ++ 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 " <> T.pack (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++castToNotebook' :: GObjectClass obj => Text -> obj -> Notebook+castToNotebook' str obj = if obj `isA` gTypeNotebook+ then castToNotebook obj+ else error . T.unpack $ "Not a notebook " <> str+