leksah-0.1: src/IDE/Leksah.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Leksah
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>
-- Stability : experimental
-- Portability : portable
--
--
-- Main function of Genuine Haskell Face, an Haskell IDE written in Haskell
--
---------------------------------------------------------------------------------
module IDE.Leksah (
runMain
) where
import Graphics.UI.Gtk
import Control.Monad.Reader
import Control.Concurrent
import Data.IORef
import Data.Maybe
import Data.List(sort)
import qualified Data.Map as Map
import System.Console.GetOpt
import System.Environment
import GHC
import Config
import Data.Version
import Prelude hiding(catch)
import System.FilePath
import System.Directory
import Paths_leksah
import IDE.SaveSession
import IDE.Core.State
import IDE.SourceCandy
import IDE.Utils.File
import IDE.Framework.ViewFrame
import IDE.Framework.MakeEditor
import IDE.Framework.Parameters
import IDE.Menu
import IDE.Preferences
import IDE.Keymap
import IDE.SourceEditor
import IDE.SpecialEditors
import IDE.Metainfo.Info
import IDE.Metainfo.SourceCollector
import IDE.Metainfo.InterfaceCollector
import IDE.Log(getLog,appendLog)
import IDE.InfoPane
import IDE.ModulesPane
-- ---------------------------------------------------------------------
-- Command line options
--
data Flag = UninstalledProject String | Collect | Rebuild | Sources | VersionF | DebugF
deriving (Show,Eq)
options :: [OptDescr Flag]
options = [Option ['r'] ["Rebuild"] (NoArg Rebuild)
"Cleans all .pack files and rebuild everything"
, Option ['c'] ["Collect"] (NoArg Collect)
"Collects new information in .pack files"
, Option ['u'] ["Uninstalled"] (ReqArg UninstalledProject "FILE")
"Gather info about an uninstalled package"
, Option ['s'] ["Sources"] (NoArg Sources)
"Gather info about pathes to sources"
, Option ['v'] ["Version"] (NoArg VersionF)
"Show the version number of ide"
, Option ['d'] ["Debug"] (NoArg DebugF)
"Write ascii pack files"]
ideOpts :: [String] -> IO ([Flag], [String])
ideOpts argv =
case getOpt Permute options argv of
(o,n,[] ) -> return (o,n)
(_,_,errs) -> ioError $userError $concat errs ++ usageInfo header options
where header = "Usage: ide [OPTION...] files..."
-- ---------------------------------------------------------------------
-- | Main function
--
runMain = handleTopExceptions $do
args <- getArgs
(o,_) <- ideOpts args
let uninstalled = filter (\x -> case x of
UninstalledProject _ -> True
_ -> False) o
if elem VersionF o
then do sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version
else
if elem Sources o
then do
buildSourceForPackageDB
sysMessage Normal "rebuild SourceForPackageDB"
else if elem Rebuild o
|| elem Collect o
|| not (null uninstalled)
then do
libDir <- getSysLibDir
#if __GHC__ > 670
session <- newSession (Just libDir)
#else
session <- newSession JustTypecheck (Just libDir)
#endif
dflags0 <- getSessionDynFlags session
setSessionDynFlags session dflags0
let version = cProjectVersion
let uninstalled = filter (\x -> case x of UninstalledProject _ -> True
_ -> False) o
let writeAscii = elem DebugF o
if length uninstalled > 0
then mapM_ (collectUninstalled writeAscii session version)
$ map (\ (UninstalledProject x) -> x) uninstalled
else do
sources <- getSourcesMap
collectInstalled' writeAscii session version (elem Rebuild o) sources
else startGUI
-- ---------------------------------------------------------------------
-- | Start the GUI
startGUI :: IO ()
startGUI = do
-- sysMessage Normal "Leksah says welcome"
st <- initGUI
when rtsSupportsBoundThreads
(sysMessage Normal "Linked with -threaded")
timeoutAddFull (yield >> return True) priorityHigh 25
mapM_ (sysMessage Normal) st
uiManager <- uiManagerNew
newIcons
hasConfigDir' <- hasConfigDir
when (not hasConfigDir') firstStart
prefsPath <- getConfigFilePathForLoad "Default.prefs"
prefs <- readPrefs prefsPath
keysPath <- getConfigFilePathForLoad $keymapName prefs ++ ".keymap"
keyMap <- parseKeymap keysPath
let accelActions = setKeymap (keyMap :: KeymapI) actions
specialKeys <- buildSpecialKeys keyMap accelActions
candyPath <- getConfigFilePathForLoad
(case sourceCandy prefs of
Nothing -> "Default.candy"
Just name -> name ++ ".candy")
candySt <- parseCandy candyPath
win <- windowNew
dataDir <- getDataDir
let iconPath = dataDir </> "data" </> "leksah.png"
iconExists <- doesFileExist iconPath
when iconExists $
windowSetIconFromFile win iconPath
libDir <- getSysLibDir
#if __GHC__ > 670
session <- newSession (Just libDir)
#else
session <- newSession JustTypecheck (Just libDir)
#endif
dflags0 <- getSessionDynFlags session
setSessionDynFlags session dflags0
let ide = IDE
{ window = win
, uiManager = uiManager
, panes = Map.empty
, activePane = Nothing
, paneMap = Map.empty
, layout = (TerminalP Nothing (-1))
, specialKeys = specialKeys
, specialKey = Nothing
, candy = candySt
, prefs = prefs
-- , packages = []
, activePack = Nothing
, errors = []
, currentErr = Nothing
, accessibleInfo = Nothing
, currentInfo = Nothing
, session = session
, handlers = Map.empty}
ideR <- newIORef ide
runReaderT (initInfo :: IDEAction) ideR
menuDescription' <- menuDescription
(acc,menus) <- runReaderT (makeMenu uiManager accelActions menuDescription') ideR
when (length menus /= 3) $ throwIDE ("Failed to build menu" ++ show (length menus))
windowAddAccelGroup win acc
nb <- newNotebook
widgetSetName nb $"root"
statusBar <- buildStatusbar ideR
vb <- vBoxNew False 1 -- Top-level vbox
widgetSetName vb "topBox"
boxPackStart vb (menus !! 0) PackNatural 0
boxPackStart vb nb PackGrow 0
boxPackEnd vb statusBar PackNatural 0
win `onDelete` (\ _ -> do runReaderT quit ideR; return True)
win `onKeyPress` (\ e -> runReaderT (handleSpecialKeystrokes e) ideR)
containerAdd win vb
runReaderT (setCandyState (isJust (sourceCandy prefs))) ideR
let (x,y) = defaultSize prefs
windowSetDefaultSize win x y
runReaderT (do
registerEvents menus
recoverSession :: IDEAction) ideR
widgetShowAll win
mainGUI
--
-- | Callback function for onKeyPress of the main window, so preprocess any key
--
handleSpecialKeystrokes :: Event -> IDEM Bool
handleSpecialKeystrokes (Key _ _ _ mods _ _ _ keyVal name mbChar) = do
bs <- getCandyState
when bs $ editKeystrokeCandy mbChar
sk <- readIDE specialKey
sks <- readIDE specialKeys
sb <- getSBSpecialKeys
case sk of
Nothing -> do
case Map.lookup (keyVal,sort mods) sks of
Nothing -> do
lift $statusbarPop sb 1
lift $statusbarPush sb 1 ""
return False
Just map -> do
sb <- getSBSpecialKeys
let sym = printMods mods ++ name
lift $statusbarPop sb 1
lift $statusbarPush sb 1 sym
modifyIDE_ (\ide -> return (ide{specialKey = Just (map,sym)}))
return True
Just (map,sym) -> do
case Map.lookup (keyVal,sort mods) map of
Nothing -> do
sb <- getSBSpecialKeys
lift $statusbarPop sb 1
lift $statusbarPush sb 1 $sym ++ printMods mods ++ name ++ "?"
return ()
Just (AD actname _ _ _ ideAction _ _) -> do
sb <- getSBSpecialKeys
lift $statusbarPop sb 1
lift $statusbarPush sb 1
$sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname
ideAction
modifyIDE_ (\ide -> return (ide{specialKey = Nothing}))
return True
where
printMods :: [Modifier] -> String
printMods [] = ""
printMods (m:r) = show m ++ printMods r
handleSpecialKeystrokes _ = return True
registerEvents :: [Widget] -> IDEAction
registerEvents tbl = do
stRef <- ask
registerEvent stRef LogMessageS (Left logHandler)
registerEvent stRef GetToolbarS (Left tbHandler)
registerEvent stRef SelectInfoS (Left siHandler)
registerEvent stRef SelectIdentS (Left sidHandler)
registerEvent stRef CurrentInfoS (Left ciuHandler)
registerEvent stRef ActivePackS (Left apHandler)
return ()
where
logHandler e@(LogMessage s t) = do
(log :: IDELog) <- getLog
lift $ appendLog log s t
return e
logHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"
tbHandler (GetToolbar _) = return (GetToolbar tbl)
tbHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"
siHandler e@(SelectInfo str) = do
setSymbol str
return e
siHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"
sidHandler e@(SelectIdent id) = do
selectIdentifier id
return e
sidHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"
ciuHandler CurrentInfo = do
reloadKeepSelection
return CurrentInfo
ciuHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"
apHandler ActivePack = do
infoForActivePackage :: IDEAction
return ActivePack
apHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"
--
-- | Called when leksah ist first called
--
fDescription :: FieldDescription Prefs
fDescription =
mkField
(paraName <<<- ParaName "Paths under which haskell sources may be found"
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
sourceDirectories
(\b a -> a{sourceDirectories = b})
(filesEditor Nothing FileChooserActionSelectFolder "Select folders")
firstStart :: IO ()
firstStart = do
prefsPath <- getConfigFilePathForLoad "Default.prefs"
prefs <- readPrefs prefsPath
dialog <- windowNew
vb <- vBoxNew False 0
bb <- hButtonBoxNew
ok <- buttonNewFromStock "gtk-ok"
cancel <- buttonNewFromStock "gtk-cancel"
boxPackStart bb ok PackNatural 0
boxPackStart bb cancel PackNatural 0
label <- labelNew (Just ("Welcome to Leksah, an IDE for Haskell.\n" ++
"At the first start, Leksah will collect metadata about your installed haskell packages.\n" ++
"Select folders under which you have installed Haskell packages with sources below and click add.\n" ++
"It may take some time before Leksah starts up."))
(widget, setInj, getExt,notifier)
<- fieldEditor fDescription prefs
ok `onClicked` (do
mbNewPrefs <- extract prefs [getExt]
case mbNewPrefs of
Nothing -> return ()
Just newPrefs -> do
fp <- getConfigFilePathForSave "Default.prefs"
writePrefs fp newPrefs
widgetDestroy dialog
mainQuit
firstBuild)
cancel `onClicked` (do
widgetDestroy dialog
mainQuit)
dialog `onDelete` (\_ -> do
widgetDestroy dialog
mainQuit
return True)
boxPackStart vb label PackGrow 7
boxPackStart vb widget PackGrow 7
boxPackEnd vb bb PackNatural 7
containerAdd dialog vb
widgetSetSizeRequest dialog 700 400
widgetShowAll dialog
mainGUI
return ()
firstBuild :: IO ()
firstBuild = do
libDir <- getSysLibDir
#if __GHC__ > 670
session <- newSession (Just libDir)
#else
session <- newSession JustTypecheck (Just libDir)
#endif
dflags0 <- getSessionDynFlags session
setSessionDynFlags session dflags0
let version = cProjectVersion
buildSourceForPackageDB
sources <- getSourcesMap
collectInstalled' False session version True sources