diff --git a/ltk.cabal b/ltk.cabal --- a/ltk.cabal +++ b/ltk.cabal @@ -1,5 +1,5 @@ name: ltk -version: 0.14.0.0 +version: 0.14.0.1 cabal-version: >= 1.8 build-type: Simple license: GPL @@ -24,18 +24,18 @@ default: True Library - build-depends: Cabal >=1.6.0 && <1.19, base >=4.0.0.0 && <4.8, + build-depends: Cabal >=1.6.0 && <1.21, base >=4.0.0.0 && <4.8, containers >=0.2 && <0.6, filepath >=1.1.0 && <1.4, - glib >=0.13.0.0 && <0.14, text >=0.11.0.6 && <1.2, - mtl >=1.1.0.2 && <2.2, parsec >=2.1.0.1 && <3.2, - pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.4, + glib >=0.13.0.0 && <0.14, text >=0.11.0.6 && <1.3, + mtl >=1.1.0.2 && <2.3, parsec >=2.1.0.1 && <3.2, + pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.5, ghc -any if flag(gtk3) - build-depends: gtk3 >=0.13.0.0 && <0.14 + build-depends: gtk3 >=0.13.1 && <0.14 cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 else - build-depends: gtk >=0.13.0.0 && <0.14 + build-depends: gtk >=0.13.1 && <0.14 exposed-modules: Default MyMissing Control.Event Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite @@ -45,5 +45,4 @@ Text.PrinterParser exposed: True buildable: True - extensions: CPP, FlexibleInstances, BangPatterns hs-source-dirs: src diff --git a/src/Control/Event.hs b/src/Control/Event.hs --- a/src/Control/Event.hs +++ b/src/Control/Event.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} ----------------------------------------------------------------------------- -- -- Module : Control.Event @@ -46,7 +46,7 @@ | alpha -> beta, alpha -> gamma where getHandlers :: alpha -> gamma (Handlers beta gamma delta) setHandlers :: alpha -> Handlers beta gamma delta -> gamma () - myUnique :: alpha -> gamma (Unique) + myUnique :: alpha -> gamma Unique -- | Reimplement this in instances to make triggering of events possible canTriggerEvent :: alpha -> delta -> Bool diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs --- a/src/Graphics/UI/Editor/Basics.hs +++ b/src/Graphics/UI/Editor/Basics.hs @@ -55,7 +55,7 @@ import Control.Event import Data.Map (Map(..)) import qualified Data.Map as Map (delete,insert,lookup,empty) -import Data.Maybe (isJust,fromJust) +import Data.Maybe (fromMaybe, isJust, fromJust) import Unsafe.Coerce (unsafeCoerce) import Control.Arrow (first) import MyMissing (allOf) @@ -139,7 +139,7 @@ -- -- | A type for a function to register a gtk event -- | -type GtkRegFunc = forall o . GObjectClass o => o -> GtkHandler -> IO (Connection) +type GtkRegFunc = forall o . GObjectClass o => o -> GtkHandler -> IO Connection -- -- | The widgets are the real event sources. @@ -277,24 +277,21 @@ -> GUIEventSelector -> IO () activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do - let registerFunc = case mbRegisterFunc of - Just f -> f - Nothing -> getStandardRegFunction eventSel + let registerFunc = fromMaybe (getStandardRegFunction eventSel) mbRegisterFunc cid <- registerFunc widget (do (hi,_) <- readIORef pairRef case Map.lookup eventSel hi of Nothing -> return False Just [] -> return False Just handlers -> do - name <- if (widget `isA` gTypeWidget) + name <- if widget `isA` gTypeWidget then widgetGetName (castToWidget widget) else return "no widget - no name" :: IO Text - eventList <- mapM (\f -> do + eventList <- mapM ((\f -> do let ev = GUIEvent eventSel "" False - f ev) - (map snd handlers) + f ev) . snd) handlers let boolList = map gtkReturn eventList - return (foldr (&&) True boolList)) + return (and boolList)) (handerls,ger) <- readIORef pairRef let newGer = case Map.lookup eventSel ger of Nothing -> Map.insert eventSel ([cid],([],Map.empty)) @@ -311,7 +308,7 @@ getStandardRegFunction FocusIn = \w h -> liftM ConnectC $ on (castToWidget w) focusInEvent $ liftIO h getStandardRegFunction ButtonPressed = \w h -> liftM ConnectC $ after (castToWidget w) buttonReleaseEvent $ liftIO h getStandardRegFunction KeyPressed = \w h -> liftM ConnectC $ after (castToWidget w) keyReleaseEvent $ liftIO h -getStandardRegFunction Clicked = \w h -> liftM ConnectC $ on (castToButton w) buttonActivated $ liftIO h >> return () +getStandardRegFunction Clicked = \w h -> liftM ConnectC $ on (castToButton w) buttonActivated $ void $ liftIO h getStandardRegFunction _ = error "Basic>>getStandardRegFunction: no original GUI event" registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Maybe Unique] @@ -321,6 +318,6 @@ propagateAsChanged :: (EventSource alpha GUIEvent m GUIEventSelector) => alpha -> [GUIEventSelector] -> m () -propagateAsChanged notifier selectors = +propagateAsChanged notifier = mapM_ (\s -> registerEvent notifier s - (\ e -> triggerEvent notifier e{selector = MayHaveChanged})) selectors + (\ e -> triggerEvent notifier e{selector = MayHaveChanged})) diff --git a/src/Graphics/UI/Editor/DescriptionPP.hs b/src/Graphics/UI/Editor/DescriptionPP.hs --- a/src/Graphics/UI/Editor/DescriptionPP.hs +++ b/src/Graphics/UI/Editor/DescriptionPP.hs @@ -34,6 +34,8 @@ import qualified Data.Text as T (unpack) import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Maybe (fromMaybe) +import qualified Control.Arrow as A (Arrow(..)) data FieldDescriptionPP alpha gamma = FDPP { parameters :: Parameters @@ -47,12 +49,12 @@ type MkFieldDescriptionPP alpha beta gamma = Parameters -> - (Printer beta) -> - (Parser beta) -> - (Getter alpha beta) -> - (Setter alpha beta) -> - (Editor beta) -> - (Applicator beta gamma ) -> + Printer beta -> + Parser beta -> + Getter alpha beta -> + Setter alpha beta -> + Editor beta -> + Applicator beta gamma -> FieldDescriptionPP alpha gamma mkFieldPP :: (Eq beta, Monad gamma) => MkFieldDescriptionPP alpha beta gamma @@ -62,14 +64,12 @@ (\ dat -> (PP.text (case getParameterPrim paraName parameters of Nothing -> "" Just str -> T.unpack str) PP.<> PP.colon) - PP.$$ (PP.nest 15 (printer (getter dat))) - PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameters of + PP.$$ PP.nest 15 (printer (getter dat)) + PP.$$ PP.nest 5 (case getParameterPrim paraSynopsis parameters of Nothing -> PP.empty - Just str -> PP.text . T.unpack $ "--" <> str))) + Just str -> PP.text . T.unpack $ "--" <> str)) (\ dat -> P.try (do - symbol (case getParameterPrim paraName parameters of - Nothing -> "" - Just str -> str) + symbol (fromMaybe "" (getParameterPrim paraName parameters)) colon val <- parser return (setter val dat))) @@ -77,17 +77,14 @@ (\ newDat oldDat -> do --applicator let newField = getter newDat let oldField = getter oldDat - if newField == oldField - then return () - else applicator newField) + unless (newField == oldField) $ applicator newField) extractFieldDescription :: FieldDescriptionPP alpha gamma -> FieldDescription alpha extractFieldDescription (VFDPP paras descrs) = VFD paras (map extractFieldDescription descrs) extractFieldDescription (HFDPP paras descrs) = HFD paras (map extractFieldDescription descrs) -extractFieldDescription (NFDPP descrsp) = NFD (map (\(s,d) -> - (s, extractFieldDescription d)) descrsp) +extractFieldDescription (NFDPP descrsp) = NFD (map (A.second extractFieldDescription) descrsp) extractFieldDescription (FDPP parameters fieldPrinter fieldParser fieldEditor applicator) = - (FD parameters fieldEditor) + FD parameters fieldEditor flattenFieldDescriptionPP :: FieldDescriptionPP alpha gamma -> [FieldDescriptionPP alpha gamma] flattenFieldDescriptionPP (VFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs --- a/src/Graphics/UI/Editor/MakeEditor.hs +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -39,7 +39,7 @@ import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics --import Graphics.UI.Frame.ViewFrame -import Data.Maybe (isNothing) +import Data.Maybe (fromMaybe, isNothing) import Data.IORef (newIORef) import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..)) @@ -48,9 +48,9 @@ -- type MkFieldDescription alpha beta = Parameters -> - (Getter alpha beta) -> - (Setter alpha beta) -> - (Editor beta) -> + Getter alpha beta -> + Setter alpha beta -> + Editor beta -> FieldDescription alpha -- @@ -87,7 +87,7 @@ buildEditor (NFD pairList) v = do nb <- newNotebook notebookSetShowTabs nb False - resList <- mapM (\d -> buildEditor d v) (map snd pairList) + resList <- mapM ((`buildEditor` v) . snd) pairList let (widgets, setInjs, getExts, notifiers) = unzip4 resList notifier <- emptyNotifier mapM_ (\ (labelString, widget) -> do @@ -122,15 +122,15 @@ scrolledWindowSetPolicy sw PolicyNever PolicyAutomatic boxPackStart hb sw PackNatural 0 boxPackEnd hb nb PackGrow 7 - let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) - let newExt = (\v -> extract v getExts) + let newInj v = mapM_ (\ setInj -> setInj v) setInjs + let newExt v = extract v getExts mapM_ (propagateEvent notifier notifiers) allGUIEvents return (castToWidget hb, newInj, newExt, notifier) buildBoxEditor :: [FieldDescription alpha] -> Direction -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) buildBoxEditor descrs dir v = do - resList <- mapM (\d -> buildEditor d v) descrs + resList <- mapM (`buildEditor` v) descrs notifier <- emptyNotifier let (widgets, setInjs, getExts, notifiers) = unzip4 resList hb <- case dir of @@ -140,13 +140,11 @@ Vertical -> do b <- vBoxNew False 0 return (castToBox b) - let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") descrs - let packParas = map (\fd -> getParameter paraPack (parameters fd)) descrs + let newInj v = mapM_ (\ setInj -> setInj v) setInjs + let fieldNames = map (fromMaybe "Unnamed" . getParameterPrim paraName . parameters) descrs + let packParas = map (getParameter paraPack . parameters) descrs mapM_ (propagateEvent notifier notifiers) allGUIEvents - let newExt = (\v -> extractAndValidate v getExts fieldNames notifier) + let newExt v = extractAndValidate v getExts fieldNames notifier mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas return (castToWidget hb, newInj, newExt, notifier) @@ -170,14 +168,14 @@ (\ dat -> do noti <- emptyNotifier (widget,inj,ext) <- editor parameters noti - let pext = (\a -> do + let pext a = do b <- ext case b of Just b -> return (Just (setter b a)) - Nothing -> return Nothing) + Nothing -> return Nothing inj (getter dat) return (widget, - (\a -> inj (getter a)), + inj . getter, pext, noti)) @@ -193,9 +191,8 @@ frameSetShadowType frame (getParameter paraShadow parameters) case getParameter paraName parameters of "" -> return () - str -> if getParameter paraShowLabel parameters - then frameSetLabel frame str - else return () + str -> when (getParameter paraShowLabel parameters) $ + frameSetLabel frame str containerAdd outerAlig frame let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters @@ -223,10 +220,10 @@ if null errors then return (Just newVal) else do - triggerEvent notifier (GUIEvent { + triggerEvent notifier GUIEvent { selector = ValidationError, eventText = mconcat (intersperse ", " errors), - gtkReturn = True}) + gtkReturn = True} return Nothing extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) diff --git a/src/Graphics/UI/Editor/Parameters.hs b/src/Graphics/UI/Editor/Parameters.hs --- a/src/Graphics/UI/Editor/Parameters.hs +++ b/src/Graphics/UI/Editor/Parameters.hs @@ -90,66 +90,66 @@ emptyParams :: [Parameter] emptyParams = [] -paraName :: (Parameter -> (Maybe Text)) +paraName :: Parameter -> Maybe Text paraName (ParaName str) = Just str paraName _ = Nothing -paraSynopsis :: (Parameter -> (Maybe Text)) +paraSynopsis :: Parameter -> Maybe Text paraSynopsis (ParaSynopsis str) = Just str paraSynopsis _ = Nothing -paraShowLabel :: (Parameter -> (Maybe Bool)) +paraShowLabel :: Parameter -> Maybe Bool paraShowLabel (ParaShowLabel b) = Just b paraShowLabel _ = Nothing -paraDirection :: (Parameter -> (Maybe Direction)) +paraDirection :: Parameter -> Maybe Direction paraDirection (ParaDirection d) = Just d paraDirection _ = Nothing -paraShadow :: (Parameter -> (Maybe ShadowType)) +paraShadow :: Parameter -> Maybe ShadowType paraShadow (ParaShadow d) = Just d paraShadow _ = Nothing -paraOuterAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) +paraOuterAlignment :: Parameter -> Maybe (Float,Float,Float,Float) paraOuterAlignment (ParaOuterAlignment d) = Just d paraOuterAlignment _ = Nothing -paraInnerAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) +paraInnerAlignment :: Parameter -> Maybe (Float,Float,Float,Float) paraInnerAlignment (ParaInnerAlignment d) = Just d paraInnerAlignment _ = Nothing -paraOuterPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) +paraOuterPadding :: Parameter -> Maybe (Int,Int,Int,Int) paraOuterPadding (ParaOuterPadding d) = Just d paraOuterPadding _ = Nothing -paraInnerPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) +paraInnerPadding :: Parameter -> Maybe (Int,Int,Int,Int) paraInnerPadding (ParaInnerPadding d) = Just d paraInnerPadding _ = Nothing -paraMinSize :: (Parameter -> (Maybe (Int, Int))) +paraMinSize :: Parameter -> Maybe (Int, Int) paraMinSize (ParaMinSize d) = Just d paraMinSize _ = Nothing -paraHorizontal :: (Parameter -> (Maybe (HorizontalAlign))) +paraHorizontal :: Parameter -> Maybe HorizontalAlign paraHorizontal (ParaHorizontal d) = Just d paraHorizontal _ = Nothing -paraStockId :: (Parameter -> (Maybe Text)) +paraStockId :: Parameter -> Maybe Text paraStockId (ParaStockId str) = Just str paraStockId _ = Nothing -paraMultiSel :: (Parameter -> (Maybe Bool)) +paraMultiSel :: Parameter -> Maybe Bool paraMultiSel (ParaMultiSel b) = Just b paraMultiSel _ = Nothing -paraPack :: (Parameter -> (Maybe Packing)) +paraPack :: Parameter -> Maybe Packing paraPack (ParaPack b) = Just b paraPack _ = Nothing -- -- | Convenience method to get a parameter, or if not set the default parameter -- -getParameter :: (Parameter -> (Maybe beta)) -> Parameters -> beta +getParameter :: (Parameter -> Maybe beta) -> Parameters -> beta getParameter selector parameter = case getParameterPrim selector parameter of Just ele -> ele @@ -157,13 +157,13 @@ Just ele -> ele _ -> error "default parameter not defined" -getParameterPrim :: (Parameter -> (Maybe beta)) -> Parameters -> Maybe beta +getParameterPrim :: (Parameter -> Maybe beta) -> Parameters -> Maybe beta getParameterPrim selector parameter = case filter isJust $ map selector parameter of - (Just ele) : _ -> Just ele - _ -> Nothing + Just ele : _ -> Just ele + _ -> Nothing -(<<<-) :: (Parameter -> (Maybe beta)) -> Parameter -> Parameters -> Parameters +(<<<-) :: (Parameter -> Maybe beta) -> Parameter -> Parameters -> Parameters (<<<-) selector para params = para : filter (isNothing . selector) params defaultParameters :: Parameters diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs --- a/src/Graphics/UI/Editor/Simple.hs +++ b/src/Graphics/UI/Editor/Simple.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs --- a/src/Graphics/UI/Frame/Panes.hs +++ b/src/Graphics/UI/Frame/Panes.hs @@ -188,7 +188,7 @@ windows :: [Window] , uiManager :: UIManager , panes :: Map PaneName (IDEPane delta) -, paneMap :: (Map PaneName (PanePath, Connections)) +, paneMap :: Map PaneName (PanePath, Connections) , activePane :: Maybe (PaneName, Connections) , panePathFromNB :: ! (Map Notebook PanePath) , layout :: PaneLayout} diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs --- a/src/Graphics/UI/Frame/ViewFrame.hs +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -1,1450 +1,1495 @@ -{-# LANGUAGE CPP #-} -{-# 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 : --- 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 -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(..)) -#ifdef MIN_VERSION_gtk3 -import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString) -import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider) -#endif -import MyMissing (forceJust, forceHead) -import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) -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 Debug.Trace (trace) -trace (a::Text) b = b - -groupPrefix = "_group_" - -withoutGroupPrefix :: Text -> Text -withoutGroupPrefix s = case groupPrefix `T.stripPrefix` s of - Nothing -> s - Just s' -> s' - - -initGtkRc :: IO () -#ifdef MIN_VERSION_gtk3 -initGtkRc = return () -#else -initGtkRc = rcParseString ("style \"leksah-close-button-style\"\n" ++ - "{\n" ++ - " GtkButton::default-border = 0\n" ++ - " GtkButton::default-outside-border = 0\n" ++ - " GtkButton::inner-border = 0\n" ++ - " GtkWidget::focus-padding = 0\n" ++ - " GtkWidget::focus-line-width = 0\n" ++ - " xthickness = 0\n" ++ - " ythickness = 0\n" ++ - " padding = 0\n" ++ - "}\n" ++ - "widget \"*.leksah-close-button\" style \"leksah-close-button-style\"") -#endif - -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 do - 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 (catMaybes - $ map (\(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 (\v -> forceJust v "ViewFrame.notebookInsertOrdered: no widget") mbWidgets - labelStrs <- liftIO $ mapM widgetGetName widgets - let pos = case findIndex (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr) labelStrs of - Just i -> i - Nothing -> -1 - 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 - -#ifdef MIN_VERSION_gtk3 - 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: 2px;\n" <> - "}" :: Text) - context <- widgetGetStyleContext tabButton - styleContextAddProvider context provider 600 -#endif - containerSetBorderWidth tabButton 0 - containerAdd tabButton image - - boxPackStart innerBox tabButton PackNatural 0 - boxPackStart innerBox lbl PackGrow 0 - - 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 ()) - - return lb - where - closeHandler :: PaneMonad alpha => () -> alpha () - closeHandler _ = case groupPrefix `T.stripPrefix` paneName of - Just group -> do - 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 ("" <> group <> "") - 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 (tail children) "ViewFrame>>markLabel: empty children" - (text :: Text) <- widgetGetName topWidget - labelSetUseMarkup (castToLabel label) True - labelSetMarkup (castToLabel label) - (if modified - then "" <> text <> "" - 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 -> do - 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 - case mbPanePath of - Nothing -> return () - Just panePath -> do - viewCollapse' panePath - -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) ] -#ifdef MIN_VERSION_gtk3 - upper <- castToVBox <$> dialogGetContentArea dia -#else - upper <- castToVBox <$> dialogGetUpper dia -#endif - 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 - (\ a b -> a) - (textEditor (const True) True)] - -viewNest :: PaneMonad alpha => Text -> alpha () -viewNest group = do - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return () - Just panePath -> do - 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 (\(a,b) -> (a,fst b)) (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 $ map fst nameAndpathList - results <- mapM (\ (PaneC p) -> closePane p) panes - when (foldr (&&) True 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 -> do - 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) -> do - 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 -> do - return () - Just (paneName,_) -> do - (PaneC pane) <- paneFromName paneName - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> do - return () - Just panePath -> do - layout <- getLayoutSt - case findMoveTarget panePath layout direction of - Nothing -> do - return () - Just moveTo -> move moveTo pane - --- --- | Find the target for a move --- -findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath -findMoveTarget panePath layout direction= - let 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 -> do - 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 -> do - when (fromNB /= toNB && not (isPrefixOf fromPath 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) -> do - 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 - if parent `isA` gTypeNotebook - then do - mbPageNum <- notebookPageNum ((castToNotebook' "setCurrentNotebookPage 1") parent) widget - case mbPageNum of - Just pageNum -> do - notebookSetCurrentPage ((castToNotebook' "setCurrentNotebookPage 2") parent) pageNum - return () - Nothing -> return () - else 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 (\ (pp,l) -> (reverse pp,l)) $ 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 p group = adjust' p group - --- --- | 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 = findIndex (== 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 CPP #-} +{-# 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 : +-- 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(..)) +#ifdef MIN_VERSION_gtk3 +import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString) +import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider) +import Graphics.UI.Gtk.General.Enums (Align(..)) +#else +import Graphics.UI.Gtk (rcParseString) +#endif +import MyMissing (forceJust, forceHead) +import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) +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 Debug.Trace (trace) +trace (a::Text) b = b + +groupPrefix = "_group_" + +withoutGroupPrefix :: Text -> Text +withoutGroupPrefix s = case groupPrefix `T.stripPrefix` s of + Nothing -> s + Just s' -> s' + + +initGtkRc :: IO () +#ifdef MIN_VERSION_gtk3 +initGtkRc = return () +#else +initGtkRc = rcParseString ("style \"leksah-close-button-style\"\n" ++ + "{\n" ++ + " GtkButton::default-border = 0\n" ++ + " GtkButton::default-outside-border = 0\n" ++ + " GtkButton::inner-border = 0\n" ++ + " GtkWidget::focus-padding = 0\n" ++ + " GtkWidget::focus-line-width = 0\n" ++ + " xthickness = 0\n" ++ + " ythickness = 0\n" ++ + " padding = 0\n" ++ + "}\n" ++ + "widget \"*.leksah-close-button\" style \"leksah-close-button-style\"") +#endif + +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 do + 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 (catMaybes + $ map (\(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 (\v -> forceJust v "ViewFrame.notebookInsertOrdered: no widget") mbWidgets + labelStrs <- liftIO $ mapM widgetGetName widgets + let pos = case findIndex (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr) labelStrs of + Just i -> i + Nothing -> -1 + 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 + +#ifdef MIN_VERSION_gtk3 + 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 AlignBaseline +#endif + containerSetBorderWidth tabButton 0 + containerAdd tabButton image + + boxPackStart innerBox tabButton PackNatural 0 + boxPackStart innerBox lbl PackGrow 0 + + 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 ()) + + return lb + where + closeHandler :: PaneMonad alpha => () -> alpha () + closeHandler _ = case groupPrefix `T.stripPrefix` paneName of + Just group -> do + 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 ("" <> group <> "") + 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 (tail children) "ViewFrame>>markLabel: empty children" + (text :: Text) <- widgetGetName topWidget + labelSetUseMarkup (castToLabel label) True + labelSetMarkup (castToLabel label) + (if modified + then "" <> text <> "" + 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 -> do + 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 + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewCollapse' panePath + +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) ] +#ifdef MIN_VERSION_gtk3 + upper <- castToVBox <$> dialogGetContentArea dia +#else + upper <- castToVBox <$> dialogGetUpper dia +#endif + 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 + (\ a b -> a) + (textEditor (const True) True)] + +viewNest :: PaneMonad alpha => Text -> alpha () +viewNest group = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + 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 (\(a,b) -> (a,fst b)) (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 $ map fst nameAndpathList + results <- mapM (\ (PaneC p) -> closePane p) panes + when (foldr (&&) True 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 -> do + 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) -> do + 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 -> do + return () + Just (paneName,_) -> do + (PaneC pane) <- paneFromName paneName + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> do + return () + Just panePath -> do + layout <- getLayoutSt + case findMoveTarget panePath layout direction of + Nothing -> do + return () + Just moveTo -> move moveTo pane + +-- +-- | Find the target for a move +-- +findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath +findMoveTarget panePath layout direction= + let 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 -> do + 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 -> do + when (fromNB /= toNB && not (isPrefixOf fromPath 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) -> do + 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 + if parent `isA` gTypeNotebook + then do + mbPageNum <- notebookPageNum ((castToNotebook' "setCurrentNotebookPage 1") parent) widget + case mbPageNum of + Just pageNum -> do + notebookSetCurrentPage ((castToNotebook' "setCurrentNotebookPage 2") parent) pageNum + return () + Nothing -> return () + else 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 (\ (pp,l) -> (reverse pp,l)) $ 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 p group = adjust' p group + +-- +-- | 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 = findIndex (== 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 + diff --git a/src/MyMissing.hs b/src/MyMissing.hs --- a/src/MyMissing.hs +++ b/src/MyMissing.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : MyMissing @@ -24,11 +24,11 @@ import Data.Text (Text) import qualified Data.Text as T (unpack) import Data.List (find,unfoldr) -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Char (isSpace) nonEmptyLines :: String -> [String] -nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines +nonEmptyLines = filter (isJust . find (not . isSpace)) . lines allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] @@ -38,9 +38,7 @@ -- Convenience methods with error handling -- forceJust :: Maybe alpha -> Text -> alpha -forceJust mb str = case mb of - Nothing -> error (T.unpack str) - Just it -> it +forceJust mb str = fromMaybe (error (T.unpack str)) mb -- --------------------------------------------------------------------- -- Convenience methods with error handling diff --git a/src/Text/PrinterParser.hs b/src/Text/PrinterParser.hs --- a/src/Text/PrinterParser.hs +++ b/src/Text/PrinterParser.hs @@ -44,7 +44,7 @@ import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics -import Data.Maybe (listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid ((<>)) import Graphics.UI.Gtk (Color(..)) import Data.List (foldl') @@ -71,10 +71,10 @@ type MkFieldDescriptionS alpha beta = Parameters -> - (Printer beta) -> - (Parser beta) -> - (Getter alpha beta) -> - (Setter alpha beta) -> + Printer beta -> + Parser beta -> + Getter alpha beta -> + Setter alpha beta -> FieldDescriptionS alpha mkFieldS :: {--Eq beta =>--} MkFieldDescriptionS alpha beta @@ -82,15 +82,13 @@ FDS parameter (\ dat -> (PP.text (case getParameterPrim paraName parameter of Nothing -> "" - Just str -> T.unpack $ str) PP.<> PP.colon) - PP.$$ (PP.nest 15 (printer (getter dat))) - PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameter of + Just str -> T.unpack str) PP.<> PP.colon) + PP.$$ PP.nest 15 (printer (getter dat)) + PP.$$ PP.nest 5 (case getParameterPrim paraSynopsis parameter of Nothing -> PP.empty - Just str -> PP.text . T.unpack $ "--" <> str))) + Just str -> PP.text . T.unpack $ "--" <> str)) (\ dat -> try (do - symbol (case getParameterPrim paraName parameter of - Nothing -> "" - Just str -> str) + symbol (fromMaybe "" (getParameterPrim paraName parameter)) colon val <- parser return (setter val dat))) @@ -98,7 +96,7 @@ applyFieldParsers :: a -> [a -> CharParser () a] -> CharParser () a applyFieldParsers prefs parseF = do eof - return (prefs) + return prefs <|> do let parsers = map (\a -> a prefs) parseF newprefs <- choice parsers @@ -108,20 +106,20 @@ boolParser :: CharParser () Bool boolParser = do - (symbol "True" <|> symbol "true") + symbol "True" <|> symbol "true" return True <|> do - (symbol "False"<|> symbol "false") + symbol "False" <|> symbol "false" return False "bool parser" readParser :: Read a => CharParser () a readParser = do - str <- many (noneOf ['\n']) + str <- many (noneOf "\n") if null str then unexpected "read parser on empty string" - else do + else case maybeRead str of Nothing -> unexpected $ "read parser no parse " ++ str Just r -> return r @@ -141,14 +139,14 @@ stringParser :: CharParser () Text stringParser = do char '"' - str <- many (noneOf ['"']) + str <- many (noneOf "\"") char '"' return (T.pack str) "string parser" lineParser :: CharParser () Text lineParser = do - str <- many (noneOf ['\n']) + str <- many (noneOf "\n") return (T.pack str) "line parser" @@ -241,9 +239,8 @@ parseFields :: alpha -> [FieldDescriptionS alpha] -> P.CharParser () alpha parseFields defaultValue descriptions = - let parsersF = map fieldParser descriptions in do - res <- applyFieldParsers defaultValue parsersF - return res + let parsersF = map fieldParser descriptions in + applyFieldParsers defaultValue parsersF P. "prefs parser"