module IDE.Core.State (
window
, errorRefs
, breakpointRefs
, contextRefs
, currentError
, currentBreak
, currentContext
, setCurrentError
, setCurrentBreak
, setCurrentContext
, isInterpreting
, isStartingOrClosing
, triggerEventIDE
, deactivatePane
, readIDE
, modifyIDE
, modifyIDE_
, withIDE
, getIDE
, throwIDE
, reifyIDE
, reflectIDE
, reflectIDEI
, catchIDE
, postSyncIDE
, postAsyncIDE
, forkIDE
, sysMessage
, MessageLevel(..)
, ideMessage
, logMessage
, withoutRecordingDo
, activeProjectDir
, changePackage
, liftYiControl
, liftYi
, module IDE.Core.Types
, module IDE.Core.CTypes
, module IDE.Utils.Utils
, module Graphics.UI.Frame.Panes
, module Graphics.UI.Frame.ViewFrame
) where
import Graphics.UI.Gtk hiding (get)
import Graphics.UI.Gtk.SourceView.SourceView ()
import Data.IORef
import Control.Exception
import Prelude hiding (catch)
import Control.Monad.IO.Class (MonadIO, liftIO)
import IDE.Core.Types
import Graphics.UI.Frame.Panes
import Graphics.UI.Frame.ViewFrame
import Control.Event
import System.IO
import Data.Maybe (isJust)
import System.FilePath (dropFileName)
import IDE.Core.CTypes
import Control.Concurrent (forkIO)
import IDE.Utils.Utils
import qualified Data.Map as Map (empty, lookup)
import Data.Typeable(Typeable)
import qualified IDE.YiConfig as Yi
import Data.Enumerator (runIteratee, Iteratee(..))
import qualified Data.Enumerator as E
(returnI, Step(..), yield, continue)
import Control.Monad (liftM, when)
import Control.Monad.Trans.Reader (ask, ReaderT(..))
instance PaneMonad IDEM where
getFrameState = readIDE frameState
setFrameState v = modifyIDE_ (\ide -> ide{frameState = v})
runInIO f = reifyIDE (\ideRef -> return (\v -> reflectIDE (f v) ideRef))
panePathForGroup id = do
prefs <- readIDE prefs
case id `lookup` (categoryForPane prefs) of
Just group -> case group `lookup` (pathForCategory prefs) of
Nothing -> return (defaultPath prefs)
Just p -> return p
Nothing -> return (defaultPath prefs)
getThisPane = getPanePrim
getOrBuildThisPane ePpoPid = do
mbPane <- getPanePrim
case mbPane of
Nothing -> do
pp <- case ePpoPid of
Right pId -> getBestPathForId pId
Left ppp -> do
layout <- getLayout
return (getBestPanePath ppp layout)
nb <- getNotebook pp
buildPane pp nb builder
Just pane -> return (Just pane)
displayThisPane pane shallGrabFocus = do
liftIO $ bringPaneToFront pane
when shallGrabFocus $ liftIO $ widgetGrabFocus $ getTopWidget pane
buildThisPane panePath notebook builder = do
windows <- getWindows
(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
notebookInsertOrdered notebook (getTopWidget buf) (paneName buf) Nothing False
addPaneAdmin buf cids panePath
liftIO $ do
widgetSetName (getTopWidget buf) (paneName buf)
widgetShowAll (getTopWidget buf)
widgetGrabFocus (getTopWidget buf)
bringPaneToFront buf
return (Just buf)
else return Nothing
activateThisPane pane conn = do
mbAP <- getActivePane
case mbAP of
Just (pn,_) | pn == paneName pane -> return ()
_ -> do
deactivatePaneWithout
triggerEventIDE (StatusbarChanged [CompartmentPane (Just (PaneC pane))])
liftIO $ bringPaneToFront pane
setActivePane (Just (paneName pane,conn))
trigger (Just (paneName pane))
(case mbAP of
Nothing -> Nothing
Just (pn,_) -> Just pn)
modifyIDE_ updateRecent
return ()
where
updateRecent (ide@IDE{currentState = IsFlipping _}) = ide
updateRecent ide = ide{recentPanes = paneName pane : filter (/= paneName pane) (recentPanes ide)}
trigger :: Maybe String -> Maybe String -> IDEAction
trigger s1 s2 = do
triggerEventIDE (RecordHistory ((PaneSelected s1), PaneSelected s2))
triggerEventIDE (Sensitivity [(SensitivityEditor, False)])
return ()
closeThisPane pane = do
(panePath,_) <- 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
deactivatePaneIfActive pane
liftIO $ do
notebookRemovePage nb i
widgetDestroy (getTopWidget pane)
removePaneAdmin pane
modifyIDE_ (\ide -> ide{recentPanes = filter (/= paneName pane) (recentPanes ide)})
return True
data MessageLevel = Silent | Normal | High
deriving (Eq,Ord,Show)
sysMessage :: MonadIO m => MessageLevel -> String -> m ()
sysMessage ml str = liftIO $ do
putStrLn str
hFlush stdout
ideMessage :: MessageLevel -> String -> IDEAction
ideMessage level str = do
triggerEventIDE (LogMessage (str ++ "\n") LogTag)
liftIO $ sysMessage level str
logMessage :: String -> LogTag -> IDEAction
logMessage str tag = do
triggerEventIDE (LogMessage (str ++ "\n") tag)
return ()
data IDEException = IDEException String
deriving Typeable
instance Show IDEException where
show (IDEException str) = str
instance Exception IDEException
throwIDE str = throw (IDEException str)
window = head . windows
activeProjectDir :: IDEM FilePath
activeProjectDir = do
activePack' <- readIDE activePack
case activePack' of
Nothing -> return "."
Just pack -> return (dropFileName (ipdCabalFile pack))
errorRefs :: IDE -> [LogRef]
errorRefs = (filter ((\t -> t == ErrorRef || t == WarningRef) . logRefType)) . allLogRefs
breakpointRefs :: IDE -> [LogRef]
breakpointRefs = (filter ((== BreakpointRef) . logRefType)) . allLogRefs
contextRefs :: IDE -> [LogRef]
contextRefs = (filter ((== ContextRef) . logRefType)) . allLogRefs
currentError = (\(e,_,_)-> e) . currentEBC
currentBreak = (\(_,b,_)-> b) . currentEBC
currentContext = (\(_,_,c)-> c) . currentEBC
setCurrentError e = do
modifyIDE_ (\ide -> ide{currentEBC = (e, currentBreak ide, currentContext ide)})
triggerEventIDE (CurrentErrorChanged e) >> return ()
setCurrentBreak b = do
modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, b, currentContext ide)})
triggerEventIDE (CurrentBreakChanged b) >> return ()
setCurrentContext c = modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, currentBreak ide, c)})
isStartingOrClosing :: IDEState -> Bool
isStartingOrClosing IsStartingUp = True
isStartingOrClosing IsShuttingDown = True
isStartingOrClosing _ = False
isInterpreting :: IDEM Bool
isInterpreting = do
readIDE debugState >>= \mb -> return (isJust mb)
triggerEventIDE :: IDEEvent -> IDEM IDEEvent
triggerEventIDE e = ask >>= \ideR -> triggerEvent ideR e
reifyIDE :: (IDERef -> IO a) -> IDEM a
reifyIDE = ReaderT
reflectIDE :: IDEM a -> IDERef -> IO a
reflectIDE c ideR = runReaderT c ideR
reflectIDEI :: Iteratee a IDEM b -> IDERef -> Iteratee a IO b
reflectIDEI c ideR = loop c where
loop x = do
s <- liftIO $ reflectIDE (runIteratee x) ideR
case s of
E.Continue f -> E.continue $ loop . f
E.Yield a b -> E.yield a b
E.Error e -> E.returnI $ E.Error e
liftYiControl :: Yi.ControlM a -> IDEM a
liftYiControl f = do
control <- readIDE yiControl
liftIO $ Yi.runControl f control
liftYi :: Yi.YiM a -> IDEM a
liftYi = liftYiControl . Yi.liftYi
catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a
catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler)
forkIDE :: IDEAction -> IDEAction
forkIDE block = reifyIDE (\ideR -> forkIO (reflectIDE block ideR) >> return ())
postSyncIDE :: IDEM a -> IDEM a
postSyncIDE f = reifyIDE (\ideR -> postGUISync (reflectIDE f ideR))
postAsyncIDE :: IDEM () -> IDEM ()
postAsyncIDE f = reifyIDE (\ideR -> postGUIAsync (reflectIDE f ideR))
readIDE :: (IDE -> beta) -> IDEM beta
readIDE f = do
e <- ask
liftIO $ liftM f (readIORef e)
modifyIDE_ :: (IDE -> IDE) -> IDEM ()
modifyIDE_ f = let f' a = (f a,()) in do
e <- ask
liftIO (atomicModifyIORef e f')
modifyIDE :: (IDE -> (IDE,beta)) -> IDEM beta
modifyIDE f = do
e <- ask
liftIO (atomicModifyIORef e f)
withIDE :: (IDE -> IO alpha) -> IDEM alpha
withIDE f = do
e <- ask
liftIO $ f =<< readIORef e
getIDE :: IDEM(IDE)
getIDE = do
e <- ask
st <- liftIO $ readIORef e
return st
withoutRecordingDo :: IDEAction -> IDEAction
withoutRecordingDo act = do
(b,l,n) <- readIDE guiHistory
if not b then do
modifyIDE_ (\ide -> ide{guiHistory = (True,l,n)})
act
(b,l,n) <- readIDE guiHistory
modifyIDE_ (\ide -> ide{guiHistory = (False,l,n)})
else act
deactivatePane :: IDEAction
deactivatePane = do
mbAP <- getActivePane
case mbAP of
Nothing -> return ()
Just (pn, _) -> do
deactivatePaneWithout
triggerEventIDE (RecordHistory (PaneSelected Nothing,
PaneSelected (Just pn)))
triggerEventIDE (Sensitivity [(SensitivityEditor, False)])
return ()
deactivatePaneWithout :: IDEAction
deactivatePaneWithout = do
triggerEventIDE (StatusbarChanged [CompartmentPane Nothing])
mbAP <- getActivePane
case mbAP of
Just (_,signals) -> liftIO $do
signalDisconnectAll signals
Nothing -> return ()
setActivePane Nothing
deactivatePaneIfActive :: RecoverablePane alpha beta IDEM => alpha -> IDEAction
deactivatePaneIfActive pane = do
mbActive <- getActivePane
case mbActive of
Nothing -> return ()
Just (n,_) -> if n == paneName pane
then deactivatePane
else return ()
changePackage :: IDEPackage -> IDEAction
changePackage ideP@IDEPackage{ipdCabalFile = file} = do
oldWorkspace <- readIDE workspace
case oldWorkspace of
Nothing -> return ()
Just ws -> do
let ps = map exchange (wsPackages ws)
modifyIDE_ (\ide -> ide{workspace = Just ws {wsPackages = ps},
bufferProjCache = Map.empty})
mbActivePack <- readIDE activePack
case mbActivePack of
Just activePack | ipdCabalFile ideP == ipdCabalFile activePack ->
modifyIDE_ (\ide -> ide{activePack = Just ideP})
_ -> return ()
where
exchange p | ipdCabalFile p == file = ideP
| otherwise = p