leksah-0.16.2.2: src/IDE/Leksah.hs
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, LambdaCase, PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Leksah
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
--
-- Main function of Leksah, an Haskell IDE written in Haskell
--
---------------------------------------------------------------------------------
module IDE.Leksah (
leksah
) where
import Prelude ()
import Prelude.Compat
import Control.Concurrent
import Data.IORef
import Data.Maybe
import qualified Data.Map as Map
import System.Console.GetOpt
import System.Environment
import Data.Version
import qualified IDE.OSX as OSX
import qualified IDE.TextEditor.Yi.Config as Yi
#ifdef LEKSAH_WITH_YI_DYRE
import System.Directory (getAppUserDataDirectory)
import System.FilePath ((</>))
import Control.Applicative ((<$>))
import qualified Config.Dyre as Dyre
#endif
import IDE.Session
import IDE.Core.State
import Control.Event
import IDE.SourceCandy
import IDE.Utils.FileUtils
import Graphics.UI.Editor.MakeEditor
import Graphics.UI.Editor.Parameters
import IDE.Command
import IDE.Preferences
import IDE.Keymap
import IDE.Pane.SourceBuffer
import IDE.Find
import Graphics.UI.Editor.Composite (filesEditor, maybeEditor)
import Graphics.UI.Editor.Simple
(stringEditor, enumEditor, textEditor)
import IDE.Metainfo.Provider (initInfo)
import IDE.Workspaces
(projectTryQuiet, projectAddPackage', workspaceTryQuiet,
workspaceNewHere, workspaceOpenThis, backgroundMake, projectOpenThis)
import IDE.Utils.GUIUtils
import Network (withSocketsDo)
import Control.Exception
import System.Exit(exitFailure)
import qualified IDE.StrippedPrefs as SP
import IDE.Utils.Tool (runTool, toolline, waitForProcess)
import System.Log
import System.Log.Logger
(getLevel, getRootLogger, debugM, updateGlobalLogger,
rootLoggerName, setLevel)
import Data.List (stripPrefix)
import System.Directory
(doesDirectoryExist, copyFile, createDirectoryIfMissing,
getHomeDirectory, doesFileExist)
import System.FilePath (dropExtension, splitExtension, (</>))
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Conduit (($$))
import Control.Monad (forever, forM_, void, when, unless, liftM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Applicative ((<$>))
import qualified Data.Text as T (pack, unpack, stripPrefix, unlines)
import Data.Text (Text)
import Data.Monoid ((<>))
import qualified Data.Sequence as Seq (empty)
import qualified GI.Gtk.Functions as Gtk (main, init)
import GI.GLib.Functions (idleAdd, timeoutAdd, timeoutAddSeconds)
import GI.GLib.Constants
(pattern PRIORITY_DEFAULT_IDLE, pattern PRIORITY_DEFAULT, pattern PRIORITY_LOW)
import GI.Gdk.Objects.Screen (screenGetDefault)
import GI.Gtk.Objects.CssProvider
(CssProvider(..), cssProviderLoadFromData, cssProviderNew)
import GI.Gtk.Objects.StyleContext
(styleContextAddProviderForScreen)
import qualified Data.ByteString.Char8 as B (unlines)
import GI.GLib.Structs.Source (sourceRemove)
import GI.Gtk.Functions
(mainIterationDo, eventsPending, mainIteration)
import GI.Gtk.Objects.Window
(setWindowDeletable, windowSetIconFromFile, IsWindow, toWindow,
setWindowWindowPosition, setWindowTitle, windowSetDefaultSize, windowNew)
import GI.Gtk.Objects.Widget
(widgetDestroy, widgetHide, widgetShowAll, widgetGetWindow,
onWidgetRealize, onWidgetDeleteEvent, widgetSetName)
import GI.Gtk.Objects.UIManager (uIManagerNew)
import GI.Gtk.Objects.Notebook (afterNotebookSwitchPage)
import GI.Gtk.Enums
(Orientation(..), WindowType(..), PolicyType(..), ResponseType(..),
WindowPosition(..), FileChooserAction(..))
import GI.Gtk.Objects.Dialog
(dialogRun, dialogResponse, dialogGetContentArea, dialogNew)
import Data.GI.Base (unsafeCastTo, set)
import GI.Gtk.Objects.Label (labelNew)
import GI.Gtk.Objects.Box (Box(..))
import GI.Gtk.Objects.ScrolledWindow
(scrolledWindowSetPolicy, scrolledWindowNew)
import GI.Gtk.Objects.Adjustment (noAdjustment)
import Control.Monad.Reader (MonadReader(..))
import GI.Gtk.Objects.ProgressBar
(progressBarSetFraction, progressBarSetText, progressBarNew)
import GI.Gtk
(containerAdd, applicationNew, Application, applicationWindowNew)
import GI.Gio (applicationRun, onApplicationActivate)
import GI.GLib.Structs.MainContext
(mainContextIteration, mainContextDefault)
import System.FSNotify
(watchTree, watchDir, withManager, WatchManager)
-- --------------------------------------------------------------------
-- Command line options
--
data Flag = VersionF | SessionN Text | EmptySession | DefaultSession | Help | Verbosity Text
deriving (Show,Eq)
options :: [OptDescr Flag]
options = [Option "e" ["emptySession"] (NoArg EmptySession)
"Start with empty session"
, Option "d" ["defaultSession"] (NoArg DefaultSession)
"Start with default session (can be used together with a source file)"
, Option "l" ["loadSession"] (ReqArg (SessionN . T.pack) "NAME")
"Load session"
, Option "h" ["help"] (NoArg Help)
"Display command line options"
, Option "v" ["version"] (NoArg VersionF)
"Show the version number of ide"
, Option "e" ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity")
"One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"]
header = "Usage: leksah [OPTION...] [file(.lkshs|.lkshw|.hs|.lhs)]"
ideOpts :: [Text] -> IO ([Flag], [Text])
ideOpts argv =
case getOpt Permute options $ map T.unpack argv of
(o,n,[] ) -> return (o,map T.pack n)
(_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options
-- ---------------------------------------------------------------------
-- | Main function
--
#ifdef LEKSAH_WITH_YI_DYRE
leksahDriver = Dyre.wrapMain Dyre.defaultParams
{ Dyre.projectName = "yi"
, Dyre.realMain = \(config, mbError) -> do
case mbError of
Just error -> putStrLn $ "Error in yi configuration file : " ++ error
Nothing -> return ()
realMain config
, Dyre.showError = \(config, _) error -> (config, Just error)
, Dyre.configDir = Just . getAppUserDataDirectory $ "yi"
, Dyre.cacheDir = Just $ ((</> "leksah") <$> (getAppUserDataDirectory "cache"))
, Dyre.hidePackages = ["mtl"]
, Dyre.ghcOpts = ["-DLEKSAH"]
}
leksah yiConfig = leksahDriver (yiConfig, Nothing)
#else
leksah = realMain
#endif
realMain yiConfig =
withSocketsDo $ handleExceptions $ do
dataDir <- getDataDir
args <- getArgs
(flags,files) <- ideOpts $ map T.pack args
isFirstStart <- not <$> hasSavedConfigFile standardPreferencesFilename
let sessions = mapMaybe (\case
SessionN s -> Just s
_ -> Nothing) flags
let sessionFPs = filter (\f -> snd (splitExtension f) == leksahSessionFileExtension) $ map T.unpack files
let workspaceFPs = filter (\f -> snd (splitExtension f) == leksahWorkspaceFileExtension) $ map T.unpack files
let sourceFPs = filter (\f -> let (_,s) = splitExtension f
in s == ".hs" || s == ".lhs" || s == ".chs") $ map T.unpack files
let mbWorkspaceFP'= case workspaceFPs of
[] -> Nothing
w:_ -> Just w
(mbWSessionFP, mbWorkspaceFP) <-
case mbWorkspaceFP' of
Nothing -> return (Nothing,Nothing)
Just fp -> let spath = dropExtension fp ++ leksahSessionFileExtension
in do
exists <- liftIO $ doesFileExist spath
if exists
then return (Just spath,Nothing)
else return (Nothing,Just fp)
let ssession = case sessions of
(s:_) -> T.unpack s <> leksahSessionFileExtension
_ -> if null sourceFPs
then standardSessionFilename
else emptySessionFilename
sessionFP <- if EmptySession `elem` flags
then getConfigFilePathForLoad
emptySessionFilename Nothing dataDir
else if DefaultSession `elem` flags
then getConfigFilePathForLoad
standardSessionFilename Nothing dataDir
else case mbWSessionFP of
Just fp -> return fp
Nothing -> getConfigFilePathForLoad
ssession Nothing dataDir
let verbosity' = mapMaybe (\case
Verbosity s -> Just s
_ -> Nothing) flags
let verbosity = case verbosity' of
[] -> INFO
h:_ -> read $ T.unpack h
updateGlobalLogger rootLoggerName (setLevel verbosity)
when (VersionF `elem` flags)
(sysMessage Normal $ "Leksah the Haskell IDE, version " <> T.pack (showVersion version))
when (Help `elem` flags)
(sysMessage Normal $ "Leksah the Haskell IDE " <> T.pack (usageInfo header options))
prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir
prefs <- readPrefs prefsPath
when (notElem VersionF flags && notElem Help flags)
(startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs prefs isFirstStart)
handleExceptions inner =
catch inner (\(exception :: SomeException) -> do
sysMessage Normal ("leksah: internal IDE error: " <> T.pack (show exception))
exitFailure
)
-- ---------------------------------------------------------------------
-- | Start the GUI
startGUI :: Yi.Config -> FilePath -> Maybe FilePath -> [FilePath] -> Prefs -> Bool -> IO ()
startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs iprefs isFirstStart =
withManager $ \fsnotify -> Yi.start yiConfig $ \yiControl -> do
app <- applicationNew (Just "org.leksah.leksah") []
onApplicationActivate app $ do
debugM "leksah" "Application Activate"
timeout <- if rtsSupportsBoundThreads
then do
setNumCapabilities 2
sysMessage Normal "Linked with -threaded"
return Nothing
else Just <$> timeoutAdd PRIORITY_LOW 10 (yield >> return True)
screenGetDefault >>= \case
Nothing -> return ()
Just screen -> do
debugM "leksah" "Add CSS"
provider <- cssProviderNew
cssProviderLoadFromData provider $
B.unlines [ ".window-frame,"
, ".window-frame:backdrop {"
, " box-shadow: none;"
, " margin: 0;}"
, "#errorLabel {"
, " padding: 10px;"
, " background: #F2DEDE;"
, " color: #A94442;"
, " border: 1px solid #EBCCD1;"
, " border-radius: 5px;}"
]
styleContextAddProviderForScreen screen provider 600
dataDir <- getDataDir
mbStartupPrefs <- if not isFirstStart
then return $ Just iprefs
else do
firstStartOK <- firstStart iprefs
if not firstStartOK
then return Nothing
else do
prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir
prefs <- readPrefs prefsPath
return $ Just prefs
maybe (return ()) (void . sourceRemove) timeout
case mbStartupPrefs of
Nothing -> return ()
Just startupPrefs ->
startMainWindow app yiControl fsnotify sessionFP mbWorkspaceFP sourceFPs
startupPrefs isFirstStart
debugM "leksah" "starting applicationRun"
applicationRun app Nothing
debugM "leksah" "finished applicationRun"
startMainWindow :: Application -> Yi.Control -> WatchManager -> FilePath -> Maybe FilePath -> [FilePath] ->
Prefs -> Bool -> IO ()
startMainWindow app yiControl fsnotify sessionFP mbWorkspaceFP sourceFPs startupPrefs isFirstStart = do
timeout <- if rtsSupportsBoundThreads
then return Nothing
else Just <$> timeoutAdd PRIORITY_LOW 10 (yield >> return True)
debugM "leksah" "startMainWindow"
osxApp <- OSX.applicationNew
uiManager <- uIManagerNew
newIcons
dataDir <- getDataDir
candyPath <- getConfigFilePathForLoad
(case sourceCandy startupPrefs of
(_,name) -> T.unpack name <> leksahCandyFileExtension) Nothing dataDir
candySt <- parseCandy candyPath
-- keystrokes
keysPath <- getConfigFilePathForLoad (T.unpack (keymapName startupPrefs) <> leksahKeymapFileExtension) Nothing dataDir
keyMap <- parseKeymap keysPath
let accelActions = setKeymap (keyMap :: KeymapI) mkActions
specialKeys <- buildSpecialKeys keyMap accelActions
win <- toWindow =<< applicationWindowNew app
widgetSetName win "Leksah Main Window"
let fs = FrameState
{ windows = [win]
, uiManager = uiManager
, panes = Map.empty
, activePane = Nothing
, paneMap = Map.empty
, layout = TerminalP Map.empty Nothing (-1) Nothing Nothing
, panePathFromNB = Map.empty
}
triggerBuild <- newEmptyMVar
let ide = IDE
{ application = app
, frameState = fs
, recentPanes = []
, specialKeys = specialKeys
, specialKey = Nothing
, candy = candySt
, prefs = startupPrefs
, workspace = Nothing
, bufferProjCache = Map.empty
, allLogRefs = Seq.empty
, currentHist = 0
, currentEBC = (Nothing, Nothing, Nothing)
, systemInfo = Nothing
, packageInfo = Nothing
, workspaceInfo = Nothing
, workspInfoCache = Map.empty
, handlers = Map.empty
, currentState = IsStartingUp
, guiHistory = (False,[],-1)
, findbar = (False,Nothing)
, toolbar = (True,Nothing)
, recentFiles = []
, recentWorkspaces = []
, runningTool = Nothing
, debugState = Nothing
, completion = ((750,400),Nothing)
, yiControl = yiControl
, serverQueue = Nothing
, server = Nothing
, hlintQueue = Nothing
, vcsData = (Map.empty, Nothing)
, logLaunches = Map.empty
, autoCommand = return ()
, autoURI = Nothing
, triggerBuild = triggerBuild
, stopWorkspaceNotify = return ()
, fsnotify = fsnotify
}
ideR <- newIORef ide
(`reflectIDE` ideR) $ do
menuDescription' <- liftIO menuDescription
makeMenu uiManager accelActions menuDescription'
nb <- newNotebook []
afterNotebookSwitchPage nb (\_ i -> reflectIDE (handleNotebookSwitch nb (fromIntegral i)) ideR)
widgetSetName nb "root"
instrumentWindow win startupPrefs nb
setBackgroundBuildToggled (backgroundBuild startupPrefs)
setMakeDocs (makeDocs startupPrefs)
setRunUnitTests (runUnitTests startupPrefs)
setRunBenchmarks (runBenchmarks startupPrefs)
setMakeModeToggled (makeMode startupPrefs)
let (x,y) = defaultSize startupPrefs
windowSetDefaultSize win (fromIntegral x) (fromIntegral y)
registerLeksahEvents
(tbv,fbv) <- recoverSession sessionFP
forM_ mbWorkspaceFP (workspaceOpenThis False)
mapM_ fileOpenThis sourceFPs
wins <- getWindows
mapM_ instrumentSecWindow (tail wins)
onWidgetRealize win $
widgetGetWindow win >>= mapM_ OSX.allowFullscreen
liftIO $ debugM "leksah" "Show main window"
widgetShowAll win
triggerEventIDE UpdateRecent
if tbv
then showToolbar
else hideToolbar
if fbv
then showFindbar
else hideFindbar
OSX.updateMenu osxApp uiManager
OSX.applicationReady osxApp
configDir <- liftIO getConfigDir
let welcomePath = configDir</>"leksah-welcome"
welcomeExists <- liftIO $ doesDirectoryExist welcomePath
unless welcomeExists $ do
let welcomeSource = dataDir</>"data"</>"leksah-welcome"
welcomeProject = welcomePath</>"cabal.project"
welcomeCabal = welcomePath</>"leksah-welcome.cabal"
welcomeMain = welcomePath</>"src"</>"Main.hs"
liftIO $ do
createDirectoryIfMissing True $ welcomePath</>"src"
createDirectoryIfMissing True $ welcomePath</>"test"
copyFile (welcomeSource</>"Setup.lhs") (welcomePath</>"Setup.lhs")
copyFile (welcomeSource</>"cabal.project") welcomeProject
copyFile (welcomeSource</>"leksah-welcome.cabal") welcomeCabal
copyFile (welcomeSource</>"LICENSE") (welcomePath</>"LICENSE")
copyFile (welcomeSource</>"src"</>"Main.hs") welcomeMain
copyFile (welcomeSource</>"test"</>"Main.hs") (welcomePath</>"test"</>"Main.hs")
defaultWorkspace <- liftIO $ (</> "leksah.lkshw") <$> getHomeDirectory
defaultExists <- liftIO $ doesFileExist defaultWorkspace
if defaultExists
then workspaceOpenThis False defaultWorkspace
else workspaceNewHere defaultWorkspace
workspaceTryQuiet $ projectOpenThis welcomeProject
projectTryQuiet $ void (projectAddPackage' welcomeCabal)
fileOpenThis welcomeMain
initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning}))
mapM_ sourceRemove timeout
liftIO . forkIO . forever $ do
takeMVar triggerBuild
processing <- newEmptyMVar
reflectIDE (postAsyncIDE' PRIORITY_LOW $
eventsPending >>= \case
True -> do
liftIO $ tryPutMVar triggerBuild ()
liftIO $ putMVar processing ()
False -> do
liftIO $ tryTakeMVar triggerBuild
liftIO $ putMVar processing ()
currentPrefs <- readIDE prefs
when (backgroundBuild currentPrefs) backgroundMake) ideR
takeMVar processing
triggerEvent ideR (Sensitivity [(SensitivityInterpreting, False)])
return ()
fDescription :: FilePath -> FieldDescription Prefs
fDescription configPath = VFD emptyParams [
mkField
(paraName <<<- ParaName "Paths under which haskell sources for packages may be found"
$ paraOrientation <<<- ParaOrientation OrientationVertical
$ paraMinSize <<<- ParaMinSize (-1, 150)
$ emptyParams)
sourceDirectories
(\b a -> a{sourceDirectories = b})
(filesEditor Nothing FileChooserActionSelectFolder "Select folders")
, mkField
(paraName <<<- ParaName "Unpack source for cabal packages to" $ emptyParams)
unpackDirectory
(\b a -> a{unpackDirectory = b})
(maybeEditor (stringEditor (const True) True,emptyParams) True "")
, mkField
(paraName <<<- ParaName "URL from which to download prebuilt metadata" $ emptyParams)
retrieveURL
(\b a -> a{retrieveURL = b})
(textEditor (const True) True)
, mkField
(paraName <<<- ParaName "Strategy for downloading prebuilt metadata" $ emptyParams)
retrieveStrategy
(\b a -> a{retrieveStrategy = b})
(enumEditor ["Try to download and then build locally if that fails","Try to build locally and then download if that fails","Never download (just try to build locally)"])]
--
-- | Called when leksah is first called (the .leksah-xx directory does not exist)
--
firstStart :: Prefs -> IO Bool
firstStart prefs = do
dataDir <- getDataDir
prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir
prefs <- readPrefs prefsPath
configDir <- getConfigDir
dialog <- dialogNew
setLeksahIcon dialog
setWindowTitle dialog "Welcome to Leksah, the Haskell IDE"
setWindowWindowPosition dialog WindowPositionCenter
dialogAddButton' dialog "gtk-ok" ResponseTypeOk
dialogAddButton' dialog "gtk-cancel" ResponseTypeCancel
vb <- dialogGetContentArea dialog >>= liftIO . unsafeCastTo Box
label <- labelNew (Just (
"Before you start using Leksah it will collect and download metadata about your installed Haskell packages.\n" <>
"You can add folders under which you have sources for Haskell packages not available from Hackage."))
(widget, setInj, getExt,notifier) <- buildEditor (fDescription configDir) prefs
boxPackStart' vb label PackNatural 7
sw <- scrolledWindowNew noAdjustment noAdjustment
containerAdd sw widget
scrolledWindowSetPolicy sw PolicyTypeNever PolicyTypeAutomatic
boxPackStart' vb sw PackGrow 7
windowSetDefaultSize dialog 800 630
widgetShowAll dialog
response <- dialogRun' dialog
widgetHide dialog
case response of
ResponseTypeOk -> do
mbNewPrefs <- liftIO $ extract prefs [getExt]
widgetDestroy dialog
case mbNewPrefs of
Nothing -> do
liftIO $ sysMessage Normal "No dialog results"
return False
Just newPrefs -> do
fp <- liftIO $ getConfigFilePathForSave standardPreferencesFilename
liftIO $ writePrefs fp newPrefs
fp2 <- liftIO $ getConfigFilePathForSave strippedPreferencesFilename
liftIO $ SP.writeStrippedPrefs fp2
SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,
SP.unpackDirectory = unpackDirectory newPrefs,
SP.retrieveURL = retrieveURL newPrefs,
SP.retrieveStrategy = retrieveStrategy newPrefs,
SP.serverPort = serverPort newPrefs,
SP.endWithLastConn = endWithLastConn newPrefs}
firstBuild newPrefs
return True
_ -> do
widgetDestroy dialog
return False
setLeksahIcon :: (IsWindow self) => self -> IO ()
setLeksahIcon window = do
dataDir <- getDataDir
let iconPath = dataDir </> "pics" </> "leksah.png"
iconExists <- doesFileExist iconPath
when iconExists $
windowSetIconFromFile window iconPath
firstBuild :: Prefs -> IO ()
firstBuild newPrefs = do
dialog <- dialogNew
liftIO $ setLeksahIcon dialog
setWindowTitle dialog "Leksah: Updating Metadata"
setWindowWindowPosition dialog WindowPositionCenter
setWindowDeletable dialog False
vb <- dialogGetContentArea dialog >>= liftIO . unsafeCastTo Box
progressBar <- progressBarNew
progressBarSetText progressBar $ Just "Please wait while Leksah collects information about Haskell packages on your system"
progressBarSetFraction progressBar 0.0
boxPackStart' vb progressBar PackGrow 7
forkIO $ do
logger <- getRootLogger
let verbosity = case getLevel logger of
Just level -> ["--verbosity=" <> T.pack (show level)]
Nothing -> []
(output, pid) <- runTool "leksah-server" (["-sbo", "+RTS", "-N2", "-RTS"] ++ verbosity) Nothing Nothing
output $$ CL.mapM_ (update progressBar)
waitForProcess pid
void . idleAdd PRIORITY_DEFAULT $ do
dialogResponse' dialog ResponseTypeOk
return False
widgetShowAll dialog
dialogRun dialog
widgetHide dialog
widgetDestroy dialog
return ()
where
update pb to = do
let str = toolline to
case T.stripPrefix "update_toolbar " str of
Just rest -> void . idleAdd PRIORITY_DEFAULT $ do
progressBarSetFraction pb (read $ T.unpack rest)
return False
Nothing -> debugM "leksah" $ T.unpack str