diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/billeksah-pane.cabal b/billeksah-pane.cabal new file mode 100644 --- /dev/null +++ b/billeksah-pane.cabal @@ -0,0 +1,44 @@ +name: billeksah-pane +version: 1.0.0 +cabal-version: >= 1.8 +build-type: Simple +license: LGPL +license-file: LICENSE +copyright: Juergen "jutaro" Nicklisch-Franken +maintainer: maintainer@leksah.org +homepage: http://www.leksah.org +package-url: https://github.com/leksah +bug-reports: http://code.google.com/p/leksah/issues/list +synopsis: Leksah library +description: General library used by leksah +category: Graphics +author: Juergen "jutaro" Nicklisch-Franken +tested-with: GHC ==7.0 + + +Library + exposed-modules: + Graphics.Panes + Graphics.Frame + Graphics.FrameTypes + Graphics.Pane + Graphics.Menu + Graphics.Session + Graphics.Statusbar + exposed: True + buildable: True + hs-source-dirs: src + build-depends: + base >=4.0.0.0 && <4.4, + containers >=0.2 && <0.5, + mtl >=1.1.0.2 && <2.1, + transformers >= 0.2.2.0 && < 0.3, + parsec >= 3.1.1 && < 4, + pretty >=1.0.1.0 && <1.1, + directory >= 1.1.0.0 && <1.2, + filepath >= 1.2.0.0 && < 1.3, + gtk >= 0.12.0 && < 0.13, + glib >= 0.12.0 && < 0.13, + time >= 1.2 && < 1.3, + + billeksah-services >= 1.0.0 && < 1.1 diff --git a/src/Graphics/Frame.hs b/src/Graphics/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Frame.hs @@ -0,0 +1,1775 @@ +{-# Language + FunctionalDependencies, + MultiParamTypeClasses, + DeriveDataTypeable, + ExistentialQuantification, + StandaloneDeriving, + FlexibleInstances, + ScopedTypeVariables, + FlexibleContexts, + CPP, + TypeFamilies #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.Frame +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- +-- | Splittable panes containing notebooks with any widgets +-- +--------------------------------------------------------------------------------- + + +module Graphics.Frame ( + + -- * Pane class + Pane(..) + + -- * Actions +, viewSwitchTabs +, viewTabsPos +, viewNewGroup +, viewCollapse +, viewSplitHorizontal +, viewSplitVertical +, viewMove +, viewDetach +, viewClosePane +, quit + +-- * Events +, FrameEvent(..) +, FrameEventSel(..) +, triggerFrameEvent +, getFrameEvent +, registerFrameEvent + + -- * Internals +, getMainWindow +, handleNotebookSwitch +, newNotebook +, viewSplit' +, paneDirectionToPosType +, viewDetach' +, viewNest' +, mbPaneFromName +, paneFromName +, posTypeToPaneDirection +, getNotebook +, getPaned +, viewCollapse' +, allGroupNames +, closeGroup +, GenPane(..) +, getPanes + + -- * Accesing state +, initialFrameState +, registerFrameState +, getUiManagerSt +, getWindowsSt +, setWindowsSt +, getPanesSt +, setPanesSt +, getPaneMapSt +, setPaneMapSt +, getActivePaneSt +, setActivePaneSt +, getLayoutSt +, setLayoutSt +, setPaneTypes +, getPaneTypes +, getSessionExt +, setSessionExt +, getToolbar +, setToolbar +, getStatusbar +, setStatusbar +, getPanePathFromNB +, setPanePathFromNB +, getRecentPanes +, setRecentPanes + +) where + +import Base +import Graphics.Panes +import Graphics.FrameTypes + +import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.Map(Map) +import Data.List +import Data.Maybe +import Data.Unique +import Data.Typeable +import Data.Version + +import System.Glib (GObjectClass(..), isA) +#if MIN_VERSION_gtk(0,10,5) +import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook) +#else +import Graphics.UI.Gtk.Types (gTypeNotebook) +#endif +import System.CPUTime (getCPUTime) +#if MIN_VERSION_gtk(0,10,5) +import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) +#else +import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) +#endif +import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) +import qualified Data.Set as Set (unions, member) +import Data.Set (Set(..)) +import Graphics.UI.Gtk.Gdk.Events (Event(..)) +import Data.IORef(newIORef) + +-- import Debug.Trace (trace) +trace a b = b + + +-- ---------------------------------- +-- * Events +-- +data FrameEventSel = FrameEventSel + deriving (Eq, Ord, Show, Typeable) + +instance Selector FrameEventSel where + type ValueType FrameEventSel = EventChannel FrameEvent + +-- +-- | Events the gui frame triggers +-- +data FrameEvent = + ActivatePane String + | DeactivatePane String + | MovePane String + | ChangeLayout + | RegisterActions [ActionDescr] + | RegisterPane [(String, GenPane)] + | RegisterSessionExt [GenSessionExtension] + | RegisterStatusbarComp [CompDescr] + | AboutToQuit Bool + +makeFrameEvent :: StateM(EventChannel FrameEvent) +makeFrameEvent = makeEvent FrameEventSel + +triggerFrameEvent :: FrameEvent -> StateM(FrameEvent) +triggerFrameEvent = triggerEvent FrameEventSel + +getFrameEvent :: StateM (EventChannel FrameEvent) +getFrameEvent = getEvent FrameEventSel + +registerFrameEvent hdl = getFrameEvent >>= \ev -> registerEvent ev hdl + +-- ------------------------------------ +-- * The state connected with frames +-- + +-- | Shows the state for the implementation of the GUI Frame +-- +data FrameState = FrameState { + fsUiManager :: UIManager +, fsWindows :: [Window] +, fsPanes :: Map PaneName GenPane +, fsPaneMap :: (Map PaneName (PanePath, Connections)) -- these connections are from the build +, fsActivePane :: Maybe (PaneName, Connections) -- and these connections from activate +, fsPanePathFromNB :: Map Notebook PanePath +, fsLayout :: PaneLayout +, fsRecentPanes :: [PaneName] +, fsPaneTypes :: [(String,GenPane)] -- ^ The string is the paneType of the pane + -- the second arg encapsulates the real type +, fsSessionExt :: [GenSessionExtension] +, fsToolbar :: (Maybe Toolbar) +, fsStatusbar :: (Map CompName CompWidget, Maybe HBox)} + deriving Typeable +-- +-- | Empty initial frame state +-- +initialFrameState uim = FrameState { + fsUiManager = uim +, fsWindows = [] +, fsPanes = Map.empty +, fsPaneMap = Map.empty +, fsActivePane = Nothing +, fsPanePathFromNB = Map.empty +, fsLayout = initialLayout +, fsRecentPanes = [] +, fsPaneTypes = [] +, fsSessionExt = [] +, fsToolbar = (Nothing) +, fsStatusbar = (Map.empty,Nothing)} + + +data GenPane = forall alpha beta . Pane alpha => PaneC alpha + +instance Eq GenPane where + (==) (PaneC x) (PaneC y) = paneName x == paneName y + +instance Ord GenPane where + (<=) (PaneC x) (PaneC y) = paneName x <= paneName y + +instance Show GenPane where + show (PaneC x) = "Pane " ++ paneName x + +-- --------------------------------------------------------------------- +-- * Accessor functions +-- + +getThis :: (FrameState -> alpha) -> StateM alpha +getThis sel = do + st <- getFrameState + return (sel st) + +setThis :: (FrameState -> alpha -> FrameState) -> alpha -> StateM () +setThis sel value = do + st <- getFrameState + setFrameState (sel st value) + +getWindowsSt = getThis fsWindows +setWindowsSt = setThis (\st value -> st{fsWindows = value}) +getUiManagerSt = getThis fsUiManager +getPanesSt = getThis fsPanes +setPanesSt = setThis (\st value -> st{fsPanes = value}) +getPaneMapSt = getThis fsPaneMap +setPaneMapSt = setThis (\st value -> st{fsPaneMap = value}) +getActivePaneSt = getThis fsActivePane +setActivePaneSt = setThis (\st value -> st{fsActivePane = value}) +getLayoutSt = getThis fsLayout +setLayoutSt = setThis (\st value -> st{fsLayout = value}) +getPanePathFromNB = getThis fsPanePathFromNB +setPanePathFromNB = setThis (\st value -> st{fsPanePathFromNB = value}) +getRecentPanes = getThis fsRecentPanes +setRecentPanes = setThis (\st value -> st{fsRecentPanes = value}) +getPaneTypes = getThis fsPaneTypes +setPaneTypes = setThis (\st value -> st{fsPaneTypes = value}) +getSessionExt = getThis fsSessionExt +setSessionExt = setThis (\st value -> st{fsSessionExt = value}) +getToolbar = getThis fsToolbar +setToolbar = setThis (\st value -> st{fsToolbar = value}) +getStatusbar = getThis fsStatusbar +setStatusbar = setThis (\st value -> st{fsStatusbar = value}) + + +-- +-- | The handling of the state of the frame +-- + +data FrameStateSel = FrameStateSel + deriving (Eq, Ord, Show, Typeable) + +instance Selector FrameStateSel where + type ValueType FrameStateSel = FrameState + + +registerFrameState :: FrameState -> StateM (Maybe String) +registerFrameState = registerState FrameStateSel + +setFrameState :: FrameState -> StateM () +setFrameState = setState FrameStateSel + +getFrameState :: StateM (FrameState) +getFrameState = getState FrameStateSel + +-- | Quit ide -- TODO +quit :: StateAction +quit = do + AboutToQuit shallQuit <- triggerFrameEvent (AboutToQuit True) + when shallQuit (liftIO mainQuit) + +-- ---------------------------------------- +-- * The main interface to the frame system + +-- +-- | All kinds of panes are instances of Pane +-- +class PaneInterface alpha => Pane alpha where + + paneName :: alpha -> PaneName + -- ^ gets a string which names this pane, which may include an added index ... + paneName b = if getAddedIndex b == 0 + then primPaneName b + else primPaneName b ++ "(" ++ show (getAddedIndex b) ++ ")" + + getAddedIndex :: alpha -> Int + -- ^ ..., which is used if more then one pane has the same name + getAddedIndex _ = 0 + + makeActive :: alpha -> Connections -> StateM () + -- ^ activates this pane, should probably be private + makeActive pane conn = do + mbAP <- getActivePaneSt + case mbAP of + Just (pn,_) | pn == paneName pane -> return () + _ -> do + deactivatePane + liftIO $ bringPaneToFront pane + setActivePaneSt (Just (paneName pane,conn)) + -- use it for error reporting + triggerFrameEvent (ActivatePane (paneName pane)) + recent <- getRecentPanes + setRecentPanes + (paneName pane : filter (/= paneName pane) recent) + return () + + closePane :: alpha -> StateM Bool + -- ^ closes this pane + closePane pane = do + (panePath,conn) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + error ("notebook page not found: unexpected " ++ paneName pane ++ " " ++ show panePath) + return False + Just i -> do + liftIO $ signalDisconnectAll conn + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + deactivatePaneIfActive pane + removePaneAdmin pane + recent <- getRecentPanes + setRecentPanes (filter (/= paneName pane) recent) + return True + + getPane :: StateM (Maybe alpha) + -- ^get a pane of this type, if one is open + getPane = do + selectedPanes <- getPanes + if null selectedPanes || length selectedPanes > 1 + then return Nothing + else (return (Just $ head selectedPanes)) + + forceGetPane :: Either PanePath String -> PaneArgs alpha -> StateM alpha + -- ^get a pane of this type, if not one is open panic + forceGetPane pp arg = do mbPane <- getOrBuildPane pp arg + case mbPane of + Nothing -> error "Can't get pane " + Just p -> return p + + getOrBuildPane :: Either PanePath String -> PaneArgs alpha -> StateM (Maybe alpha) + -- ^get a pane of this type, if one is open, or build one and for this specify either + -- a pane path to put it, or a group name, from which a pane path may be derived + getOrBuildPane ePpoPid arg = do + mbPane <- getPane + case mbPane of + Nothing -> do + pp <- case ePpoPid of + Right pId -> getBestPathForId pId + Left ppp -> do + layout <- getLayoutSt + return (getBestPanePath ppp layout) + nb <- getNotebook pp + buildPanePrim pp nb (builder arg) + Just pane -> return (Just pane) + + buildPane :: Either PanePath String -> PaneArgs alpha -> StateM (Maybe alpha) + -- ^build a pane of this specific type + buildPane ePpoPid arg = do + pp <- case ePpoPid of + Right pId -> getBestPathForId pId + Left ppp -> do + layout <- getLayoutSt + return (getBestPanePath ppp layout) + nb <- getNotebook pp + buildPanePrim pp nb (builder arg) + + + displayPane :: alpha -> Bool -> StateM () + -- ^ makes this pane visible + displayPane pane shallGrabFocus = do + liftIO $ bringPaneToFront pane + when shallGrabFocus $ liftIO $ widgetGrabFocus $ getTopWidget pane + + + getOrBuildDisplay :: Either PanePath String -> Bool -> PaneArgs alpha -> StateM (Maybe alpha) + -- ^ is a concatination of getOrBuildPane and displayPane + getOrBuildDisplay pps b arg = do + mbP <- getOrBuildPane pps arg + case mbP of + Nothing -> return Nothing + Just p -> do + displayPane p b + return (Just p) + + buildPanePrim :: PanePath -> + Notebook -> + (PanePath -> Notebook -> Window -> StateM (Maybe alpha,Connections)) -> + StateM (Maybe alpha) + buildPanePrim panePath notebook builder = do + windows <- getWindowsSt + + (mbBuf,cids) <- builder panePath notebook (head windows) + case mbBuf of + Nothing -> return Nothing + Just buf -> do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + let b1 = case Map.lookup (paneName buf) paneMap' of + Nothing -> True + Just it -> False + let b2 = case Map.lookup (paneName buf) panes' of + Nothing -> True + Just it -> False + if b1 && b2 + then do + idx <- notebookInsertOrdered notebook (getTopWidget buf) (paneName buf) Nothing False + mbPage <- liftIO $ notebookGetNthPage notebook idx + mbCid <- case mbPage of + Nothing -> return Nothing + Just page -> liftM Just (reifyState (\ stateR -> + on (castToContainer page) setFocusChild (\ _ -> + liftIO (reflectState (makeActive buf []) stateR)))) + addPaneAdmin buf (case mbCid of {Nothing -> cids; Just c -> castCID c:cids}) panePath + liftIO $ do + widgetSetName (getTopWidget buf) (paneName buf) + widgetShowAll (getTopWidget buf) + widgetGrabFocus (getTopWidget buf) + bringPaneToFront buf + return (Just buf) + else return Nothing + + setChanged :: alpha -> Bool -> StateM () + -- ^ Set the state of this pane to changed or not changed + setChanged pane hasChanged = liftIO $ do + let topWidget = getTopWidget pane + mbNb <- getNotebookForWidget topWidget + case mbNb of + Nothing -> return () + Just nb -> markLabel nb topWidget hasChanged + + +-- --------------------------------------------------------------------- +-- Activating and deactivating Panes. +-- This is here and not in Views because it needs some dependencies +-- (e.g. Events for history) +-- + +deactivatePane :: StateAction +deactivatePane = do + mbAP <- getActivePaneSt + case mbAP of + Nothing -> return () + Just (name,signals) -> do + liftIO $ signalDisconnectAll signals + setActivePaneSt Nothing + triggerFrameEvent (DeactivatePane name) + return () + +deactivatePaneWithoutEvents :: StateAction +deactivatePaneWithoutEvents = do + mbAP <- getActivePaneSt + case mbAP of + Just (_,signals) -> liftIO $do + signalDisconnectAll signals + Nothing -> return () + setActivePaneSt Nothing + +deactivatePaneIfActive :: Pane alpha => alpha -> StateAction +deactivatePaneIfActive pane = do + mbActive <- getActivePaneSt + case mbActive of + Nothing -> return () + Just (n,_) -> if n == paneName pane + then deactivatePane + else return () + + +addPaneAdmin :: Pane alpha => alpha -> Connections -> PanePath -> StateM 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 + return False + +paneFromName :: PaneName -> StateM GenPane +paneFromName pn = do + mbPane <- mbPaneFromName pn + case mbPane of + Just p -> return p + Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn + +mbPaneFromName :: PaneName -> StateM (Maybe GenPane) +mbPaneFromName pn = do + panes <- getPanesSt + return (Map.lookup pn panes) + +type StandardPath = PanePath + +-- +-- | 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 :: String -> StateM PanePath +getBestPathForId id = do + p <- panePathForGroup id + l <- getLayoutSt + return (getBestPanePath p l) + +findGroupPath :: String -> 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: " ++ group) + where + filterFunc (_,(TerminalP groups _ _ _ _)) = group `Set.member` Map.keysSet groups + filterFunc _ = error "ViewFrame>>findGroupPath: impossible" + + +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 + + + +getNotebookOrPaned :: PanePath -> (Widget -> beta) -> StateM beta +getNotebookOrPaned p cf = do + layout <- getLayoutSt + mwn <- mainWindowName + (widgetGet $ getWidgetNameList p layout mwn) cf + +widgetGet :: [String] -> (Widget -> b) -> StateM (b) +widgetGet strL cf = do + windows <- getWindowsSt + r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL + return (cf r) + +getWidgetNameList :: PanePath -> PaneLayout -> String -> [String] +getWidgetNameList path layout mainWindowName = reverse $ nameList (reverse path) (reverse $ layoutsFromPath path layout) + where + nameList [] _ = reverse [mainWindowName,"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 + +mainWindowName :: StateM String +mainWindowName = do + windows <- getWindowsSt + case windows of + [] -> return "" + (w:_) -> liftIO (widgetGetName w) + +-- +-- | Bring the pane to the front position in its notebook +-- +bringPaneToFront :: Pane alpha => alpha -> IO () +bringPaneToFront pane = do + let tv = getTopWidget pane + 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 () + +getNotebookForWidget :: (WidgetClass alpha) => alpha -> IO (Maybe Notebook) +getNotebookForWidget widget = do + mbParent <- widgetGetParent widget + case mbParent of + Just parent -> do + if parent `isA` gTypeNotebook + then return (Just (castToNotebook parent)) + else return Nothing + Nothing -> return Nothing + +-- | Translates a pane direction to the widget name +-- +paneDirectionToWidgetName :: PaneDirection -> String +paneDirectionToWidgetName TopP = "top" +paneDirectionToWidgetName BottomP = "bottom" +paneDirectionToWidgetName LeftP = "left" +paneDirectionToWidgetName RightP = "right" + +panePathElementToWidgetName :: PanePathElement -> String +panePathElementToWidgetName (SplitP dir) = paneDirectionToWidgetName dir +panePathElementToWidgetName (GroupP group) = groupPrefix ++ group + +-- +-- | 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 + +-- +-- | Get the widget from a list of strings +-- +widgetFromPath :: Widget -> [String] -> IO (Widget) +widgetFromPath w [] = return w +widgetFromPath w path = do + children <- containerGetChildren (castToContainer w) + chooseWidgetFromPath children path + +chooseWidgetFromPath :: [Widget] -> [String] -> 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 + + +-- +-- | Get the notebook widget for the given pane path +-- +getNotebook :: PanePath -> StateM Notebook +getNotebook p = getNotebookOrPaned p (castToNotebook' ("getNotebook " ++ show p)) + +getNotebook' :: String -> PanePath -> StateM Notebook +getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " ++ str ++ " " ++ show p)) + + +castToNotebook' :: GObjectClass obj => String -> obj -> Notebook +castToNotebook' str obj = if obj `isA` gTypeNotebook + then castToNotebook obj + else error ("Not a notebook " ++ str) + +notebookInsertOrdered :: (NotebookClass self, WidgetClass child) + => self + -> child -- child - the Widget to use as the contents of the page. + -> String + -> Maybe Label -- the label for the page as String or Label + -> Bool + -> StateM Int +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 + return realPos + +-- +-- | used to identify a group from a pane name +-- +groupPrefix = "_group_" + +-- +-- | Get a pane name without group prefix +-- +withoutGroupPrefix :: String -> String +withoutGroupPrefix s = case groupPrefix `stripPrefix` s of + Nothing -> s + Just s' -> s' + + +groupLabel :: String -> StateM EventBox +groupLabel group = do + label <- liftIO $ labelNew Nothing + liftIO $ labelSetUseMarkup label True + liftIO $ labelSetMarkup label ("" ++ group ++ "") + labelBox <- mkLabelBox label (groupPrefix ++ group) + liftIO $ widgetShowAll labelBox + return labelBox + +-- | Add the change mark or removes it +markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () +markLabel nb topWidget modified = do + mbBox <- notebookGetTabLabel nb topWidget + case mbBox of + Nothing -> return () + Just box -> do + mbContainer <- binGetChild (castToBin box) + case mbContainer of + Nothing -> return () + Just container -> do + children <- containerGetChildren (castToContainer container) + let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children" + text <- widgetGetName topWidget + labelSetUseMarkup (castToLabel label) True + labelSetMarkup (castToLabel label) + (if modified + then "" ++ text ++ "" + else text) + + +-- | Returns a label box +mkLabelBox :: Label -> String -> StateM 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" + buttonSetFocusOnClick tabButton False + buttonSetRelief tabButton ReliefNone + buttonSetAlignment tabButton (0.0,0.0) + + image <- imageNewFromStock stockClose IconSizeMenu + mbPB <- widgetRenderIcon tabButton stockClose IconSizeMenu "" + (height,width) <- case mbPB of + Nothing -> return (14,14) + Just pb -> do + h <- pixbufGetHeight pb + w <- pixbufGetWidth pb + return (h,w) + on tabButton styleSet (\style -> do + widgetSetSizeRequest tabButton (height + 2) (width + 2)) + containerSetBorderWidth tabButton 0 + containerAdd tabButton image + + boxPackStart innerBox lbl PackNatural 0 + boxPackEnd innerBox tabButton PackNatural 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 $ onClicked tb (cl ()) + + return lb + where + closeHandler :: () -> StateM () + closeHandler _ = case groupPrefix `stripPrefix` paneName of + Just group -> do + closeGroup group + Nothing -> do + (PaneC pane) <- paneFromName paneName + closePane pane + return () + +closeGroup :: String -> StateM () +closeGroup groupName = do + layout <- getLayoutSt + let mbPath = findGroupPath groupName layout + mainWindow <- getMainWindow + case mbPath of + Nothing -> message Warning ("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) + +getMainWindow = liftM head getWindowsSt + +-- +-- | 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 + + +removePaneAdmin :: Pane alpha => alpha -> StateM () +removePaneAdmin pane = do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + setPanesSt (Map.delete (paneName pane) panes') + setPaneMapSt (Map.delete (paneName pane) paneMap') + + +getPanePrim :: Typeable alpha => Pane alpha => StateM (Maybe alpha) +getPanePrim = do + selectedPanes <- getPanes + if null selectedPanes || length selectedPanes > 1 + then return Nothing + else (return (Just $ head selectedPanes)) + +-- +-- | Get all panes of a certain type +-- +getPanes :: Typeable alpha => Pane alpha => StateM ([alpha]) +getPanes = do + panes' <- getPanesSt + return (catMaybes + $ map (\(PaneC p) -> cast p) + $ Map.elems panes') + + + +-- | Constructs a unique pane name, which is an index and a string +figureOutPaneName :: String -> Int -> StateM (Int,String) +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 ++ "(" ++ show ind ++ ")") + + +-- | +guiPropertiesFromName :: PaneName -> StateM (PanePath, Connections) +guiPropertiesFromName pn = do + paneMap <- getPaneMapSt + case Map.lookup pn paneMap of + Just it -> return it + otherwise -> error $"Cant't find guiProperties from unique name " ++ pn + +posTypeToPaneDirection PosLeft = LeftP +posTypeToPaneDirection PosRight = RightP +posTypeToPaneDirection PosTop = TopP +posTypeToPaneDirection PosBottom = BottomP + +paneDirectionToPosType LeftP = PosLeft +paneDirectionToPosType RightP = PosRight +paneDirectionToPosType TopP = PosTop +paneDirectionToPosType BottomP = PosBottom + +-- +-- | Closes the current pane +-- +viewClosePane :: StateM () +viewClosePane = do + mbPane <- getActivePaneSt + case mbPane of + Nothing -> do + return () + Just (paneName,_) -> do + (PaneC pane) <- paneFromName paneName + closePane pane >> return () + +-- +-- | Toggle the tabs of the current notebook +-- +viewSwitchTabs :: StateM () +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 :: PositionType -> StateM () +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 :: StateM () +viewSplitHorizontal = viewSplit Horizontal + +-- +-- | Split the currently active pane in vertical direction +-- +viewSplitVertical :: StateM () +viewSplitVertical = viewSplit Vertical + +-- +-- | The active view can be split in two (horizontal or vertical) +-- +viewSplit :: Direction -> StateM () +viewSplit dir = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewSplit' panePath dir + +viewSplit' :: PanePath -> Direction -> StateM () +viewSplit' panePath dir = do + l <- getLayoutSt + case layoutFromPath panePath l of + (TerminalP _ _ _ (Just _) _) -> message Warning ("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 -> message Warning ("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 + ppNb <- getPanePathFromNB + setPanePathFromNB $ Map.insert activeNotebook oldPath ppNb + 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 <- widgetGetName activeNotebook + widgetSetName newpane rName + widgetSetName nb altname + 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 + 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 $ afterSwitchPage nb 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 :: StateM () +viewCollapse = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewCollapse' panePath + +viewCollapse' :: PanePath -> StateM () +viewCollapse' panePath = do + layout1 <- getLayoutSt + case layoutFromPath panePath layout1 of + (TerminalP _ _ _ (Just _) _) -> message Debug ("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 + ppNb <- getPanePathFromNB + let ! newMap = Map.delete otherSideNotebook ppNb + 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" + -- 4. Change panePathFromNotebook + adjustNotebooks panePath newPanePath + -- 5. Change paneMap + adjustPanes panePath newPanePath + -- 6. Change layout + adjustLayoutForCollapse panePath + +getGroupsFrom :: PanePath -> PaneLayout -> [String] +getGroupsFrom path layout = + case layoutFromPath path layout of + t@(TerminalP _ _ _ _ _) -> Map.keys (paneGroups t) + HorizontalP _ _ _ -> [] + VerticalP _ _ _ -> [] + +viewNewGroup :: StateM () +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 :: String -> PanePath -> StateM (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 :: String -> StateM (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 String) +groupNameDialog parent = liftIO $ do + dia <- dialogNew + windowSetTransientFor dia parent + windowSetTitle dia "Enter group name" + upper <- dialogGetUpper dia + lower <- dialogGetActionArea dia + + buttonBox <- hButtonBoxNew + okButton <- buttonNewFromStock "gtk-ok" + cancelButton <- buttonNewFromStock "gtk-cancel" + onClicked okButton (dialogResponse dia ResponseOk) + onClicked cancelButton (dialogResponse dia ResponseCancel) + boxPackStartDefaults buttonBox cancelButton + boxPackStartDefaults buttonBox okButton + boxPackStart lower buttonBox PackNatural 7 + dialogSetDefaultResponse dia ResponseOk + + label <- labelNew (Just "Group Name") + textField <- entryNew +-- entrySetActivatesDefault textField True + windowSetDefault dia (Just okButton) + boxPackStartDefaults upper label + boxPackStartDefaults upper textField + + + widgetShowAll dia + resp <- dialogRun dia + value <- entryGetText textField + widgetDestroy dia + case resp of + ResponseOk | value /= "" -> return (Just value) + _ -> return Nothing + +viewNest :: String -> StateM () +viewNest group = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewNest' panePath group + +viewNest' :: PanePath -> String -> StateM () +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 $ afterSwitchPage nb handleFunc + adjustLayoutForNest group panePath + _ -> return () + +viewDetach :: StateM (Maybe (Window,Widget)) +viewDetach = do + id <- liftIO $ fmap show getCPUTime + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return Nothing + Just panePath -> do + viewDetach' panePath id + +viewDetach' :: PanePath -> String -> StateM (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 + windowSetTitle window "Leksah detached window" + widgetSetName window id + case size of + Just (width, height) -> do + windowSetDefaultSize window width height + Nothing -> do + (curWidth, curHeight) <- widgetGetSize activeNotebook + windowSetDefaultSize window curWidth curHeight + containerRemove (castToContainer parent) activeNotebook + containerAdd window activeNotebook + widgetShowAll window + return window + handleFunc <- runInIO (handleReattach id window) + liftIO $ window `onDelete` handleFunc + windows <- getWindowsSt + setWindowsSt $ windows ++ [window] + adjustLayoutForDetach id panePath + return (Just (window, castToWidget activeNotebook)) + _ -> return Nothing + + + +handleReattach :: String -> Window -> Event -> StateM Bool +handleReattach windowId window _ = do + layout <- getLayoutSt + 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" + + + +groupMenuLabel :: String -> StateM (Maybe Label) +groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) + +handleNotebookSwitch :: Notebook -> Int -> StateM () +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 :: String -> StateM (Maybe GenPane) + 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 :: PaneDirection -> StateM () +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 :: Pane alpha => PanePath -> alpha -> StateM () +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' :: (PaneName,Notebook) -> StateM () +move' (paneName,toNB) = do + paneMap <- getPaneMapSt + panes <- getPanesSt + layout <- getLayoutSt + case groupPrefix `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) + ppNb <- getPanePathFromNB + case toNB `Map.lookup` ppNb 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 <- getLayoutSt + return () + Nothing -> + case paneName `Map.lookup` panes of + Nothing -> trace ("ViewFrame>>move': pane not found: " ++ paneName) return () + Just (PaneC pane) -> do + ppNb <- getPanePathFromNB + case toNB `Map.lookup` ppNb 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 + + +-- +-- | 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 :: PanePath -> StateM Notebook +newNotebook pp = do + nb <- liftIO newNotebook' + ppNb <- getPanePathFromNB + setPanePathFromNB $ Map.insert nb pp ppNb + 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 + liftIO $ func (str,nb) + return () + +findDetachedPath :: String -> 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: " ++ id) + where + filterFunc (_,(TerminalP _ _ _ (Just lid) _)) = lid == id + filterFunc _ = False + + +allGroupNames :: PaneLayout -> Set String +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 (gtk) Paned widget for a given path +-- +getPaned :: PanePath -> StateM Paned +getPaned p = getNotebookOrPaned p castToPaned + +-- +-- | Get the path to the active pane +-- +getActivePanePath :: StateM (Maybe PanePath) +getActivePanePath = do + mbPane <- getActivePaneSt + case mbPane of + Nothing -> return Nothing + Just (paneName,_) -> do + (pp,_) <- guiPropertiesFromName paneName + return (Just pp) + +getActivePanePathOrStandard :: StandardPath -> StateM (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 :: StateM (Maybe Notebook) +getActiveNotebook = do + mbPanePath <- getActivePanePath + case mbPanePath of + Just panePath -> do + nb <- (getNotebook' "getActiveNotebook") panePath + return (Just nb) + Nothing -> return Nothing + +-- +-- | Changes a pane path in the pane map +-- +adjustPanes :: PanePath -> PanePath -> StateM () +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 :: PanePath -> PanePath -> StateM () +adjustNotebooks fromPane toPane = do + npMap <- trace ("+++ adjustNotebooks from: " ++ show fromPane ++ " to " ++ show toPane) + getPanePathFromNB + setPanePathFromNB (Map.map (\pp -> + case stripPrefix fromPane pp of + Just rest -> toPane ++ rest + _ -> pp) npMap) + +-- +-- | Changes the layout for a split +-- +adjustLayoutForSplit :: PaneDirection -> PanePath -> StateM () +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 :: String -> PanePath -> StateM () +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 :: String -> PanePath -> StateM () +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 :: PanePath -> StateM () +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 :: PanePath -> StateM () +adjustLayoutForCollapse oldPath = do + layout <- getLayoutSt + let pathLayout = layoutFromPath oldPath layout + setLayoutSt $ adjustLayout (init oldPath) layout pathLayout + +-- +-- | Changes the layout for a move +-- +adjustLayoutForGroupMove :: PanePath -> PanePath -> String -> StateM () +adjustLayoutForGroupMove fromPath toPath group = do + layout <- getLayoutSt + let layoutToMove = layoutFromPath fromPath layout + let newLayout = removeGL fromPath layout + setLayoutSt (addGL layoutToMove (toPath ++ [GroupP group]) newLayout) + +-- +-- | Changes the layout for a remove +-- +adjustLayoutForGroupRemove :: PanePath -> String -> StateM () +adjustLayoutForGroupRemove fromPath group = do + layout <- getLayoutSt + setLayoutSt (removeGL fromPath layout) + + +-- +-- | 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 + + + +widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b) +widgetGetRel w sl cf = do + r <- widgetFromPath w sl + return (cf r) + +getUIAction :: String -> (Action -> a) -> StateM (a) +getUIAction str f = do + uiManager <- getUiManagerSt + liftIO $ do + findAction <- uiManagerGetAction uiManager str + case findAction of + Just act -> return (f act) + Nothing -> error $"getUIAction can't find action " ++ str + + diff --git a/src/Graphics/FrameTypes.hs b/src/Graphics/FrameTypes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/FrameTypes.hs @@ -0,0 +1,132 @@ +{-# Language ExistentialQuantification, TypeFamilies, MultiParamTypeClasses, + DeriveDataTypeable, FlexibleInstances, StandaloneDeriving #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.FrameTypes +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- +-- | Splittable panes containing notebooks with any widgets +-- +--------------------------------------------------------------------------------- + +module Graphics.FrameTypes ( + panePluginName +, ActionDescr(..) +, ActionType(..) +, MenuPosition(..) +, ToolPosition(..) +, SessionExtension(..) +, GenSessionExtension(..) +, CompDescr(..) +, CompPosition(..) +, CompName +, CompWidget(..) +) where + +import Base + +import Graphics.UI.Gtk +import Data.Maybe (fromJust) + +panePluginName = "billeksah-pane" + +--------------------------------------------------------------------------------------- +-- * Types for Actions, Menus, Toolbars + +-- | ActionDescr is a data structure used for +-- menus, toolbars, and accelerator keystrokes. In this implementation +-- GtkActions are build from this description +data ActionDescr = AD { + adName :: String -- ^ has to be unique, so allways prepend the plugin name, + -- seperated with a dot. +, adLabel :: String -- ^ what is displayed in the menu +, adSynopsis :: Maybe String -- ^ maybe a text to display in a tooltip +, adStockID :: Maybe String -- ^ maybe a text for a gtk standard action +, adAction :: StateM () -- ^ the action to perform + -- which then may show a special icon, ... +, adAccelerator :: Maybe String -- ^ Keyboard accelerator + -- ^ The format looks like "a" or "F1" or "z" +, adActionType :: ActionType +, adMenu :: Maybe MenuPosition +, adToolbar :: Maybe ToolPosition +, adSensitivities :: [GenSelector] +} + +type WithSeparator = Bool + +data MenuPosition = + MPFirst [String] -- ^ Add this item in the first position using path. + | MPLast [String] WithSeparator -- ^ Add this item in the last position using path. + | MPAfter [String] + WithSeparator -- ^ Add this item after the first arg string + -- If the Bool is true add a separator between. + | MPBefore [String] -- ^ Add this item before the first arg string + -- in the last position using path (second arg). + | MPAppend WithSeparator -- ^ Append this after the last added item. + -- If the Bool is true add a separator between. + | MPOr MenuPosition MenuPosition -- ^ Try the first position. + -- If this fails try the next. + deriving Eq + +data ToolPosition = + TPFirst -- ^ Add this item in the first position. + | TPLast WithSeparator -- ^ Add this item in the last position. + | TPAfter String WithSeparator -- ^ Add this item after the first arg string + | TPBefore String -- ^ Add this item before the first arg string + -- in the last position using path (second arg). + | TPAppend WithSeparator -- ^ Append this after the last added item. + | TPOr ToolPosition ToolPosition -- ^ Try the first position. + -- If this fails try the next. + deriving Eq + +-- | Beside Standard action we have actions which toggles a state or select from a +-- number of possible states +data ActionType = ActionNormal | ActionToggle | ActionSubmenu -- TODO ActionSelect alpha + deriving Eq + +--------------------------------------------------------------------------------------- +-- * Types for Sessions + +data (Read alpha, Show alpha) => SessionExtension alpha = SessionExtension { + seName :: String, + seRetriever :: StateM alpha, + seApplicator :: alpha -> StateM ()} + +data GenSessionExtension = forall alpha . (Read alpha, Show alpha) => GenS (SessionExtension alpha) + +--------------------------------------------------------------------------------------- +-- * Types for Statusbar + +type CompName = String + +-- +-- | Description of a Statusbar compartment +-- +data CompDescr = + TextCompDescr + {scName :: CompName, + scHasResizeGrip :: Bool, + scRequestedSize :: Int, + scPacking :: Packing, + scPosition :: CompPosition} + +-- +-- | Description of a Statusbar position +-- +data CompPosition = + CPFirst -- ^ Add this item in the first position. + | CPLast -- ^ Add this item in the last position. + | CPAfter String -- ^ Add this item after the first arg string + | CPBefore String -- ^ Add this item before the first arg string + deriving Eq + + +data CompWidget = CompWText Statusbar + + diff --git a/src/Graphics/Menu.hs b/src/Graphics/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Menu.hs @@ -0,0 +1,423 @@ +{-# Language TypeFamilies, DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- +-- Module : Graphics.Menu +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Menu services +-- +----------------------------------------------------------------------------- + +module Graphics.Menu ( + initActions, + setSensitivity, + registerActionState, + initialActionState, + + toggleToolbar, + showToolbar, + toolbarVisible +)where + +import Base +import Graphics.FrameTypes +import Graphics.Frame +import Graphics.Panes +import Graphics.Statusbar + + +import Data.Version (Version(..)) +import Data.Typeable (Typeable) +import Control.Monad.IO.Class (MonadIO(..)) +import Graphics.UI.Gtk +import Control.Monad (liftM, when, foldM_, filterM, foldM) +import Data.List (nub, elemIndex) +import Data.Map (Map) +import qualified Data.Map as Map (fromList, lookup, empty) +import Data.Maybe (fromJust, mapMaybe, catMaybes) + + + +----------------------------------------- +-- * The handling of the state of the frame +-- +type ActionState = Map GenSelector [String] + +data ActionStateSel = ActionStateSel + deriving (Eq, Ord, Show, Typeable) + +instance Selector ActionStateSel where + type ValueType ActionStateSel = ActionState + +registerActionState :: ActionState -> StateM (Maybe String) +registerActionState = registerState ActionStateSel + +setActionState :: ActionState -> StateM () +setActionState st = do + message Debug ("setActionState: " ++ show st) + setState ActionStateSel st + +getActionState :: StateM (ActionState) +getActionState = getState ActionStateSel + +initialActionState = Map.empty + +-------------------------------------------------------------- +-- * Actions + +-- +-- | * Builds the menu and toolbar from the action description, +-- and registers accelerators from the action descriptions +initActions :: UIManager -> [ActionDescr] -> StateM (MenuBar,Toolbar) +initActions uiManager actionDescrs = do + message Debug "initAction" + mb <- liftIO $ menuBarNew + tb <- liftIO $ toolbarNew + actionGroup <- liftIO $ actionGroupNew "global" + accGroup <- liftIO $ uiManagerGetAccelGroup uiManager + foldM_ (buildAction uiManager accGroup actionGroup tb mb) (Nothing,Nothing) actionDescrs + liftIO $ uiManagerInsertActionGroup uiManager actionGroup 1 + setActionState (buildActionState actionDescrs) + return (mb,tb) + + +buildActionState :: [ActionDescr] -> Map GenSelector [String] +buildActionState actionDescrs = Map.fromList $ zip allSensitivities (map actionStringsFor allSensitivities) + where + allSensitivities = nub $ concatMap adSensitivities actionDescrs + actionStringsFor sens = mapMaybe (actionStringFor sens) actionDescrs + actionStringFor sens AD{adName = name, adSensitivities = sensitivities} + | elem sens sensitivities = Just name + | otherwise = Nothing + +buildAction uiManager accGroup actionGroup toolBar mb lastPosition actionDescr = + let (acc,accString) = case adAccelerator actionDescr of + Nothing -> (Nothing,"=" ++ adName actionDescr) + Just ha -> (Just ha, ha ++ "=" ++ adName actionDescr) + in case adActionType actionDescr of + ActionSubmenu -> reifyState $ \ stateR -> do + fst <- buildMenuItem uiManager mb (Nothing :: Maybe Action) + actionDescr (fst lastPosition) + return (fst, snd lastPosition) + ActionNormal -> reifyState $ \ stateR -> do + act <- actionNew (adName actionDescr) + (adLabel actionDescr) (adSynopsis actionDescr) (adStockID actionDescr) + actionSetAccelGroup act accGroup + onActionActivate act (reflectState (do + adAction actionDescr + setStatusText "SBActions" accString) stateR) + actionGroupAddActionWithAccel actionGroup act acc + fst <- buildMenuItem uiManager mb (Just act) actionDescr (fst lastPosition) + snd <- buildToolItem uiManager toolBar (Just act) actionDescr (snd lastPosition) + return (fst,snd) + ActionToggle -> reifyState $ \ stateR -> do + act <- toggleActionNew (adName actionDescr) + (adLabel actionDescr) (adSynopsis actionDescr) (adStockID actionDescr) + actionSetAccelGroup act accGroup + on act actionToggled (reflectState (do + adAction actionDescr + setStatusText "SBActions" accString) stateR) + actionGroupAddActionWithAccel actionGroup act acc + fst <- buildMenuItem uiManager mb (Just act) actionDescr (fst lastPosition) + snd <- buildToolItem uiManager toolBar (Just act) actionDescr (snd lastPosition) + return (fst,snd) + +-------------------------------------------------------------- +-- * Menus + +buildMenuItem :: ActionClass alpha => UIManager -> MenuBar -> Maybe alpha -> ActionDescr + -> Maybe (MenuShell,Int) -> IO (Maybe (MenuShell,Int)) +buildMenuItem uiManager mb mbAction ad@AD{adMenu = menuPos, adName = name} mbLast + | menuPos == Nothing = case adAccelerator ad of + Nothing -> return mbLast + Just str -> do + uiManagerAddUiFromString uiManager $ + "" + return mbLast + | otherwise = do + menuItem <- mkMenuItem mbAction ad + res <- getInsertion (castToMenuShell mb) (fromJust menuPos) + case res of + Nothing -> error ("Menu>>buildMenuItem: No valid position for: " ++ adName ad) + Just (Prepend ms) -> do + menuShellPrepend ms (castToMenuItem menuItem) + return (Just (ms,0)) + Just (Append ms separated) -> do + when separated $ do + sep <- separatorMenuItemNew + menuShellAppend ms sep + menuShellAppend ms (castToMenuItem menuItem) + idx <- getMenuIndexForItem ms (castToMenuItem menuItem) + case idx of + Nothing -> return (Just (ms,0)) + Just idx -> return (Just (ms,idx)) + Just (Insert idx ms separated) -> do + idx' <- if separated + then do + sep <- separatorMenuItemNew + menuShellInsert ms sep idx + return (idx + 1) + else return idx + menuShellInsert ms (castToMenuItem menuItem) idx' + return (Just (ms,idx')) + Just (AfterLast separated) -> do + case mbLast of + Nothing -> error ("Menu>>buildMenuItem: No last insertion for: " ++ adName ad) + Just (ms,idx) -> do + idx' <- if separated + then do + sep <- separatorMenuItemNew + menuShellInsert ms sep (idx + 1) + return (idx + 1) + else return idx + menuShellInsert ms (castToMenuItem menuItem) (idx' + 1) + return (Just (ms,idx' + 1)) + +mkMenuItem :: ActionClass alpha => Maybe alpha -> ActionDescr -> IO MenuItem +mkMenuItem Nothing AD{adActionType = actionType, adLabel = label} + | actionType == ActionSubmenu = do + menuItem <- menuItemNewWithMnemonic label + subMenu <- menuNew + menuItemSetSubmenu menuItem subMenu + return menuItem + | otherwise = error "Menu>>mkMenuItem: Impossible" +mkMenuItem (Just action) AD{adActionType = actionType} + | actionType == ActionNormal || actionType == ActionToggle = do + menuItem <- actionCreateMenuItem action + return (castToMenuItem menuItem) +data MenuPos = Prepend MenuShell | Append MenuShell Bool | Insert Int MenuShell Bool + | AfterLast Bool + +getInsertion :: MenuShell -> MenuPosition -> IO (Maybe MenuPos) +getInsertion mb (MPFirst path) = do + res <- getMenuShellForPath path mb + case res of + Nothing -> return Nothing + Just ms -> return (Just (Prepend ms)) +getInsertion mb (MPLast path sep) = do + res <- getMenuShellForPath path mb + case res of + Nothing -> return Nothing + Just ms -> return (Just (Append ms sep)) +getInsertion mb (MPAfter [] sep) = error "Menu>>getInsertion: Empty After path" +getInsertion mb (MPAfter (name:path) sep) + = do + res <- getMenuShellForPath path mb + case res of + Nothing -> return Nothing + Just ms -> do + mbIdx <- getMenuIndexForName ms name + case mbIdx of + Nothing -> return Nothing + Just idx -> return + (Just (Insert (idx + 1) + ms sep)) +getInsertion mb (MPBefore []) = error "Menu>>getInsertion: Empty Before path" +getInsertion mb (MPBefore (n:p)) = do + res <- getMenuShellForPath p mb + case res of + Nothing -> return Nothing + Just ms -> do + mbIdx <- getMenuIndexForName ms n + case mbIdx of + Nothing -> return Nothing + Just idx -> return + (Just (Insert idx ms False)) +getInsertion mb (MPAppend sep) = return (Just (AfterLast sep)) +getInsertion mb (MPOr mp1 mp2) = do + mbFirst <- getInsertion mb mp1 + case mbFirst of + Just t -> return (Just t) + Nothing -> getInsertion mb mp2 + +getMenuShellForPath :: [String] -> MenuShell -> IO (Maybe MenuShell) +getMenuShellForPath [] menu = return (Just menu) +getMenuShellForPath (hd:rest) menu = do + widgets <- containerGetChildren menu + res <- filterM (\ w -> do + mbLabel <- binGetChild (castToBin w) + case mbLabel of + Nothing -> return False + Just label -> do + n <- labelGetText (castToLabel label) + return (n == hd)) widgets + case res of + [w] -> do + submenu <- menuItemGetSubmenu (castToMenuItem w) + case submenu of + Nothing -> error ("Menu>>getMenuShellForPath: Can't find submenu for " ++ hd) + Just w -> getMenuShellForPath rest (castToMenuShell w) + otherwise -> return Nothing + +getMenuIndexForName :: MenuShell -> String -> IO (Maybe Int) +getMenuIndexForName menu name = do + widgets <- containerGetChildren menu + res <- filterM (\ (w,_) -> do + mbLabel <- binGetChild (castToBin w) + case mbLabel of + Nothing -> return False + Just label -> do + n <- labelGetText (castToLabel label) + return (n == name)) + (zip widgets [0..]) + case res of + [(w,idx)] -> return (Just idx) + otherwise -> return Nothing + +getMenuIndexForItem :: MenuShell -> MenuItem -> IO (Maybe Int) +getMenuIndexForItem menu item = do + widgets <- containerGetChildren menu + return (elemIndex item (map castToMenuItem widgets)) + +-------------------------------------------------------------- +-- * Toolbar + +buildToolItem :: ActionClass alpha => UIManager -> Toolbar -> Maybe alpha -> ActionDescr + -> Maybe Int -> IO (Maybe Int) +buildToolItem uiManager tb Nothing ad@AD{adToolbar = toolPos, adName = name} mbLast + = return mbLast +buildToolItem uiManager tb (Just action) ad@AD{adToolbar = toolPos, adName = name} mbLast + | toolPos == Nothing = return mbLast + | otherwise = do + toolItem <- liftM castToToolItem (actionCreateToolItem action) + res <- getToolInsertion tb (fromJust toolPos) + case res of + Nothing -> error ("Menu>>buildToolItem: No valid position for: " ++ adName ad) + Just (InsertTool ind True) -> do + sep <- separatorToolItemNew + toolbarInsert tb sep ind + toolbarInsert tb toolItem (ind + 1) + return (Just (ind + 2)) + Just (InsertTool ind False) -> do + toolbarInsert tb toolItem ind + return (Just (ind + 1)) + Just (AfterLastTool True) -> do + case mbLast of + Nothing -> error $ "Menu>>buildToolItem: No last insertion for: " + ++ adName ad + Just ind -> do + toolbarInsert tb toolItem ind + return (Just (ind + 1)) + Just (AfterLastTool False) -> do + case mbLast of + Nothing -> error $ "Menu>>buildToolItem: No last insertion for: " + ++ adName ad + Just ind -> do + sep <- separatorToolItemNew + toolbarInsert tb sep ind + toolbarInsert tb toolItem (ind + 1) + return (Just (ind + 2)) + + + +data ToolPos = InsertTool Int Bool | AfterLastTool Bool + + +getToolInsertion :: Toolbar -> ToolPosition -> IO (Maybe ToolPos) +getToolInsertion tb TPFirst = return $ Just (InsertTool 0 False) +getToolInsertion tb (TPLast sep) = do + n <- toolbarGetNItems tb + return $ Just (InsertTool n sep) +getToolInsertion tb (TPAfter str sep) = do + mbIndex <- getToolIndexForName tb str + case mbIndex of + Just ind -> return $ Just (InsertTool (ind +1) sep) + Nothing -> return $ Nothing +getToolInsertion tb (TPBefore str) = do + mbIndex <- getToolIndexForName tb str + case mbIndex of + Just ind -> return $ Just + (InsertTool ind False) + Nothing -> return $ Nothing +getToolInsertion tb (TPAppend sep) = return $ Just (AfterLastTool sep) +getToolInsertion tb (TPOr mp1 mp2) = do + mbFirst <- getToolInsertion tb mp1 + case mbFirst of + Just t -> return (Just t) + Nothing -> getToolInsertion tb mp2 + + +getToolIndexForName :: Toolbar -> String -> IO (Maybe Int) +getToolIndexForName tb name = do + widgets <- containerGetChildren tb + res <- filterM (\ (w,_) -> do + mbString <- get (castToToolButton w) toolButtonLabel + case mbString of + Nothing -> return False + Just string -> do + return (string == name)) + (zip widgets [0..]) + case res of + [(w,idx)] -> return (Just idx) + otherwise -> return Nothing + +toggleToolbar :: StateM () +toggleToolbar = do + mbToolbar <- getToolbar + tbv <- toolbarVisible + case mbToolbar of + Nothing -> return () + Just tb -> if tbv + then liftIO $ widgetShowAll tb + else liftIO $ widgetHideAll tb + +showToolbar :: Bool -> StateM () +showToolbar showIt = do + mbToolbar <- getToolbar + uiManager <- getUiManagerSt + case mbToolbar of + Nothing -> return () + Just tb -> if showIt + then liftIO $ widgetShowAll tb + else liftIO $ widgetHideAll tb + mbAct <- liftIO $ getActionFor uiManager "ToolbarVisible" + case mbAct of + Nothing -> return () + Just act -> liftIO $ toggleActionSetActive (castToToggleAction act) showIt + +toolbarVisible :: StateM Bool +toolbarVisible = do + uiManager <- getUiManagerSt + mbAct <- liftIO $ getActionFor uiManager "ToolbarVisible" + case mbAct of + Nothing -> return False + Just act -> liftIO $ toggleActionGetActive (castToToggleAction act) + +-------------------------------------------------------------- +-- * Sensitivity + +-- +-- | Setting sensivity +-- +setSensitivity :: Selector s => [(s, Bool)] -> StateM () +setSensitivity l = do + message Debug ("setSensitivity " ++ show l) + mapM_ setSensitivitySingle l + message Debug ("after setSensitivity" ++ show l) + where + setSensitivitySingle (sens,bool) = do + actions <- getActionsFor sens + liftIO $ mapM_ (\a -> actionSetSensitive a bool) actions + +getActionsFor :: Selector s => s -> StateM [Action] +getActionsFor sens = do + actMap <- getActionState + uiManager <- getUiManagerSt + case Map.lookup (GS sens) actMap of + Nothing -> return [] + Just l -> do + maybeList <- liftIO $ (mapM (getActionFor uiManager) l) + return (catMaybes maybeList) + +getActionFor uiManager string = do + actionGroups <- uiManagerGetActionGroups uiManager + actionGroupGetAction (head actionGroups) string + + diff --git a/src/Graphics/Pane.hs b/src/Graphics/Pane.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pane.hs @@ -0,0 +1,250 @@ +{-# Language CPP, TypeFamilies, RankNTypes, DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.Pane +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | +-- +----------------------------------------------------------------------------------- + +module Graphics.Pane ( + startupFrame, + setSensitivity, + panePluginInterface, + + module Graphics.Frame, + module Graphics.FrameTypes, + module Graphics.Panes, + module Graphics.Session + +) where + +import Base +import Graphics.FrameTypes +import Graphics.Frame +import Graphics.Panes +import Graphics.Menu +import Graphics.Session +import Graphics.Statusbar + +import Graphics.UI.Gtk +import Data.Version (Version(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Concurrent (yield) +import Control.Monad (when) +import Data.Typeable (Typeable) + +-- ----------------------------------------------------------- +-- * It's a plugin +-- + +panePluginInterface :: StateM (PluginInterface FrameEvent) +panePluginInterface = do + fe <- makeEvent FrameEventSel + return $ PluginInterface { + piInit1 = frameInit1, + piInit2 = frameInit2, + piEvent = fe, + piName = panePluginName, + piVersion = Version [1,0,0][]} + +frameInit1 :: BaseEvent -> EventChannel FrameEvent -> StateM () +frameInit1 baseEvent myEvent = do + message Debug ("init1 " ++ panePluginName) + res <- registerActionState initialActionState + case res of + Nothing -> return () + Just s -> message Error s + return () + +frameInit2 :: BaseEvent -> EventChannel FrameEvent -> StateM () +frameInit2 baseEvent myEvent = do + message Debug ("init2 " ++ panePluginName) + uiManager <- reifyState (\stateR -> do + res <- unsafeInitGUIForThreadedRTS +-- res <- initGUI + messageR Debug ("initGUI " ++ show res) stateR + uiManagerNew) + liftIO $ initGtkRc + res <- registerFrameState (initialFrameState uiManager) + case res of + Nothing -> return () + Just s -> message Error s + getFrameEvent >>= \e -> registerEvent' e + (\s -> case s of + ActivatePane pn -> do setSensitivity [(PaneActiveSens, True)] + setStatusText "SBActivePane" pn + DeactivatePane _ -> do setSensitivity [(PaneActiveSens, False)] + setStatusText "SBActivePane" "" + _ -> return ()) + return () + +data PaneActiveSens = PaneActiveSens + deriving (Eq, Ord, Show, Typeable) + +instance Selector PaneActiveSens where + type ValueType PaneActiveSens = Bool + + +-- +-- | The Actions that can be performed on frames +-- +frameActions :: [ActionDescr] +frameActions = + [AD "File" "_File" Nothing Nothing (return ()) Nothing ActionSubmenu + (Just $ MPFirst []) Nothing [] + ,AD "Quit" "_Quit" Nothing (Just "gtk-quit") quit Nothing ActionNormal + (Just $ MPFirst ["File"]) Nothing [] + ,AD "View" "_View" Nothing Nothing (return ()) Nothing ActionSubmenu + (Just $ MPLast [] False) Nothing [] + ,AD "ViewMoveLeft" "Move _Left" Nothing Nothing + (viewMove LeftP) (Just "Left") ActionNormal + (Just $ MPFirst ["View"]) Nothing [GS PaneActiveSens] + ,AD "ViewMoveRight" "Move _Right" Nothing Nothing + (viewMove RightP) (Just "Right") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewMoveUp" "Move _Up" Nothing Nothing + (viewMove TopP) (Just "Up") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewMoveDown" "Move _Down" Nothing Nothing + (viewMove BottomP) (Just "Down") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewSplitHorizontal" "Split H_orizontal" Nothing Nothing + viewSplitHorizontal (Just "2") ActionNormal + (Just $ MPAppend True) Nothing [GS PaneActiveSens] + ,AD "ViewSplitVertical" "Split _Vertical" Nothing Nothing + viewSplitVertical (Just "3") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewCollapse" "_Collapse" Nothing Nothing + viewCollapse (Just "1") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewNest" "_Group" Nothing Nothing + viewNewGroup Nothing ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewDetach" "_Detach" Nothing Nothing + viewDetachInstrumented Nothing ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewTabsLeft" "Tabs Left" Nothing Nothing + (viewTabsPos PosLeft) (Just "Left") ActionNormal + (Just $ MPAppend True) Nothing[GS PaneActiveSens] + ,AD "ViewTabsRight" "Tabs Right" Nothing Nothing + (viewTabsPos PosRight) (Just "Right") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewTabsUp" "Tabs Up" Nothing Nothing + (viewTabsPos PosTop) (Just "Up") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewTabsDown" "Tabs Down" Nothing Nothing + (viewTabsPos PosBottom) (Just "Down") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + ,AD "ViewSwitchTabs" "Tabs On/Off" Nothing Nothing + viewSwitchTabs (Just "t") ActionNormal + (Just $ MPAppend False) Nothing [GS PaneActiveSens] + + ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close") + viewClosePane (Just "q") ActionNormal + (Just $ MPAppend True) (Just TPFirst) [GS PaneActiveSens] + + ,AD "ToolbarVisible" "Toolbar visible" Nothing Nothing + toggleToolbar (Just "t") ActionToggle (Just $ MPAppend True) Nothing [] + ] + +frameCompartments = [ + TextCompDescr "SBActions" False 150 PackGrow CPLast, + TextCompDescr "SBActivePane" False 150 PackGrow CPLast] + +-- +-- | Opens up the main window, with menu, toolbar, accelerators +-- +startupFrame :: String -> (Window -> VBox -> Notebook -> StateAction) -> + (Window -> VBox -> Notebook -> StateAction) -> StateAction +startupFrame windowName beforeWindowOpen beforeMainGUI = do + message Debug "startupFrame" + -- osxApp <- OSX.applicationNew + uiManager <- getUiManagerSt + RegisterActions allActions <- triggerFrameEvent (RegisterActions frameActions) + RegisterPane allPanes <- triggerFrameEvent (RegisterPane []) + setPaneTypes allPanes + RegisterSessionExt sessionExt <- triggerFrameEvent (RegisterSessionExt []) + setSessionExt sessionExt + (menuBar,toolbar) <- initActions uiManager allActions + setSensitivity [(PaneActiveSens, False)] + tbv <- toolbarVisible + setToolbar (Just toolbar) + showToolbar True + RegisterStatusbarComp allCompartments <- triggerFrameEvent (RegisterStatusbarComp frameCompartments) + statusbar <- buildStatusbar allCompartments + reifyState $ \ stateR -> do + + win <- windowNew + accGroup <- uiManagerGetAccelGroup uiManager + windowAddAccelGroup win accGroup + widgetSetName win windowName + reflectState (setWindowsSt [win]) stateR + + vb <- vBoxNew False 1 -- Top-level vbox + widgetSetName vb "topBox" + containerAdd win vb + + boxPackStart vb menuBar PackNatural 0 + + toolbarSetIconSize toolbar IconSizeButton + toolbarSetStyle toolbar ToolbarBothHoriz + widgetSetSizeRequest toolbar 700 (-1) + boxPackStart vb toolbar PackNatural 0 + + nb <- reflectState (newNotebook []) stateR + afterSwitchPage nb (\i -> reflectState (handleNotebookSwitch nb i) stateR) + widgetSetName nb "root" + win `onDelete` (\ _ -> do reflectState quit stateR; return True) + boxPackStart vb nb PackGrow 0 + + boxPackEnd vb statusbar PackNatural 0 + + reflectState (beforeWindowOpen win vb nb) stateR + timeoutAddFull (yield >> return True) priorityDefaultIdle 100 -- maybe switch back to + + widgetShowAll win + reflectState (do + toolbarIsVisible <- toolbarVisible + showToolbar toolbarIsVisible + beforeMainGUI win vb nb) stateR + + mainGUI + return () + +-- +-- | Set gtk style - call that function once at initialization +-- +initGtkRc :: IO () +#if MIN_VERSION_gtk(0,11,0) +initGtkRc = rcParseString ("style \"leksah-close-button-style\"\n" ++ + "{\n" ++ + " GtkWidget::focus-padding = 0\n" ++ + " GtkWidget::focus-line-width = 0\n" ++ + " xthickness = 0\n" ++ + " ythickness = 0\n" ++ + "}\n" ++ + "widget \"*.leksah-close-button\" style \"leksah-close-button-style\"") +#else +initGtkRc = return () +#endif + +viewDetachInstrumented :: StateM () +viewDetachInstrumented = do + mbPair <- viewDetach + case mbPair of + Nothing -> return () + Just (win,wid) -> do + instrumentSecWindow win + liftIO $ widgetShowAll win + +-- TODO Menu, Toolbar, Key accelerators, Statusbar ??? for other windows +instrumentSecWindow :: Window -> StateM () +instrumentSecWindow win = return () + diff --git a/src/Graphics/Panes.hs b/src/Graphics/Panes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Panes.hs @@ -0,0 +1,234 @@ + +{-# Language + ExistentialQuantification, + MultiParamTypeClasses, + FunctionalDependencies, + CPP, + DeriveDataTypeable, + EmptyDataDecls, + StandaloneDeriving, + TypeFamilies, + FlexibleContexts, + ScopedTypeVariables, + RankNTypes, + FlexibleInstances, + TypeSynonymInstances #-} + -- TypeFamilies +----------------------------------------------------------------------------- +-- +-- Module : Graphics.Panes +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | The basic definitions for all panes +-- +------------------------------------------------------------------------------- + +module Graphics.Panes ( + +-- * Panes and pane layout + Direction(..) +, PaneDirection(..) +, PanePathElement(..) +, PanePath +, PaneLayout(..) +, PaneName +, Connection +, Connections +, castCID +, PaneInterface(..) + +, PanePrefs(..) + +-- * Other +, signalDisconnectAll + +, panePathForGroup +, initialLayout + +, postSyncState +, postAsyncState + +) where + +import Base +import Graphics.FrameTypes + +import Graphics.UI.Gtk hiding (get) +import System.Glib.GObject +import System.Glib.Signals +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Typeable +import Control.Monad.Trans +import Data.List (isPrefixOf, stripPrefix, findIndex) +import Control.Monad (liftM, when) +import qualified Data.Set as Set (member) +import Data.IORef (newIORef) +import Data.Version (Version(..)) +import Foreign.C (CULong) + + +-- --------------------------------------------------------------------- +-- * Panes and pane layout +-- + +type PaneName = String + +-- +-- | The direction of a split +-- +data Direction = Horizontal | Vertical + deriving (Eq,Show) + +-- +-- | A path to a pane +-- +type PanePath = [PanePathElement] + +-- +-- | An element of a path to a pane +-- +data PanePathElement = SplitP PaneDirection | GroupP String + deriving (Eq,Show,Read) + +-- +-- | The relative direction to a pane from the parent +-- +data PaneDirection = TopP | BottomP | LeftP | RightP + deriving (Eq,Show,Read) + +-- +-- | Description of a window layout +-- Horizontal: top bottom Vertical: left right +-- +data PaneLayout = HorizontalP PaneLayout PaneLayout Int + | VerticalP PaneLayout PaneLayout Int + | TerminalP { + paneGroups :: Map String PaneLayout + , paneTabs :: Maybe PaneDirection + , currentPage :: Int + , detachedId :: Maybe String + , detachedSize :: Maybe (Int, Int) } + deriving (Eq,Show,Read) + +-- +-- | Empty initial layout +-- +initialLayout = TerminalP { + paneGroups = Map.empty +, paneTabs = Nothing +, currentPage = (-1) +, detachedId = Nothing +, detachedSize = Nothing} + + +data PanePrefs = PanePrefs { + ppCategoryForPane :: [(String,String)], + ppPathForCategory :: [(String,PanePath)], + ppDefaultPath :: PanePath} + deriving (Eq,Typeable) + + + +-- +-- | The class which describes the minimal implementation +-- +class (Typeable alpha, Show (PaneState alpha), Read (PaneState alpha)) => PaneInterface alpha where + + data PaneState alpha :: * + type PaneArgs alpha :: * + + primPaneName :: alpha -> String + -- ^ gets a string which names this pane + + + paneType :: alpha -> String + -- ^ gets a unique id for this type of pane + + builder :: PaneArgs alpha -> PanePath -> Notebook -> Window -> StateM (Maybe alpha,Connections) + -- ^ A function, which builds this pane + + getTopWidget :: alpha -> Widget + -- ^ gets the top Widget of this pane + + saveState :: alpha -> StateM (Maybe (PaneState alpha)) + -- ^ Returns the state of this pane + + recoverState :: PanePath -> PaneState alpha -> StateM (Maybe alpha) + -- ^ Sets the state for this pane + + + + + +-- +-- | Signal handlers for the different pane types +-- +type Connection = ConnectId Widget + +type Connections = [Connection] + +castCID :: GObjectClass alpha => ConnectId alpha -> ConnectId Widget +castCID (ConnectId ui o) = (ConnectId ui (castToWidget o)) + +-- TODO recover somewhere, needs prefs + +panePathForGroup:: String -> delta PanePath +panePathForGroup groupName = undefined + +signalDisconnectAll :: Connections -> IO () +signalDisconnectAll = mapM_ (\ s -> signalDisconnect s) + +instance Show Window where + show _ = "a Window" + +instance Show UIManager where + show _ = "a UIManager" + +instance Show Connection where + show _ = "a Connection" + +instance Show Notebook where + show _ = "a Notebook" + +deriving instance Typeable UIManager + +-- +postSyncState :: StateM a -> StateM a +postSyncState f = reifyState (\ideR -> postGUISync (reflectState f ideR)) + +-- +postAsyncState :: StateM () -> StateM () +postAsyncState f = reifyState (\ideR -> postGUIAsync (reflectState f ideR)) + + + +-- ---------------------------------------- +-- * Necessary with pre 10.1 verion of gtk2hs +-- + +#ifdef MIN_VERSION_gtk +#if MIN_VERSION_gtk(0,10,1) +#else +instance Eq Notebook + where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa == pb +instance Ord Notebook + where (<=) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa <= pb +instance Eq Window + where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa == pb +instance Eq Widget + where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa == pb +#endif +#endif + + diff --git a/src/Graphics/Session.hs b/src/Graphics/Session.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Session.hs @@ -0,0 +1,372 @@ +{-# Language TypeSynonymInstances, ScopedTypeVariables, RankNTypes, TypeFamilies, NoMonomorphismRestriction, + FlexibleContexts, DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.Session +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- +-- | Module for saving and recovering the layout +-- +--------------------------------------------------------------------------------- + + +module Graphics.Session ( + saveSession +, recoverSession +, asRegisterType +) where + +import Base +import Graphics.Panes +import Graphics.Frame +import Graphics.FrameTypes +import Graphics.Menu + +import Control.Monad.IO.Class (MonadIO(..)) +import Graphics.UI.Gtk +import qualified Data.Set as Set (toList) +import Control.Monad (forM_, when, forM, liftM) +import Data.Maybe (fromJust, isJust) +import Control.Exception (SomeException) +import qualified Data.Map as Map + (toList, fromAscList, keys, toAscList, elems, empty) +import qualified Text.PrettyPrint as PP (text) +import Data.Time.Clock (getCurrentTime) +import Data.Time (getTimeZone, utcToLocalTime) +import Data.Typeable (Typeable) + +------------------------------------------------------------------------ +-- * Interface + +asRegisterType :: forall alpha. Pane alpha => alpha -> (String,GenPane) +asRegisterType p = (paneType p, PaneC p) + +-- +-- | Retrieves a string with all session information +-- +saveSession :: StateM String +saveSession = do + wdw <- getMainWindow + layout <- mkLayout + population <- getPopulation + size <- liftIO $ windowGetSize wdw + activePane' <- getActivePaneSt + let activeP = case activePane' of + Nothing -> Nothing + Just (s,_) -> Just s + timeNow <- liftIO getCurrentTime + timeZone <- liftIO $ getTimeZone timeNow + extensions <- getSessionExtensions + tbv <- toolbarVisible + let state = SessionState { + ssSaveTime = show $ utcToLocalTime timeZone timeNow + , ssLayout = layout + , ssPopulation = population + , ssWindowSize = size + , ssActivePane = activeP + , ssToolbarVisible = tbv + , ssExtensions = extensions} + return(showFieldsSimple state sessionDescr) + +-- +-- | Recovers a session from a previously saved string +-- +recoverSession :: String -> StateM () +recoverSession string = do + detachedCloseAll + paneCloseAll + groupsCloseAll + viewCollapseAll + mbError <- recoverSession' string + case mbError of + Just err -> message Warning err + otherwise -> return () + return () + + + +-- --------------------------------------------------------------------- + +data SessionState = SessionState { + ssSaveTime :: String + , ssLayout :: PaneLayout + , ssPopulation :: [(String,Maybe String,PanePath)] + , ssWindowSize :: (Int,Int) + , ssActivePane :: Maybe String + , ssToolbarVisible :: Bool + , ssExtensions :: [(String,String)] +} deriving Typeable + + +defaultSession = SessionState { + ssSaveTime = "" + , ssLayout = TerminalP Map.empty (Just TopP) (-1) Nothing Nothing + , ssPopulation = [] + , ssWindowSize = (1024,768) + , ssActivePane = Nothing + , ssToolbarVisible = True + , ssExtensions = [] +} + +sessionDescr :: [FieldDescriptionS SessionState] +sessionDescr = [ + mkFieldS + "Time of storage" + Nothing + stringPrinter + stringParser + ssSaveTime + (\ b a -> a{ssSaveTime = b}) + , mkFieldS + "Layout" + Nothing + (stringPrinter . show) + readParser + ssLayout + (\ b a -> a{ssLayout = b}) + , mkFieldS + "Population" + Nothing + (stringPrinter . show) + readParser + ssPopulation + (\ b a -> a{ssPopulation = b}) + , mkFieldS + "Window size" + Nothing + (stringPrinter . show) + (pairParser intParser) + ssWindowSize + (\(c,d) a -> a{ssWindowSize = (c,d)}) + , mkFieldS + "Maybe active pane" + Nothing + (stringPrinter . show) + readParser + ssActivePane + (\ b a -> a{ssActivePane = b}) + , mkFieldS + "Toolbar visible" + Nothing + (stringPrinter . show) + readParser + ssToolbarVisible + (\ b a -> a{ssToolbarVisible = b}) + , mkFieldS + "Extensions" + Nothing + (stringPrinter . show) + readParser + ssExtensions + (\b a -> a{ssExtensions = b})] + + + +detachedCloseAll :: StateM () +detachedCloseAll = do + windows <- getWindowsSt + liftIO $ mapM_ widgetDestroy (tail windows) + +paneCloseAll :: StateM () +paneCloseAll = do + panes' <- getPanesSt + mapM_ (\ (PaneC p) -> closePane p) (Map.elems panes') + +groupsCloseAll :: StateM () +groupsCloseAll = do + layout' <- getLayoutSt + mapM_ closeGroup (Set.toList $ allGroupNames layout') + +viewCollapseAll :: StateM () +viewCollapseAll = do + layout' <- getLayoutSt + case layout' of + TerminalP {} -> return () + VerticalP _ _ _ -> viewCollapse' [SplitP LeftP] + HorizontalP _ _ _ -> viewCollapse' [SplitP TopP] + +mkLayout :: StateM(PaneLayout) +mkLayout = do + rawLayout <- getLayoutSt + getLayout' rawLayout [] + where + getLayout' (HorizontalP l r _) pp = do + l2 <- getLayout' l (pp ++ [SplitP TopP]) + r2 <- getLayout' r (pp ++ [SplitP BottomP]) + pane <- getPaned pp + pos <- liftIO $ panedGetPosition pane + return (HorizontalP l2 r2 pos) + getLayout' (VerticalP l r _) pp = do + l2 <- getLayout' l (pp ++ [SplitP LeftP]) + r2 <- getLayout' r (pp ++ [SplitP RightP]) + pane <- getPaned pp + pos <- liftIO $ panedGetPosition pane + return (VerticalP l2 r2 pos) + getLayout' raw@(TerminalP {paneGroups = groups}) pp = do + groups2 <- forM (Map.toAscList groups) $ \(group, g) -> do + l <- getLayout' g (pp ++ [GroupP group]) + return (group, l) + nb <- getNotebook pp + showTabs <- liftIO $ notebookGetShowTabs nb + pos <- liftIO $ notebookGetTabPos nb + current <- liftIO $ notebookGetCurrentPage nb + size <- case detachedId raw of + Just _ -> do + Just parent <- liftIO $ widgetGetParent nb + liftIO $ fmap Just $ windowGetSize (castToWindow parent) + Nothing -> return $ detachedSize raw + return raw { + paneGroups = Map.fromAscList groups2 + , paneTabs = if showTabs then Just (posTypeToPaneDirection pos) else Nothing + , currentPage = current + , detachedSize = size} + +getPopulation :: StateM[(String,Maybe String,PanePath)] +getPopulation = do + paneMap <- getPaneMapSt + mapM (\ (pn,v) -> do + (PaneC p) <- paneFromName pn + mbSt <- saveState p + let paneType' = paneType p + case mbSt of + Nothing -> return (paneType p, Nothing, fst v) + Just st -> return (paneType p, Just (show st), fst v)) + $ Map.toList paneMap + +getSessionExtensions :: StateM [(String,String)] +getSessionExtensions = do + ext <- getSessionExt + mapM getSessionExtension ext + +getSessionExtension :: GenSessionExtension -> StateM (String,String) +getSessionExtension (GenS SessionExtension{seName = name, seRetriever = retriever}) = do + val <- retriever + return (name,show val) + + +-- ------------------------------------------------------------ +-- * Recovering +-- ------------------------------------------------------------ + +-- +-- | Read and apply the saved layout +-- + +recoverSession' :: String -> StateM (Maybe String) +recoverSession' sessionString = catchState (do + wdw <- getMainWindow + let sessionSt = parseFieldsSimple sessionString sessionDescr defaultSession + liftIO $ windowSetDefaultSize wdw (fst (ssWindowSize sessionSt))(snd (ssWindowSize sessionSt)) + applyLayout (ssLayout sessionSt) + populate (ssPopulation sessionSt) + setCurrentPages (ssLayout sessionSt) + when (isJust (ssActivePane sessionSt)) $ do + mbPane <- mbPaneFromName (fromJust (ssActivePane sessionSt)) + case mbPane of + Nothing -> return () + Just (PaneC p) -> makeActive p [] + showToolbar (ssToolbarVisible sessionSt) + extensions <- getSessionExt + applyExtensions extensions (ssExtensions sessionSt) + return Nothing) + (\ (e :: SomeException) -> do + return $ Just ("Session>>recoverSession: " ++ show e)) + +applyLayout :: PaneLayout -> StateM () +applyLayout layoutS = do + old <- getLayoutSt + case old of + TerminalP {} -> applyLayout' layoutS [] + otherwise -> error "apply Layout can only be allied to empty Layout" + where + applyLayout' (TerminalP groups mbTabPos _ mbDetachedId mbDetachedSize) pp = do + forM_ (Map.keys groups) $ \group -> viewNest' pp group + nb <- getNotebook pp + case (mbDetachedId, mbDetachedSize) of + (Just id, Just (width, height)) -> do + mbPair <- viewDetach' pp id + case mbPair of + Nothing -> return () + Just (win,wid) -> do + liftIO $ widgetShowAll win + liftIO $ windowSetDefaultSize win width height + _ -> return () + liftIO $notebookSetShowTabs nb (isJust mbTabPos) + case mbTabPos of + Just p -> liftIO $notebookSetTabPos nb (paneDirectionToPosType p) + _ -> return () + forM_ (Map.toAscList groups) $ \(group, g) -> do + applyLayout' g (pp ++ [GroupP group]) + applyLayout' (VerticalP l r pos) pp = do + viewSplit' pp Vertical + pane <- getPaned pp + liftIO $panedSetPosition pane pos + applyLayout' l (pp ++ [SplitP LeftP]) + applyLayout' r (pp ++ [SplitP RightP]) + applyLayout' (HorizontalP t b pos) pp = do + viewSplit' pp Horizontal + pane <- getPaned pp + liftIO $panedSetPosition pane pos + applyLayout' t (pp ++ [SplitP TopP]) + applyLayout' b (pp ++ [SplitP BottomP]) + +populate :: [(String, Maybe String, PanePath)] -> StateM () +populate = mapM_ (\ (typeString,mbPs,pp) -> do + paneTypes <- getPaneTypes + case mbPs of + Nothing -> return () + Just s -> let mbTypeHint = case [pt | (ps,pt) <- paneTypes, ps == typeString] of + [th] -> Left th + [] -> Right ("Type not found: " ++ typeString) + l -> Right ("Type not unique: " ++ typeString) + in case mbTypeHint of + Right str -> message Error str + Left (PaneC gth) -> populate' gth s pp >> return ()) + +populate' :: forall alpha . Pane alpha => alpha -> String -> PanePath -> StateM () +populate' _ readString panePath = do + let mbPaneState :: Maybe (PaneState alpha) = maybeRead readString + case mbPaneState of + Just ps -> recoverState panePath ps >> return () + Nothing -> message Error "Can't read session state, no recovery possible" + +setCurrentPages :: PaneLayout -> StateM () +setCurrentPages layout = setCurrentPages' layout [] + where + setCurrentPages' (HorizontalP t b _) p = do setCurrentPages' t (SplitP TopP : p) + setCurrentPages' b (SplitP BottomP : p) + setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (SplitP LeftP : p) + setCurrentPages' r (SplitP RightP : p) + setCurrentPages' (TerminalP groups _ ind _ _) p = do + forM_ (Map.toAscList groups) $ \(group, g) -> do + setCurrentPages' g (GroupP group : p) + when (ind >= 0) $ do + nb <- getNotebook (reverse p) + liftIO $ notebookSetCurrentPage nb ind + +applyExtensions :: [GenSessionExtension] -> [(String,String)] -> StateM () +applyExtensions gs = mapM_ (applyExtension gs) + +applyExtension :: [GenSessionExtension] -> (String,String) -> StateM () +applyExtension genList (name,readString) = + case findExtension name genList of + Nothing -> + message Error ("Session>>applyExtension: Extension not found: " ++ name) + Just (GenS (SessionExtension {seApplicator = applicator})) -> do + let mbVal = maybeRead readString + case mbVal of + Just val -> applicator val + Nothing -> message Error $ "Session>>applyExtension: " ++ + "can't apply session extension " ++ readString + +findExtension :: String -> [GenSessionExtension] -> Maybe GenSessionExtension +findExtension str [] = Nothing +findExtension str (g@(GenS (SessionExtension {seName = name})):r) | name == str = Just g + | otherwise = findExtension str r + diff --git a/src/Graphics/Statusbar.hs b/src/Graphics/Statusbar.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Statusbar.hs @@ -0,0 +1,82 @@ +-- {-# Language #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.Statusbar +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- | Statusbar services +-- +----------------------------------------------------------------------------- + +module Graphics.Statusbar ( + buildStatusbar, + setStatusText +)where + +import Base +import Graphics.FrameTypes + +import Graphics.UI.Gtk +import Data.List (elemIndex, foldl') +import Control.Monad.IO.Class (MonadIO(..)) +import Graphics.Frame (getStatusbar, setStatusbar) +import qualified Data.Map as Map (lookup, fromList) + +type CompState = [(CompName,CompWidget)] + +-- +-- | Building of a statusbar +-- +buildStatusbar :: [CompDescr] -> StateM HBox +buildStatusbar descrs = do + comWidgets <- liftIO $ mapM buildWidget descrs + let sortedWidgets = foldl' buildOrder [] (zip descrs comWidgets) + hb <- liftIO $ do + hb <- hBoxNew False 1 + widgetSetName hb "statusBox" + mapM_ (\ (_,CompWText w) -> boxPackStart hb w PackGrow 0) sortedWidgets + return hb + setStatusbar (Map.fromList sortedWidgets, Just hb) + return hb + +buildWidget :: CompDescr -> IO CompWidget +buildWidget TextCompDescr{scName = name, scHasResizeGrip = rg, scRequestedSize = size} = do + sb <- statusbarNew + widgetSetName sb name + statusbarSetHasResizeGrip sb rg + widgetSetSizeRequest sb size (-1) + return (CompWText sb) + + +buildOrder :: CompState -> (CompDescr,CompWidget) -> CompState +buildOrder accu (TextCompDescr{scName = name,scPosition = pos},w) = + case pos of + CPFirst -> (name,w) : accu + CPLast -> accu ++ [(name,w)] + CPAfter str -> + let index = elemIndex str (map fst accu) + in case index of + Just i -> insertAt i (name,w) accu + Nothing -> accu ++ [(name,w)] + CPBefore str -> + let index = elemIndex str (map fst accu) + in case index of + Just i | i > 0 -> insertAt (i-1) (name,w) accu + otherwise -> accu ++ [(name,w)] + +-- +-- | Setting text in a statusbar +-- +setStatusText :: CompName -> String -> StateM () +setStatusText compName string = do + (theMap,_) <- getStatusbar + case Map.lookup compName theMap of + Just (CompWText sb) -> do + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 string + return () + otherwise -> return ()