ltk 0.14.0.0 → 0.14.0.1
raw patch · 11 files changed
+1592/−1561 lines, 11 filesdep ~Cabaldep ~gtkdep ~gtk3
Dependency ranges changed: Cabal, gtk, gtk3, mtl, text, transformers
Files
- ltk.cabal +7/−8
- src/Control/Event.hs +2/−2
- src/Graphics/UI/Editor/Basics.hs +10/−13
- src/Graphics/UI/Editor/DescriptionPP.hs +15/−18
- src/Graphics/UI/Editor/MakeEditor.hs +19/−22
- src/Graphics/UI/Editor/Parameters.hs +19/−19
- src/Graphics/UI/Editor/Simple.hs +1/−0
- src/Graphics/UI/Frame/Panes.hs +1/−1
- src/Graphics/UI/Frame/ViewFrame.hs +1495/−1450
- src/MyMissing.hs +4/−6
- src/Text/PrinterParser.hs +19/−22
ltk.cabal view
@@ -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
src/Control/Event.hs view
@@ -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
src/Graphics/UI/Editor/Basics.hs view
@@ -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}))
src/Graphics/UI/Editor/DescriptionPP.hs view
@@ -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
src/Graphics/UI/Editor/MakeEditor.hs view
@@ -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)
src/Graphics/UI/Editor/Parameters.hs view
@@ -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
src/Graphics/UI/Editor/Simple.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -----------------------------------------------------------------------------
src/Graphics/UI/Frame/Panes.hs view
@@ -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}
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -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 : <maintainer at leksah.org>--- Stability : provisional--- Portability : portable--------- | Splittable panes containing notebooks with any widgets----------------------------------------------------------------------------------------module Graphics.UI.Frame.ViewFrame (- removePaneAdmin-, addPaneAdmin-, notebookInsertOrdered-, markLabel---- * Convenience methods for accesing Pane state-, posTypeToPaneDirection-, paneDirectionToPosType-, paneFromName-, mbPaneFromName-, guiPropertiesFromName---- * View Actions-, viewMove-, viewSplitHorizontal-, viewSplitVertical---, viewSplit-, viewSplit'-, viewNewGroup-, newGroupOrBringToFront-, bringGroupToFront-, viewNest-, viewNest'-, viewDetach-, viewDetach'-, handleNotebookSwitch-, viewCollapse-, viewCollapse'-, viewTabsPos-, viewSwitchTabs--, closeGroup-, allGroupNames---- * View Queries-, getBestPanePath-, getBestPathForId-, getActivePanePath-, getActivePanePathOrStandard-, figureOutPaneName-, getNotebook-, getPaned-, getActiveNotebook-, getActivePane-, setActivePane-, getUiManager-, getWindows-, getMainWindow-, getActiveWindow-, getActiveScreen-, getLayout-, getPanesSt-, getPaneMapSt-, getPanePrim-, getPanes---- * View Actions-, bringPaneToFront-, newNotebook-, newNotebook'---- * Accessing GUI elements---, widgetFromPath-, getUIAction-, widgetGet--, initGtkRc-) where--import Graphics.UI.Gtk-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 ("<b>" <> group <> "</b>")- labelBox <- mkLabelBox label (groupPrefix <> group)- liftIO $ widgetShowAll labelBox- return labelBox---- | Add the change mark or removes it-markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO ()-markLabel nb topWidget modified = do- mbBox <- notebookGetTabLabel nb topWidget- case mbBox of- Nothing -> return ()- Just box -> do- mbContainer <- binGetChild (castToBin box)- case mbContainer of- Nothing -> return ()- Just container -> do- children <- containerGetChildren container- let label = castToLabel $ forceHead (tail children) "ViewFrame>>markLabel: empty children"- (text :: Text) <- widgetGetName topWidget- labelSetUseMarkup (castToLabel label) True- labelSetMarkup (castToLabel label)- (if modified- then "<span foreground=\"red\">" <> text <> "</span>"- else text)---- | Constructs a unique pane name, which is an index and a string-figureOutPaneName :: PaneMonad alpha => Text -> Int -> alpha (Int,Text)-figureOutPaneName bn ind = do- bufs <- getPanesSt- let ind = foldr (\(PaneC buf) ind ->- if primPaneName buf == bn- then max ind ((getAddedIndex buf) + 1)- else ind)- 0 (Map.elems bufs)- if ind == 0- then return (0,bn)- else return (ind,bn <> "(" <> T.pack (show ind) <> ")")--paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha)-paneFromName pn = do- mbPane <- mbPaneFromName pn- case mbPane of- Just p -> return p- Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ T.unpack pn--mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha))-mbPaneFromName pn = do- panes <- getPanesSt- return (Map.lookup pn panes)---- |-guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections)-guiPropertiesFromName pn = do- paneMap <- getPaneMapSt- case Map.lookup pn paneMap of- Just it -> return it- otherwise -> error $"Cant't find guiProperties from unique name " ++ T.unpack pn--posTypeToPaneDirection PosLeft = LeftP-posTypeToPaneDirection PosRight = RightP-posTypeToPaneDirection PosTop = TopP-posTypeToPaneDirection PosBottom = BottomP--paneDirectionToPosType LeftP = PosLeft-paneDirectionToPosType RightP = PosRight-paneDirectionToPosType TopP = PosTop-paneDirectionToPosType BottomP = PosBottom------- | Toggle the tabs of the current notebook----viewSwitchTabs :: PaneMonad alpha => alpha ()-viewSwitchTabs = do- mbNb <- getActiveNotebook- case mbNb of- Nothing -> return ()- Just nb -> liftIO $ do- b <- notebookGetShowTabs nb- notebookSetShowTabs nb (not b)------- | Sets the tab position in the current notebook----viewTabsPos :: PaneMonad alpha => PositionType -> alpha ()-viewTabsPos pos = do- mbNb <- getActiveNotebook- case mbNb of- Nothing -> return ()- Just nb -> liftIO $notebookSetTabPos nb pos------- | Split the currently active pane in horizontal direction----viewSplitHorizontal :: PaneMonad alpha => alpha ()-viewSplitHorizontal = viewSplit Horizontal------- | Split the currently active pane in vertical direction----viewSplitVertical :: PaneMonad alpha => alpha ()-viewSplitVertical = viewSplit Vertical------- | The active view can be split in two (horizontal or vertical)----viewSplit :: PaneMonad alpha => Direction -> alpha ()-viewSplit dir = do- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> return ()- Just panePath -> 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 : <maintainer at leksah.org> +-- Stability : provisional +-- Portability : portable +-- +-- +-- | Splittable panes containing notebooks with any widgets +-- +--------------------------------------------------------------------------------- + + +module Graphics.UI.Frame.ViewFrame ( + removePaneAdmin +, addPaneAdmin +, notebookInsertOrdered +, markLabel + +-- * Convenience methods for accesing Pane state +, posTypeToPaneDirection +, paneDirectionToPosType +, paneFromName +, mbPaneFromName +, guiPropertiesFromName + +-- * View Actions +, viewMove +, viewSplitHorizontal +, viewSplitVertical +--, viewSplit +, viewSplit' +, viewNewGroup +, newGroupOrBringToFront +, bringGroupToFront +, viewNest +, viewNest' +, viewDetach +, viewDetach' +, handleNotebookSwitch +, viewCollapse +, viewCollapse' +, viewTabsPos +, viewSwitchTabs + +, closeGroup +, allGroupNames + +-- * View Queries +, getBestPanePath +, getBestPathForId +, getActivePanePath +, getActivePanePathOrStandard +, figureOutPaneName +, getNotebook +, getPaned +, getActiveNotebook +, getActivePane +, setActivePane +, getUiManager +, getWindows +, getMainWindow +, getActiveWindow +, getActiveScreen +, getLayout +, getPanesSt +, getPaneMapSt +, getPanePrim +, getPanes + +-- * View Actions +, bringPaneToFront +, newNotebook +, newNotebook' + +-- * Accessing GUI elements +--, widgetFromPath +, getUIAction +, widgetGet + +, initGtkRc +) where + +import Graphics.UI.Gtk + (castToNotebook, uiManagerGetAction, Action, Paned, + selectionDataGetText, SelectionDataM, InfoId, Point, DragContext, + dragDataReceived, dragDestSetTargetList, dragDestSet, + notebookSetPopup, notebookSetScrollable, notebookNew, + windowPresent, widgetVisible, notebookRemovePage, Notebook, + windowGetScreen, Screen, castToWindow, gTypeWindow, + widgetGetToplevel, deleteEvent, widgetGetAllocation, + windowSetDefaultSize, widgetName, windowNew, Widget, + dialogResponse, dialogGetActionArea, castToHBox, + dialogGetContentArea, windowTitle, windowTransientFor, dialogNew, + Window, widgetDestroy, dialogRun, messageDialogNew, castToWidget, + switchPage, widgetGrabFocus, castToVBox, boxReorderChild, + castToBox, notebookSetMenuLabel, notebookSetTabLabel, + notebookInsertPage, panedPack1, castToContainer, containerRemove, + notebookPageNum, panedPack2, hPanedNew, castToPaned, vPanedNew, + widgetGetParent, notebookGetCurrentPage, notebookSetTabPos, + PositionType, notebookSetShowTabs, notebookGetShowTabs, + castToLabel, containerGetChildren, castToBin, binGetChild, + notebookGetTabLabel, labelSetMarkup, labelSetUseMarkup, + buttonActivated, selectionDataSetText, dragDataGet, + dragSourceSetTargetList, targetListAddTextTargets, targetListNew, + dragSourceSet, boxPackStart, containerAdd, containerSetBorderWidth, + widgetSetVAlign, widgetGetStyleContext, stockClose, + imageNewFromStock, imageNewFromPixbuf, iconThemeLoadIcon, + iconThemeGetDefault, buttonSetAlignment, buttonSetRelief, + buttonSetFocusOnClick, buttonNew, hBoxNew, + eventBoxSetVisibleWindow, eventBoxNew, miscSetPadding, castToMisc, + miscSetAlignment, EventBox, notebookSetCurrentPage, widgetShowAll, + notebookInsertPageMenu, widgetGetName, notebookGetNthPage, + notebookGetNPages, labelNew, Label, WidgetClass, NotebookClass, + widgetSetName, IconSize(..), ResponseId(..), Rectangle(..), + DragAction(..), DestDefaults(..), PositionType(..), Packing(..), + ReliefStyle(..), IconLookupFlags(..), after, on, ButtonsType(..), + MessageType(..), AttrOp(..), get, set) +import qualified Data.Map as Map +import Data.List +import Data.Maybe +import Data.Unique +import Data.Typeable +import Data.Text (Text) + +import Graphics.UI.Frame.Panes +import Graphics.UI.Editor.Parameters +import System.Glib (GObjectClass(..), isA) +import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook) +import System.CPUTime (getCPUTime) +import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) +#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 ("<b>" <> group <> "</b>") + labelBox <- mkLabelBox label (groupPrefix <> group) + liftIO $ widgetShowAll labelBox + return labelBox + +-- | Add the change mark or removes it +markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () +markLabel nb topWidget modified = do + mbBox <- notebookGetTabLabel nb topWidget + case mbBox of + Nothing -> return () + Just box -> do + mbContainer <- binGetChild (castToBin box) + case mbContainer of + Nothing -> return () + Just container -> do + children <- containerGetChildren container + let label = castToLabel $ forceHead (tail children) "ViewFrame>>markLabel: empty children" + (text :: Text) <- widgetGetName topWidget + labelSetUseMarkup (castToLabel label) True + labelSetMarkup (castToLabel label) + (if modified + then "<span foreground=\"red\">" <> text <> "</span>" + else text) + +-- | Constructs a unique pane name, which is an index and a string +figureOutPaneName :: PaneMonad alpha => Text -> Int -> alpha (Int,Text) +figureOutPaneName bn ind = do + bufs <- getPanesSt + let ind = foldr (\(PaneC buf) ind -> + if primPaneName buf == bn + then max ind ((getAddedIndex buf) + 1) + else ind) + 0 (Map.elems bufs) + if ind == 0 + then return (0,bn) + else return (ind,bn <> "(" <> T.pack (show ind) <> ")") + +paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha) +paneFromName pn = do + mbPane <- mbPaneFromName pn + case mbPane of + Just p -> return p + Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ T.unpack pn + +mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) +mbPaneFromName pn = do + panes <- getPanesSt + return (Map.lookup pn panes) + +-- | +guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections) +guiPropertiesFromName pn = do + paneMap <- getPaneMapSt + case Map.lookup pn paneMap of + Just it -> return it + otherwise -> error $"Cant't find guiProperties from unique name " ++ T.unpack pn + +posTypeToPaneDirection PosLeft = LeftP +posTypeToPaneDirection PosRight = RightP +posTypeToPaneDirection PosTop = TopP +posTypeToPaneDirection PosBottom = BottomP + +paneDirectionToPosType LeftP = PosLeft +paneDirectionToPosType RightP = PosRight +paneDirectionToPosType TopP = PosTop +paneDirectionToPosType BottomP = PosBottom + +-- +-- | Toggle the tabs of the current notebook +-- +viewSwitchTabs :: PaneMonad alpha => alpha () +viewSwitchTabs = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> liftIO $ do + b <- notebookGetShowTabs nb + notebookSetShowTabs nb (not b) + +-- +-- | Sets the tab position in the current notebook +-- +viewTabsPos :: PaneMonad alpha => PositionType -> alpha () +viewTabsPos pos = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> liftIO $notebookSetTabPos nb pos + +-- +-- | Split the currently active pane in horizontal direction +-- +viewSplitHorizontal :: PaneMonad alpha => alpha () +viewSplitHorizontal = viewSplit Horizontal + +-- +-- | Split the currently active pane in vertical direction +-- +viewSplitVertical :: PaneMonad alpha => alpha () +viewSplitVertical = viewSplit Vertical + +-- +-- | The active view can be split in two (horizontal or vertical) +-- +viewSplit :: PaneMonad alpha => Direction -> alpha () +viewSplit dir = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> 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 +
src/MyMissing.hs view
@@ -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
src/Text/PrinterParser.hs view
@@ -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"