module IDE.Session (
saveSession
, saveSessionAs
, saveSessionAsPrompt
, recoverSession
, sessionClosePane
, loadSession
, loadSessionPrompt
, viewFullScreen
, viewDark
) where
import Prelude hiding (catch)
import Graphics.UI.Gtk hiding (showLayout)
import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString)
import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider)
import Control.Applicative ((<$>))
import System.FilePath
import qualified Data.Map as Map
import Data.Maybe
import Data.Typeable
import qualified Data.Set as Set
import IDE.Core.State
import IDE.Utils.GUIUtils
import IDE.Utils.FileUtils
import Text.PrinterParser
import qualified Text.PrettyPrint.HughesPJ as PP
import Graphics.UI.Editor.Parameters
import IDE.TextEditor
import IDE.Pane.Modules
import IDE.Pane.SourceBuffer
import IDE.Pane.Info (InfoState(..), setInfoStyle)
import IDE.Pane.Log (LogState(..))
import IDE.Pane.Preferences
import IDE.Pane.PackageFlags
import IDE.Pane.Search
import IDE.Pane.Grep
import IDE.Pane.HLint
import IDE.Pane.WebKit.Documentation
import IDE.Pane.WebKit.Output
import IDE.Pane.WebKit.Inspect
import IDE.Pane.Files
import IDE.Pane.Breakpoints
import IDE.Pane.Trace
import IDE.Pane.Variables
import IDE.Find
import System.Time (getClockTime)
import IDE.Package (deactivatePackage)
import IDE.Pane.Errors (fillErrorList, ErrorsState(..))
import Control.Exception (catch, SomeException(..))
import IDE.Pane.Workspace (WorkspaceState(..))
import IDE.Workspaces (workspaceOpenThis)
import IDE.Completion (setCompletionSize)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (void, when)
import System.Log.Logger (debugM)
import Data.Text (Text)
import qualified Data.Text as T (pack)
import Data.Traversable (forM)
import Data.Foldable (forM_)
theSessionVersion :: Int
theSessionVersion = 1
data PaneState = BufferSt BufferState
| LogSt LogState
| InfoSt InfoState
| ModulesSt ModulesState
| PrefsSt PrefsState
| FlagsSt FlagsState
| SearchSt SearchState
| FilesSt FilesState
| GrepSt GrepState
| HLintSt HLintState
| DocumentationSt DocumentationState
| OutputSt OutputState
| InspectSt InspectState
| BreakpointsSt BreakpointsState
| TraceSt TraceState
| VariablesSt VariablesState
| ErrorsSt ErrorsState
| WorkspaceSt WorkspaceState
deriving(Eq,Ord,Read,Show)
asPaneState :: RecoverablePane alpha beta gamma => beta -> PaneState
asPaneState s | isJust (cast s :: Maybe BufferState) = BufferSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe LogState) = LogSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe InfoState) = InfoSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe ModulesState) = ModulesSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe PrefsState) = PrefsSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe FlagsState) = FlagsSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe SearchState) = SearchSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe FilesState) = FilesSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe GrepState) = GrepSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe HLintState) = HLintSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe DocumentationState) = DocumentationSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe OutputState) = OutputSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe InspectState) = InspectSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe BreakpointsState) = BreakpointsSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe TraceState) = TraceSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe VariablesState) = VariablesSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe ErrorsState) = ErrorsSt (fromJust $ cast s)
asPaneState s | isJust (cast s :: Maybe WorkspaceState) = WorkspaceSt (fromJust $ cast s)
asPaneState s = error "SaveSession>>asPaneState incomplete cast"
recover :: PanePath -> PaneState -> IDEAction
recover pp (BufferSt p) = void (recoverState pp p)
recover pp (LogSt p) = void (recoverState pp p)
recover pp (InfoSt p) = void (recoverState pp p)
recover pp (ModulesSt p) = void (recoverState pp p)
recover pp (PrefsSt p) = void (recoverState pp p)
recover pp (FlagsSt p) = void (recoverState pp p)
recover pp (SearchSt p) = void (recoverState pp p)
recover pp (FilesSt p) = void (recoverState pp p)
recover pp (GrepSt p) = void (recoverState pp p)
recover pp (HLintSt p) = void (recoverState pp p)
recover pp (DocumentationSt p) = void (recoverState pp p)
recover pp (OutputSt p) = void (recoverState pp p)
recover pp (InspectSt p) = void (recoverState pp p)
recover pp (BreakpointsSt p) = void (recoverState pp p)
recover pp (TraceSt p) = void (recoverState pp p)
recover pp (VariablesSt p) = void (recoverState pp p)
recover pp (ErrorsSt p) = void (recoverState pp p)
recover pp (WorkspaceSt p) = void (recoverState pp p)
sessionClosePane :: IDEAction
sessionClosePane = do
activePane' <- getActivePane
case activePane' of
Nothing -> return ()
Just (pn,_) -> do
(PaneC p) <- paneFromName pn
closePane p
return ()
data SessionState = SessionState {
sessionVersion :: Int
, saveTime :: Text
, layoutS :: PaneLayout
, population :: [(Maybe PaneState,PanePath)]
, windowSize :: (Int,Int)
, fullScreen :: Bool
, dark :: Bool
, completionSize :: (Int,Int)
, workspacePath :: Maybe FilePath
, activePaneN :: Maybe Text
, toolbarVisibleS :: Bool
, findbarState :: (Bool,FindState)
, recentOpenedFiles :: [FilePath]
, recentOpenedWorksp :: [FilePath]
}
defaultSession = SessionState {
sessionVersion = theSessionVersion
, saveTime = ""
, layoutS = VerticalP
TerminalP {
paneGroups = Map.fromList []
, paneTabs = Just TopP
, currentPage = 1
, detachedId = Nothing
, detachedSize = Nothing}
(HorizontalP
TerminalP {
paneGroups = Map.fromList [
("Debug",HorizontalP
TerminalP {
paneGroups = Map.fromList []
, paneTabs = Nothing
, currentPage = 1
, detachedId = Nothing
, detachedSize = Nothing}
TerminalP {
paneGroups = Map.fromList []
, paneTabs = Just TopP
, currentPage = 1
, detachedId = Nothing
, detachedSize = Nothing} 167)]
, paneTabs = Just TopP
, currentPage = 2
, detachedId = Nothing
, detachedSize = Nothing}
TerminalP {
paneGroups = Map.fromList []
, paneTabs = Just TopP
, currentPage = 1
, detachedId = Nothing
, detachedSize = Nothing} 456) 693
, population = [ (Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP BottomP])
, (Just (LogSt LogState),[SplitP RightP,SplitP BottomP])
, (Just (ModulesSt
(ModulesState 200 (SystemScope,False) (Nothing,Nothing)
ExpanderState {
packageExp = ([],[])
, packageExpNoBlack = ([],[])
, packageDExp = ([],[])
, packageDExpNoBlack = ([],[])
, workspaceExp = ([],[])
, workspaceExpNoBlack = ([],[])
, workspaceDExp = ([],[])
, workspaceDExpNoBlack = ([],[])
, systemExp = ([],[])
, systemExpNoBlack = ([],[])})),[SplitP RightP,SplitP TopP])
, (Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP BottomP])]
, windowSize = (1024,768)
, fullScreen = False
, dark = False
, completionSize = (750,400)
, workspacePath = Nothing
, activePaneN = Nothing
, toolbarVisibleS = True
, findbarState = (False,FindState{
entryStr = ""
, entryHist = []
, replaceStr = ""
, replaceHist = []
, caseSensitive = False
, entireWord = False
, wrapAround = True
, regex = False
, lineNr = 1})
, recentOpenedFiles = []
, recentOpenedWorksp = []
}
sessionDescr :: [FieldDescriptionS SessionState]
sessionDescr = [
mkFieldS
(paraName <<<- ParaName "Version of session file format" $ emptyParams)
(PP.text . show)
intParser
sessionVersion
(\ b a -> a{sessionVersion = b})
, mkFieldS
(paraName <<<- ParaName "Time of storage" $ emptyParams)
(PP.text . show)
stringParser
saveTime
(\ b a -> a{saveTime = b})
, mkFieldS
(paraName <<<- ParaName "Layout" $ emptyParams)
(PP.text . show)
readParser
layoutS
(\ b a -> a{layoutS = b})
, mkFieldS
(paraName <<<- ParaName "Population" $ emptyParams)
(PP.text . show)
readParser
population
(\ b a -> a{population = b})
, mkFieldS
(paraName <<<- ParaName "Window size" $ emptyParams)
(PP.text . show)
(pairParser intParser)
windowSize
(\(c,d) a -> a{windowSize = (c,d)})
, mkFieldS
(paraName <<<- ParaName "Full screen" $ emptyParams)
(PP.text . show)
readParser
fullScreen
(\b a -> a{fullScreen = b})
, mkFieldS
(paraName <<<- ParaName "Dark" $ emptyParams)
(PP.text . show)
readParser
dark
(\b a -> a{dark = b})
, mkFieldS
(paraName <<<- ParaName "Completion size" $ emptyParams)
(PP.text . show)
(pairParser intParser)
completionSize
(\(c,d) a -> a{completionSize = (c,d)})
, mkFieldS
(paraName <<<- ParaName "Workspace" $ emptyParams)
(PP.text . show)
readParser
workspacePath
(\fp a -> a{workspacePath = fp})
, mkFieldS
(paraName <<<- ParaName "Active pane" $ emptyParams)
(PP.text . show)
readParser
activePaneN
(\fp a -> a{activePaneN = fp})
, mkFieldS
(paraName <<<- ParaName "Toolbar visible" $ emptyParams)
(PP.text . show)
readParser
toolbarVisibleS
(\fp a -> a{toolbarVisibleS = fp})
, mkFieldS
(paraName <<<- ParaName "FindbarState" $ emptyParams)
(PP.text . show)
readParser
findbarState
(\fp a -> a{findbarState = fp})
, mkFieldS
(paraName <<<- ParaName "Recently opened files" $ emptyParams)
(PP.text . show)
readParser
recentOpenedFiles
(\fp a -> a{recentOpenedFiles = fp})
, mkFieldS
(paraName <<<- ParaName "Recently opened workspaces" $ emptyParams)
(PP.text . show)
readParser
recentOpenedWorksp
(\fp a -> a{recentOpenedWorksp = fp})]
saveSession :: IDEAction
saveSession = do
sessionPath <- liftIO $ getConfigFilePathForSave standardSessionFilename
mbSessionPath2 <- do
ws <- readIDE workspace
case ws of
Nothing -> return Nothing
Just ws -> return $ Just (dropExtension (wsFile ws) ++
leksahSessionFileExtension)
saveSessionAs sessionPath mbSessionPath2
saveSessionAs :: FilePath -> Maybe FilePath -> IDEAction
saveSessionAs sessionPath mbSecondPath = do
forget <- getForgetSession
if forget
then ideMessage Normal (__ "Forget this session")
else do
sysMessage Normal (__ "Now saving session")
bufs <- allBuffers
case filter (\b -> bufferName b == "_Eval.hs") bufs of
[IDEBuffer{sourceView = sv}] -> do
ebuf <- getBuffer sv
setModified ebuf False
_ -> return ()
wdw <- getMainWindow
layout <- mkLayout
population <- getPopulation
size <- liftIO $ windowGetSize wdw
fullScreen <- getFullScreenState
dark <- getDarkState
(completionSize,_) <- readIDE completion
mbWs <- readIDE workspace
activePane' <- getActivePane
let activeP = case activePane' of
Nothing -> Nothing
Just (s,_) -> Just s
(toolbarVisible,_) <- readIDE toolbar
findState <- getFindState
(findbarVisible,_) <- readIDE findbar
timeNow <- liftIO getClockTime
recentFiles' <- readIDE recentFiles
recentWorkspaces' <- readIDE recentWorkspaces
let state = SessionState {
sessionVersion = theSessionVersion
, saveTime = T.pack $ show timeNow
, layoutS = layout
, population = population
, windowSize = size
, fullScreen = fullScreen
, dark = dark
, completionSize = completionSize
, workspacePath = case mbWs of
Nothing -> Nothing
Just ws -> Just (wsFile ws)
, activePaneN = activeP
, toolbarVisibleS = toolbarVisible
, findbarState = (findbarVisible,findState)
, recentOpenedFiles = recentFiles'
, recentOpenedWorksp = recentWorkspaces'}
liftIO $ writeFields sessionPath state sessionDescr
when (isJust mbSecondPath) $
liftIO $ writeFields (fromJust mbSecondPath) state sessionDescr
saveSessionAsPrompt :: IDEAction
saveSessionAsPrompt = do
window <- getMainWindow
response <- liftIO $ do
configFolder <- getConfigDir
chooseSaveFile window (__ "Save Session as") (Just configFolder)
case response of
Just fn -> saveSessionAs (if takeExtension fn == leksahSessionFileExtension
then fn
else addExtension fn leksahSessionFileExtension)
Nothing
Nothing -> return ()
loadSessionPrompt :: IDEAction
loadSessionPrompt = do
window' <- getMainWindow
response <- liftIO $ do
configFolder <- getConfigDir
dialog <- fileChooserDialogNew
(Just $ __ "Select session file")
(Just window')
FileChooserActionOpen
[("gtk-cancel"
,ResponseCancel)
,("gtk-open"
, ResponseAccept)]
fileChooserSetCurrentFolder dialog configFolder
widgetShow dialog
res <- dialogRun dialog
case res of
ResponseAccept -> do
fileName <- fileChooserGetFilename dialog
widgetHide dialog
return fileName
_ -> do
widgetHide dialog
return Nothing
case response of
Just fn -> loadSession fn
Nothing -> return ()
loadSession :: FilePath -> IDEAction
loadSession sessionPath = do
liftIO $ debugM "leksah" "loadSession"
saveSession :: IDEAction
deactivatePackage
recentFiles' <- readIDE recentFiles
recentWorkspaces' <- readIDE recentWorkspaces
b <- fileCloseAll (\_ -> return True)
when b $ do
detachedCloseAll
paneCloseAll
groupsCloseAll
viewCollapseAll
recoverSession sessionPath
modifyIDE_ (\ ide -> ide{ recentFiles = recentFiles'
, recentWorkspaces = recentWorkspaces'})
return ()
detachedCloseAll :: IDEAction
detachedCloseAll = do
windows <- getWindows
liftIO $ mapM_ widgetDestroy (tail windows)
paneCloseAll :: IDEAction
paneCloseAll = do
panes' <- getPanesSt
mapM_ (\ (PaneC p) -> closePane p) (Map.elems panes')
groupsCloseAll :: IDEAction
groupsCloseAll = do
layout' <- getLayout
mapM_ closeGroup (Set.toList $ allGroupNames layout')
viewCollapseAll :: IDEAction
viewCollapseAll = do
layout' <- getLayout
case layout' of
TerminalP {} -> return ()
VerticalP {} -> viewCollapse' [SplitP LeftP]
HorizontalP {} -> viewCollapse' [SplitP TopP]
mkLayout :: IDEM PaneLayout
mkLayout = do
rawLayout <- getLayout
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 (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 :: IDEM[(Maybe PaneState,PanePath)]
getPopulation = do
paneMap <- getPaneMapSt
mapM (\ (pn,v) -> do
(PaneC p) <- paneFromName pn
mbSt <- saveState p
case mbSt of
Nothing -> return (Nothing, fst v)
Just st -> return (Just (asPaneState st), fst v))
$ Map.toList paneMap
getActive :: IDEM(Maybe FilePath)
getActive = do
active <- readIDE activePack
case active of
Nothing -> return Nothing
Just p -> return (Just (ipdCabalFile p))
recoverSession :: FilePath -> IDEM (Bool,Bool)
recoverSession sessionPath = catchIDE (do
liftIO $ debugM "leksah" "recoverSession"
wdw <- getMainWindow
sessionSt <- liftIO $ catch
(readFields sessionPath sessionDescr defaultSession)
(\(_ :: SomeException) -> return defaultSession)
liftIO $ uncurry (windowSetDefaultSize wdw) (windowSize sessionSt)
applyLayout (layoutS sessionSt)
workspaceOpenThis False (workspacePath sessionSt)
liftIO $ debugM "leksah" "recoverSession calling populate"
populate (population sessionSt)
liftIO $ debugM "leksah" "recoverSession calling setCurrentPages"
setCurrentPages (layoutS sessionSt)
when (isJust (activePaneN sessionSt)) $ do
mbPane <- mbPaneFromName (fromJust (activePaneN sessionSt))
case mbPane of
Nothing -> return ()
Just (PaneC p) -> makeActive p
liftIO $ debugM "leksah" "recoverSession setting up toolbars"
setFindState ((snd . findbarState) sessionSt)
if toolbarVisibleS sessionSt
then showToolbar
else hideToolbar
if (fst . findbarState) sessionSt
then showFindbar
else hideFindbar
setCompletionSize (completionSize sessionSt)
modifyIDE_ (\ide -> ide{recentFiles = recentOpenedFiles sessionSt,
recentWorkspaces = recentOpenedWorksp sessionSt})
setFullScreenState (fullScreen sessionSt)
viewFullScreen
setDarkState (dark sessionSt)
viewDark
liftIO $ debugM "leksah" "recoverSession done"
return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt))
(\ (e :: SomeException) -> do
sysMessage Normal (T.pack $ show e)
return (True,True))
applyLayout :: PaneLayout -> IDEAction
applyLayout layoutS = do
old <- getLayout
case old of
TerminalP {} -> applyLayout' layoutS []
otherwise -> throwIDE (__ "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) ->
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 :: [(Maybe PaneState,PanePath)] -> IDEAction
populate = mapM_ (\ (mbPs,pp) -> forM_ mbPs (recover pp))
setCurrentPages :: PaneLayout -> IDEAction
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) ->
setCurrentPages' g (GroupP group : p)
when (ind >= 0) $ do
nb <- getNotebook (reverse p)
liftIO $ notebookSetCurrentPage nb ind
viewFullScreen :: IDEAction
viewFullScreen = do
isFullScreen <- getFullScreenState
mbWindow <- getActiveWindow
case (mbWindow, isFullScreen) of
(Nothing, _) -> return ()
(Just window, True) -> liftIO $ windowFullscreen window
(Just window, False) -> liftIO $ windowUnfullscreen window
viewDark :: IDEAction
viewDark = getDarkState >>= setDark
getActiveSettings :: PaneMonad alpha => alpha (Maybe Settings)
getActiveSettings = do
mbScreen <- getActiveScreen
case mbScreen of
Nothing -> return Nothing
Just screen -> liftIO $ Just <$> settingsGetForScreen screen
setDark :: Bool -> IDEM ()
setDark dark = do
setInfoStyle
fillErrorList False
prefs <- readIDE prefs
buffers <- allBuffers
mapM_ updateStyle' buffers
mbSettings <- getActiveSettings
case mbSettings of
Just settings -> liftIO $ settingsSetLongProperty
settings
("gtk-application-prefer-dark-theme" :: Text)
(if dark then 1 else 0)
"Leksah"
Nothing -> return ()