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