module IDE.Core.Types (
IDE(..)
, IDEState(..)
, IDERef
, IDEM
, IDEEventM
, IDEAction
, IDEEvent(..)
, MonadIDE
, liftIDE
, (?>>=)
, WorkspaceM
, WorkspaceAction
, runWorkspace
, PackageM
, PackageAction
, runPackage
, DebugM
, DebugAction
, runDebug
, IDEPackage(..)
, ipdBuildDir
, ipdAllDirs
, Workspace(..)
, wsAllPackages
, VCSConf
, ActionDescr(..)
, ActionString
, KeyString
, Prefs(..)
, cabalCommand
, EditorStyle(..)
, editorStyle
, LogRefType(..)
, LogRef(..)
, logRefRootPath
, logRefFilePath
, logRefFullFilePath
, isError
, isBreakpoint
, displaySrcSpan
, colorHexString
, SearchHint(..)
, CandyTable(..)
, CandyTableForth
, CandyTableBack
, KeymapI(..)
, SpecialKeyTable
, SpecialKeyCons
, PackageDescrCache
, ModuleDescrCache
, CompletionWindow(..)
, LogLaunch(..)
, LogLaunchData(..)
, LogTag(..)
, GUIHistory
, GUIHistory'(..)
, SensitivityMask(..)
, SearchMode(..)
, StatusbarCompartment(..)
) where
import qualified IDE.YiConfig as Yi
import Graphics.UI.Gtk
(TextBuffer, MenuItem, Window(..), KeyVal(..), Color(..), Menu(..),
TreeView(..), ListStore(..), Toolbar(..))
import Data.Unique (newUnique, Unique(..))
import Graphics.UI.Frame.Panes
import Distribution.Package
(PackageIdentifier(..), Dependency(..))
import Distribution.PackageDescription (BuildInfo)
import Data.Map (Map(..))
import Data.Set (Set(..))
import Data.List (nubBy)
import Control.Concurrent (MVar)
import Distribution.ModuleName (ModuleName(..))
import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))
import Graphics.UI.Gtk.ActionMenuToolbar.UIManager(MergeId)
import System.Time (ClockTime(..))
import Distribution.Simple (Extension(..))
import IDE.Utils.Tool (ToolState(..), ProcessHandle)
import Data.IORef (writeIORef, readIORef, IORef(..))
import Numeric (showHex)
import Control.Event
(EventSelector(..), EventSource(..), Event(..))
import System.FilePath (dropFileName, (</>))
import IDE.Core.CTypes
import IDE.StrippedPrefs(RetrieveStrategy)
import System.IO (Handle)
import Distribution.Text(disp)
import Text.PrettyPrint (render)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Time (UTCTime(..))
import qualified VCSWrapper.Common as VCS
import qualified VCSGui.Common as VCSGUI
import qualified Data.Map as Map (Map)
import Data.Typeable (Typeable)
import Foreign (Ptr)
import Control.Monad.Reader.Class (MonadReader(..))
import Data.Text (Text)
import qualified Data.Text as T (unpack)
import Language.Haskell.HLint3 (Idea(..))
import Data.Function (on)
import Control.Concurrent.STM.TVar (TVar)
import Data.Sequence (Seq)
data IDE = IDE {
frameState :: FrameState IDEM
, recentPanes :: [PaneName]
, specialKeys :: SpecialKeyTable IDERef
, specialKey :: SpecialKeyCons IDERef
, candy :: CandyTable
, prefs :: Prefs
, workspace :: Maybe Workspace
, activePack :: Maybe IDEPackage
, activeExe :: Maybe Text
, bufferProjCache :: Map FilePath [IDEPackage]
, allLogRefs :: Seq LogRef
, currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef)
, currentHist :: Int
, systemInfo :: Maybe GenScope
, packageInfo :: Maybe (GenScope, GenScope)
, workspaceInfo :: Maybe (GenScope, GenScope)
, workspInfoCache :: PackageDescrCache
, handlers :: Map Text [(Unique, IDEEvent -> IDEM IDEEvent)]
, currentState :: IDEState
, guiHistory :: (Bool,[GUIHistory],Int)
, findbar :: (Bool,Maybe (Toolbar,ListStore Text))
, toolbar :: (Bool,Maybe Toolbar)
, recentFiles :: [FilePath]
, recentWorkspaces :: [FilePath]
, runningTool :: Maybe ProcessHandle
, debugState :: Maybe (IDEPackage, ToolState)
, completion :: ((Int, Int), Maybe CompletionWindow)
, yiControl :: Yi.Control
, serverQueue :: Maybe (MVar (ServerCommand, ServerAnswer -> IDEM ()))
, server :: Maybe Handle
, hlintQueue :: Maybe (TVar [Either FilePath FilePath])
, vcsData :: (Map FilePath MenuItem, Maybe (Maybe Text))
, logLaunches :: Map.Map Text LogLaunchData
, autoCommand :: IDEAction
, autoURI :: Maybe Text
}
type IDERef = IORef IDE
type IDEM = ReaderT IDERef IO
type IDEAction = IDEM ()
data IDEState =
IsStartingUp
| IsShuttingDown
| IsRunning
| IsFlipping TreeView
| IsCompleting Connections
class (Functor m, Monad m, MonadIO m) => MonadIDE m where
liftIDE :: IDEM a -> m a
instance MonadIDE IDEM where
liftIDE = id
instance MonadIDE WorkspaceM where
liftIDE = lift
(?>>=) :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
a ?>>= b = do
mA <- a
case mA of
Just v -> b v
Nothing -> return ()
type IDEEventM t = ReaderT IDERef (ReaderT (Ptr t) IO)
instance MonadIDE (IDEEventM t) where
liftIDE f = do
ideR <- ask
liftIO $ runReaderT f ideR
type WorkspaceM = ReaderT Workspace IDEM
type WorkspaceAction = WorkspaceM ()
runWorkspace :: WorkspaceM a -> Workspace -> IDEM a
runWorkspace = runReaderT
type PackageM = ReaderT IDEPackage WorkspaceM
type PackageAction = PackageM ()
instance MonadIDE PackageM where
liftIDE = lift . lift
runPackage :: PackageM a -> IDEPackage -> WorkspaceM a
runPackage = runReaderT
type DebugM = ReaderT (IDEPackage, ToolState) IDEM
type DebugAction = DebugM ()
runDebug :: DebugM a -> (IDEPackage, ToolState) -> IDEM a
runDebug = runReaderT
data IDEEvent =
InfoChanged Bool
| UpdateWorkspaceInfo
| SelectInfo Text Bool
| SelectIdent Descr
| LogMessage Text LogTag
| RecordHistory GUIHistory
| Sensitivity [(SensitivityMask,Bool)]
| SearchMeta Text
| StartFindInitial
| GotoDefinition Descr
| LoadSession FilePath
| SaveSession FilePath
| UpdateRecent
| VariablesChanged
| ErrorChanged Bool
| ErrorAdded Bool Int LogRef
| CurrentErrorChanged (Maybe LogRef)
| BreakpointChanged
| CurrentBreakChanged (Maybe LogRef)
| TraceChanged
| GetTextPopup (Maybe (IDERef -> Menu -> IO ()))
| StatusbarChanged [StatusbarCompartment]
| WorkspaceChanged Bool Bool
| SelectSrcSpan (Maybe SrcSpan)
| SavedFile FilePath
instance Event IDEEvent Text where
getSelector (InfoChanged _) = "InfoChanged"
getSelector UpdateWorkspaceInfo = "UpdateWorkspaceInfo"
getSelector (LogMessage _ _) = "LogMessage"
getSelector (SelectInfo _ _) = "SelectInfo"
getSelector (SelectIdent _) = "SelectIdent"
getSelector (RecordHistory _) = "RecordHistory"
getSelector (Sensitivity _) = "Sensitivity"
getSelector (SearchMeta _) = "SearchMeta"
getSelector (StartFindInitial) = "StartFindInitial"
getSelector (GotoDefinition _) = "GotoDefinition"
getSelector (LoadSession _) = "LoadSession"
getSelector (SaveSession _) = "SaveSession"
getSelector UpdateRecent = "UpdateRecent"
getSelector VariablesChanged = "VariablesChanged"
getSelector (ErrorChanged _) = "ErrorChanged"
getSelector (ErrorAdded _ _ _) = "ErrorAdded"
getSelector (CurrentErrorChanged _) = "CurrentErrorChanged"
getSelector BreakpointChanged = "BreakpointChanged"
getSelector (CurrentBreakChanged _) = "CurrentBreakChanged"
getSelector TraceChanged = "TraceChanged"
getSelector (GetTextPopup _) = "GetTextPopup"
getSelector (StatusbarChanged _) = "StatusbarChanged"
getSelector (WorkspaceChanged _ _) = "WorkspaceChanged"
getSelector (SelectSrcSpan _) = "SelectSrcSpan"
getSelector (SavedFile _) = "SavedFile"
instance EventSource IDERef IDEEvent IDEM Text where
canTriggerEvent _ "InfoChanged" = True
canTriggerEvent _ "UpdateWorkspaceInfo" = True
canTriggerEvent _ "LogMessage" = True
canTriggerEvent _ "SelectInfo" = True
canTriggerEvent _ "SelectIdent" = True
canTriggerEvent _ "RecordHistory" = True
canTriggerEvent _ "Sensitivity" = True
canTriggerEvent _ "DescrChoice" = True
canTriggerEvent _ "SearchMeta" = True
canTriggerEvent _ "StartFindInitial" = True
canTriggerEvent _ "SearchSymbolDialog" = True
canTriggerEvent _ "GotoDefinition" = True
canTriggerEvent _ "LoadSession" = True
canTriggerEvent _ "SaveSession" = True
canTriggerEvent _ "UpdateRecent" = True
canTriggerEvent _ "VariablesChanged" = True
canTriggerEvent _ "ErrorChanged" = True
canTriggerEvent _ "ErrorAdded" = True
canTriggerEvent _ "CurrentErrorChanged" = True
canTriggerEvent _ "BreakpointChanged" = True
canTriggerEvent _ "CurrentBreakChanged" = True
canTriggerEvent _ "TraceChanged" = True
canTriggerEvent _ "GetTextPopup" = True
canTriggerEvent _ "StatusbarChanged" = True
canTriggerEvent _ "WorkspaceChanged" = True
canTriggerEvent _ "SelectSrcSpan" = True
canTriggerEvent _ "SavedFile" = True
canTriggerEvent _ _ = False
getHandlers ideRef = do
ide <- liftIO $ readIORef ideRef
return (handlers ide)
setHandlers ideRef nh = do
ide <- liftIO $ readIORef ideRef
liftIO $ writeIORef ideRef (ide {handlers= nh})
myUnique _ =
liftIO newUnique
instance EventSelector Text
data IDEPackage = IDEPackage {
ipdPackageId :: PackageIdentifier
, ipdCabalFile :: FilePath
, ipdDepends :: [Dependency]
, ipdModules :: Map ModuleName BuildInfo
, ipdHasLibs :: Bool
, ipdExes :: [Text]
, ipdTests :: [Text]
, ipdBenchmarks :: [Text]
, ipdMain :: [(FilePath, BuildInfo, Bool)]
, ipdExtraSrcs :: Set FilePath
, ipdSrcDirs :: [FilePath]
, ipdExtensions :: [Extension]
, ipdConfigFlags :: [Text]
, ipdBuildFlags :: [Text]
, ipdTestFlags :: [Text]
, ipdHaddockFlags :: [Text]
, ipdExeFlags :: [Text]
, ipdInstallFlags :: [Text]
, ipdRegisterFlags :: [Text]
, ipdUnregisterFlags :: [Text]
, ipdSdistFlags :: [Text]
, ipdSandboxSources :: [IDEPackage]
}
deriving (Eq)
instance Show IDEPackage where
show p = show "IDEPackage for " ++ (render . disp) (ipdPackageId p)
instance Ord IDEPackage where
compare x y = compare (ipdPackageId x) (ipdPackageId y)
ipdBuildDir :: IDEPackage -> FilePath
ipdBuildDir = dropFileName . ipdCabalFile
ipdAllDirs :: IDEPackage -> [FilePath]
ipdAllDirs p = ipdBuildDir p : (ipdSandboxSources p >>= ipdAllDirs)
data Workspace = Workspace {
wsVersion :: Int
, wsSaveTime :: Text
, wsName :: Text
, wsFile :: FilePath
, wsPackages :: [IDEPackage]
, wsPackagesFiles :: [FilePath]
, wsActivePackFile:: Maybe FilePath
, wsActiveExe :: Maybe Text
, wsNobuildPack :: [IDEPackage]
, packageVcsConf :: Map FilePath VCSConf
} deriving Show
wsAllPackages :: Workspace -> [IDEPackage]
wsAllPackages w = nubBy ((==) `on` ipdCabalFile) $ wsPackages w ++ (wsPackages w >>= ipdSandboxSources)
data ActionDescr alpha = AD {
name :: ActionString
, label :: Text
, tooltip :: Maybe Text
, stockID :: Maybe Text
, action :: ReaderT alpha IO ()
, accelerator :: [KeyString]
, isToggle :: Bool
}
type ActionString = Text
type KeyString = Text
data Prefs = Prefs {
prefsFormat :: Int
, prefsSaveTime :: Text
, showLineNumbers :: Bool
, rightMargin :: (Bool, Int)
, tabWidth :: Int
, wrapLines :: Bool
, sourceCandy :: (Bool,Text)
, keymapName :: Text
, forceLineEnds :: Bool
, removeTBlanks :: Bool
, textviewFont :: Maybe Text
, sourceStyle :: (Bool, Text)
, foundBackgroundLight :: Color
, matchBackgroundLight :: Color
, contextBackgroundLight :: Color
, breakpointBackgroundLight :: Color
, lintBackgroundLight :: Color
, foundBackgroundDark :: Color
, matchBackgroundDark :: Color
, contextBackgroundDark :: Color
, breakpointBackgroundDark :: Color
, lintBackgroundDark :: Color
, autoLoad :: Bool
, textEditorType :: Text
, logviewFont :: Maybe Text
, defaultSize :: (Int,Int)
, browser :: Text
, pathForCategory :: [(Text, PanePath)]
, defaultPath :: PanePath
, categoryForPane :: [(Text, Text)]
, packageBlacklist :: [Dependency]
, collectAtStart :: Bool
, useCtrlTabFlipping :: Bool
, docuSearchURL :: Text
, completeRestricted :: Bool
, saveAllBeforeBuild :: Bool
, jumpToWarnings :: Bool
, useVado :: Bool
, useCabalDev :: Bool
, backgroundBuild :: Bool
, runUnitTests :: Bool
, makeMode :: Bool
, singleBuildWithoutLinking :: Bool
, dontInstallLast :: Bool
, printEvldWithShow :: Bool
, breakOnException :: Bool
, breakOnError :: Bool
, printBindResult :: Bool
, serverIP :: Text
, showHiddenFiles :: Bool
, serverPort :: Int
, sourceDirectories :: [FilePath]
, unpackDirectory :: Maybe FilePath
, retrieveURL :: Text
, retrieveStrategy :: RetrieveStrategy
, endWithLastConn :: Bool
} deriving(Eq,Show)
cabalCommand :: Prefs -> FilePath
cabalCommand p = if useCabalDev p then "cabal-dev" else "cabal"
data EditorStyle = EditorStyle { styleName :: Maybe Text
, preferDark :: Bool
, foundBG :: (Color, Color)
, matchBG :: (Color, Color)
, contextBG :: (Color, Color)
, breakpointBG :: (Color, Color)
, lintBG :: (Color, Color)
}
editorStyle :: Bool -> Prefs -> EditorStyle
editorStyle preferDark prefs = EditorStyle { styleName = case sourceStyle prefs of
(False,_) -> Nothing
(True,v) -> Just v
, preferDark = preferDark
, foundBG = (foundBackgroundDark prefs, foundBackgroundLight prefs)
, matchBG = (matchBackgroundDark prefs, matchBackgroundLight prefs)
, contextBG = (contextBackgroundDark prefs, contextBackgroundLight prefs)
, breakpointBG = (breakpointBackgroundDark prefs, breakpointBackgroundLight prefs)
, lintBG = (lintBackgroundDark prefs, lintBackgroundLight prefs)
}
data SearchHint = Forward | Backward | Insert | Delete | Initial
deriving (Eq)
#ifndef LEKSAH_WITH_YI
instance Ord Modifier
where compare a b = compare (fromEnum a) (fromEnum b)
#endif
type VCSConf = (VCS.VCSType, VCS.Config, Maybe VCSGUI.MergeTool)
data LogLaunchData = LogLaunchData {
logLaunch :: LogLaunch
, mbPid :: Maybe ProcessHandle
}
data LogLaunch = LogLaunch {
logBuffer :: TextBuffer
} deriving Typeable
data LogRefType = ContextRef | BreakpointRef | ErrorRef | TestFailureRef | WarningRef | LintRef
deriving (Eq, Ord, Show, Enum, Bounded)
data LogRef = LogRef {
logRefSrcSpan :: SrcSpan
, logRefPackage :: IDEPackage
, refDescription :: Text
, logRefIdea :: Maybe (Text, Idea)
, logLines :: Maybe (Int, Int)
, logRefType :: LogRefType
} deriving (Eq)
instance Show LogRef where
show lr = T.unpack (refDescription lr) ++ displaySrcSpan (logRefSrcSpan lr)
displaySrcSpan s = srcSpanFilename s ++ ":" ++
if srcSpanStartLine s == srcSpanEndLine s
then show (srcSpanStartLine s) ++ ":" ++
if srcSpanStartColumn s == srcSpanEndColumn s
then show (srcSpanStartColumn s)
else show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s)
else show (srcSpanStartLine s) ++ ":" ++
show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s)
logRefRootPath :: LogRef -> FilePath
logRefRootPath = ipdBuildDir . logRefPackage
logRefFilePath :: LogRef -> FilePath
logRefFilePath = srcSpanFilename . logRefSrcSpan
logRefFullFilePath :: LogRef
-> FilePath
logRefFullFilePath lr = logRefRootPath lr </> logRefFilePath lr
isError :: LogRef -> Bool
isError = (== ErrorRef) . logRefType
isBreakpoint :: LogRef -> Bool
isBreakpoint = (== BreakpointRef) . logRefType
isContext :: LogRef -> Bool
isContext = (== ContextRef) . logRefType
colorHexString (Color r g b) = '#' : pad (showHex r "")
++ pad (showHex g "")
++ pad (showHex b "")
where pad s = replicate (4 length s) '0' ++ s
newtype CandyTable = CT (CandyTableForth,CandyTableBack)
type CandyTableForth = [(Bool,Text,Text)]
type CandyTableBack = [(Text,Text,Int)]
newtype KeymapI = KM (Map ActionString
[(Maybe (Either KeyString (KeyString,KeyString)), Maybe Text)])
type SpecialKeyTable alpha = Map (KeyVal,[Modifier]) (Map (KeyVal,[Modifier]) (ActionDescr alpha))
type SpecialKeyCons alpha = Maybe (Map (KeyVal, [Modifier]) (ActionDescr alpha), Text)
data LogTag = LogTag | ErrorTag | FrameTag | InputTag | InfoTag
type GUIHistory = (GUIHistory', GUIHistory')
data GUIHistory' =
ModuleSelected {
moduleS :: Maybe ModuleName
, facetS :: Maybe Text}
| ScopeSelected {
scope :: Scope
, blacklist :: Bool}
| InfoElementSelected {
mbInfo :: Maybe Descr}
| PaneSelected {
paneN :: Maybe Text}
deriving (Eq, Ord, Show)
data SensitivityMask =
SensitivityForwardHist
| SensitivityBackwardHist
| SensitivityProjectActive
| SensitivityWorkspaceOpen
| SensitivityError
| SensitivityEditor
| SensitivityInterpreting
deriving (Eq, Ord, Show)
data SearchMode = Exact {caseSense :: Bool} | Prefix {caseSense :: Bool}
| Regex {caseSense :: Bool}
deriving (Eq,Ord,Read,Show)
data CompletionWindow = CompletionWindow {
cwWindow :: Window,
cwTreeView :: TreeView,
cwListStore :: ListStore Text}
data StatusbarCompartment =
CompartmentCommand Text
| CompartmentPane (Maybe (IDEPane IDEM))
| CompartmentPackage Text
| CompartmentState Text
| CompartmentOverlay Bool
| CompartmentBufferPos (Int,Int)
| CompartmentBuild Bool
| CompartmentCollect Bool
type PackageDescrCache = Map PackageIdentifier ModuleDescrCache
type ModuleDescrCache = Map ModuleName (UTCTime, Maybe FilePath, ModuleDescr)