billeksah-pane-1.0.0: src/Graphics/Frame.hs
{-# 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