billeksah-pane (empty) → 1.0.0
raw patch · 10 files changed
+3483/−0 lines, 10 filesdep +basedep +billeksah-servicesdep +containerssetup-changed
Dependencies added: base, billeksah-services, containers, directory, filepath, glib, gtk, mtl, parsec, pretty, time, transformers
Files
- LICENSE +165/−0
- Setup.lhs +6/−0
- billeksah-pane.cabal +44/−0
- src/Graphics/Frame.hs +1775/−0
- src/Graphics/FrameTypes.hs +132/−0
- src/Graphics/Menu.hs +423/−0
- src/Graphics/Pane.hs +250/−0
- src/Graphics/Panes.hs +234/−0
- src/Graphics/Session.hs +372/−0
- src/Graphics/Statusbar.hs +82/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ billeksah-pane.cabal view
@@ -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
+ src/Graphics/Frame.hs view
@@ -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 ("<b>" ++ group ++ "</b>")+ labelBox <- mkLabelBox label (groupPrefix ++ group)+ liftIO $ widgetShowAll labelBox+ return labelBox++-- | Add the change mark or removes it+markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO ()+markLabel nb topWidget modified = do+ mbBox <- notebookGetTabLabel nb topWidget+ case mbBox of+ Nothing -> return ()+ Just box -> do+ mbContainer <- binGetChild (castToBin box)+ case mbContainer of+ Nothing -> return ()+ Just container -> do+ children <- containerGetChildren (castToContainer container)+ let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children"+ text <- widgetGetName topWidget+ labelSetUseMarkup (castToLabel label) True+ labelSetMarkup (castToLabel label)+ (if modified+ then "<span foreground=\"red\">" ++ text ++ "</span>"+ 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++
+ src/Graphics/FrameTypes.hs view
@@ -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 "<Control>a" or "<Shift><Alt>F1" or "<Release>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++
+ src/Graphics/Menu.hs view
@@ -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 $+ "<accelerator name=\"" ++ name+ ++ "\" action=\"" ++ name ++ "\"/>"+ 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++
+ src/Graphics/Pane.hs view
@@ -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 "<alt><shift>Left") ActionNormal+ (Just $ MPFirst ["View"]) Nothing [GS PaneActiveSens]+ ,AD "ViewMoveRight" "Move _Right" Nothing Nothing+ (viewMove RightP) (Just "<alt><shift>Right") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewMoveUp" "Move _Up" Nothing Nothing+ (viewMove TopP) (Just "<alt><shift>Up") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewMoveDown" "Move _Down" Nothing Nothing+ (viewMove BottomP) (Just "<alt><shift>Down") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewSplitHorizontal" "Split H_orizontal" Nothing Nothing+ viewSplitHorizontal (Just "<ctrl>2") ActionNormal+ (Just $ MPAppend True) Nothing [GS PaneActiveSens]+ ,AD "ViewSplitVertical" "Split _Vertical" Nothing Nothing+ viewSplitVertical (Just "<ctrl>3") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewCollapse" "_Collapse" Nothing Nothing+ viewCollapse (Just "<ctrl>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 "<alt><shift><ctrl>Left") ActionNormal+ (Just $ MPAppend True) Nothing[GS PaneActiveSens]+ ,AD "ViewTabsRight" "Tabs Right" Nothing Nothing+ (viewTabsPos PosRight) (Just "<alt><shift><ctrl>Right") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewTabsUp" "Tabs Up" Nothing Nothing+ (viewTabsPos PosTop) (Just "<alt><shift><ctrl>Up") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewTabsDown" "Tabs Down" Nothing Nothing+ (viewTabsPos PosBottom) (Just "<alt><shift><ctrl>Down") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]+ ,AD "ViewSwitchTabs" "Tabs On/Off" Nothing Nothing+ viewSwitchTabs (Just "<shift><ctrl>t") ActionNormal+ (Just $ MPAppend False) Nothing [GS PaneActiveSens]++ ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close")+ viewClosePane (Just "<ctrl><shift>q") ActionNormal+ (Just $ MPAppend True) (Just TPFirst) [GS PaneActiveSens]++ ,AD "ToolbarVisible" "Toolbar visible" Nothing Nothing+ toggleToolbar (Just "<alt><shift>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 ()+
+ src/Graphics/Panes.hs view
@@ -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++
+ src/Graphics/Session.hs view
@@ -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+
+ src/Graphics/Statusbar.hs view
@@ -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 ()