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
, onIDE
, forkIDE
, sysMessage
, MessageLevel(..)
, ideMessage
, logMessage
, withoutRecordingDo
, changePackage
, liftYiControl
, liftYi
, leksahSubDir
, leksahOrPackageDir
, getDataDir
, P.version
, module Reexported
) 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 as Reexported
import Graphics.UI.Frame.Panes as Reexported
import Graphics.UI.Frame.ViewFrame as Reexported
import Control.Event
import System.IO
import Data.Maybe (isJust)
import System.FilePath
(dropFileName, takeDirectory, (</>), takeFileName)
import IDE.Core.CTypes as Reexported
import Control.Concurrent (forkIO)
import IDE.Utils.Utils as Reexported
import qualified Data.Map as Map (empty, lookup)
import Data.Typeable(Typeable)
import qualified IDE.YiConfig as Yi
import Data.Conduit (($$))
import qualified Data.Conduit as C
(transPipe, Sink, awaitForever, yield, leftover, ($$))
import qualified Data.Conduit.List as CL
(sourceList)
import Control.Monad (void, liftM, when)
import Control.Monad.Trans.Reader (ask, ReaderT(..))
import qualified Paths_leksah as P
import System.Environment.Executable (getExecutablePath)
import System.Directory (doesDirectoryExist)
import Data.Text (Text)
import qualified Data.Text as T (unpack)
import Data.Monoid ((<>))
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 Text -> Maybe Text -> 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 " ++ T.unpack (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 -> Text -> m ()
sysMessage ml str = liftIO $ do
putStrLn $ T.unpack str
hFlush stdout
ideMessage :: MonadIDE m => MessageLevel -> Text -> m ()
ideMessage level str = do
liftIO $ sysMessage level str
triggerEventIDE (LogMessage (str <> "\n") LogTag)
return ()
logMessage :: MonadIDE m => Text -> LogTag -> m ()
logMessage str tag = do
triggerEventIDE (LogMessage (str <> "\n") tag)
return ()
data IDEException = IDEException Text
deriving Typeable
instance Show IDEException where
show (IDEException str) = T.unpack str
instance Exception IDEException
throwIDE str = throw (IDEException str)
window = head . windows
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)
setCurrentBreak b = do
modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, b, currentContext ide)})
triggerEventIDE_ (CurrentBreakChanged b)
setCurrentContext c = modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, currentBreak ide, c)})
isStartingOrClosing :: IDEState -> Bool
isStartingOrClosing IsStartingUp = True
isStartingOrClosing IsShuttingDown = True
isStartingOrClosing _ = False
isInterpreting :: MonadIDE m => m Bool
isInterpreting =
readIDE debugState >>= \mb -> return (isJust mb)
triggerEventIDE :: MonadIDE m => IDEEvent -> m IDEEvent
triggerEventIDE e = liftIDE $ ask >>= \ideR -> triggerEvent ideR e
triggerEventIDE_ :: MonadIDE m => IDEEvent -> m ()
triggerEventIDE_ = void . triggerEventIDE
reifyIDE :: MonadIDE m => (IDERef -> IO a) -> m a
reifyIDE = liftIDE . ReaderT
reflectIDE :: IDEM a -> IDERef -> IO a
reflectIDE = runReaderT
reflectIDEI :: C.Sink a IDEM () -> IDERef -> C.Sink a IO ()
reflectIDEI c ideR = C.transPipe (`reflectIDE` ideR) c
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 (void . forkIO . reflectIDE block)
postSyncIDE :: IDEM a -> IDEM a
postSyncIDE f = reifyIDE (postGUISync . reflectIDE f)
postAsyncIDE :: IDEM () -> IDEM ()
postAsyncIDE f = reifyIDE (postGUIAsync . reflectIDE f)
onIDE obj signal callback = do
ideRef <- ask
liftIO (obj `on` signal $ runReaderT callback ideRef)
readIDE :: MonadIDE m => (IDE -> beta) -> m beta
readIDE f = do
e <- liftIDE ask
liftIO $ liftM f (readIORef e)
modifyIDE_ :: MonadIDE m => (IDE -> IDE) -> m ()
modifyIDE_ f = let f' a = (f a,()) in do
e <- liftIDE ask
liftIO (atomicModifyIORef e f')
modifyIDE :: MonadIDE m => (IDE -> (IDE,beta)) -> m beta
modifyIDE f = do
e <- liftIDE ask
liftIO (atomicModifyIORef e f)
withIDE :: MonadIDE m => (IDE -> IO alpha) -> m alpha
withIDE f = do
e <- liftIDE ask
liftIO $ f =<< readIORef e
getIDE :: MonadIDE m => m IDE
getIDE = liftIDE ask >>= (liftIO . readIORef)
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,_) -> when (n == paneName pane) deactivatePane
changePackage :: IDEPackage -> IDEAction
changePackage ideP = 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 | key ideP == key activePack ->
modifyIDE_ (\ide -> ide{activePack = Just ideP})
_ -> return ()
where
key = ipdBuildDir
idePKey = key ideP
exchange p | key p == idePKey = ideP
| otherwise = p
leksahSubDir :: FilePath
-> IO (Maybe FilePath)
leksahSubDir subDir = do
exePath <- getExecutablePath
if takeFileName exePath == "leksah.exe"
then do
let dataDir = takeDirectory (takeDirectory exePath) </> subDir
exists <- doesDirectoryExist dataDir
return (if exists then Just dataDir else Nothing)
else return Nothing
leksahOrPackageDir :: FilePath
-> IO FilePath
-> IO FilePath
leksahOrPackageDir subDir getPackageDir = do
mbResult <- leksahSubDir subDir
case mbResult of
Just result -> return result
Nothing -> getPackageDir
getDataDir :: IO FilePath
getDataDir = leksahOrPackageDir "leksah" P.getDataDir