leksah-0.4: src/IDE/Pane/Info.hs
{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses
-XScopedTypeVariables -XTypeSynonymInstances #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Pane.Info
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>
-- Stability : experimental
-- Portability : portable
--
-- | The GUI stuff for infos
--
-------------------------------------------------------------------------------
module IDE.Pane.Info (
IDEInfo
, InfoState
, setInfo
, setSymbol
, replayInfoHistory
, getIdentifierDescr
, showInfo
) where
import Graphics.UI.Gtk hiding (afterToggleOverwrite)
import Control.Monad.Reader
import System.IO
import Control.Monad
import Control.Monad.Trans
import System.IO
--import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as BS
import Data.IORef
import qualified Data.Map as Map
import Data.Typeable
import IDE.Core.State
import Control.Event
import Graphics.UI.Editor.MakeEditor
import Graphics.UI.Editor.Simple
import Graphics.UI.Editor.Composite
import Graphics.UI.Editor.Parameters
import IDE.Pane.SourceBuffer
import IDE.Pane.Callers
import Graphics.UI.Editor.Basics
import MyMissing
-- | An info pane description
--
data IDEInfo = IDEInfo {
sw :: ScrolledWindow
, currentDescr :: IORef Descr
, injector :: Descr -> IO()
, extractor :: Descr -> Extractor Descr
} deriving Typeable
data InfoState = InfoState Descr
deriving(Eq,Ord,Read,Show,Typeable)
instance IDEObject IDEInfo
instance Pane IDEInfo IDEM
where
primPaneName _ = "Info"
getAddedIndex _ = 0
getTopWidget = castToWidget . sw
paneId b = "*Info"
makeActive pane = activatePane pane []
close pane = do
(panePath,_) <- guiPropertiesFromName (paneName pane)
nb <- getNotebook panePath
mbI <- liftIO $notebookPageNum nb (getTopWidget pane)
case mbI of
Nothing -> liftIO $ do
sysMessage Normal "notebook page not found: unexpected"
return ()
Just i -> do
deactivatePaneIfActive pane
liftIO $ do
notebookRemovePage nb i
widgetDestroy (getTopWidget pane)
removePaneAdmin pane
instance RecoverablePane IDEInfo InfoState IDEM where
saveState p = do
currentDescr' <- liftIO $ readIORef (currentDescr p)
return (Just (InfoState currentDescr'))
recoverState pp (InfoState descr) = do
setInfo descr
showInfo :: IDEAction
showInfo = do
mbInfo :: Maybe IDEInfo <- getPane
case mbInfo of
Nothing -> return ()
Just p -> liftIO $ bringPaneToFront p
idDescrDescr :: IDERef -> Session -> FieldDescription Descr
idDescrDescr ideR session = VFD emptyParams [
HFD emptyParams [
mkField
(paraName <<<- ParaName "Identifier"
$ paraName <<<- ParaPack PackGrow
$ emptyParams)
descrName
(\ b a -> if isReexported a then a else a{descrName' = b})
(symbolEditor ideR session)
, mkField
emptyParams
(stockIdFromType . descrType . details)
(\b a -> a)
imageEditor
, mkField
(paraName <<<- ParaName "Sort"
$ emptyParams)
(descrType . details)
(\b a -> a)
(comboSelectionEditor allOf)
, mkField
(paraName <<<- ParaName "Exported by"
$ paraPack <<<- ParaPack PackGrow
$ emptyParams)
(\l -> showPackModule (descrModu l))
(\ b a -> if isReexported a then a else a{descrModu' = parsePackModule b})
(stringEditor (const True))]
, mkField
(paraPack <<<- ParaPack PackGrow $ emptyParams)
(\ a -> (BS.unpack $ typeInfo a,
(case mbComment a of
Nothing -> ""
Just s -> BS.unpack s)))
(\ b a ->
(if isReexported a
then a
else a {typeInfo' = BS.pack (fst b),
mbComment' = case snd b of
"" -> Nothing
s -> Just (BS.pack s)}))
(typeAndCommentEditor ideR session)]
--allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign
-- , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance]
typeEditor :: IDERef -> Session -> Editor String
typeEditor ideR session para noti = do
ed@(wid,inj,ext) <- multilineStringEditor para noti
registerEvent noti ButtonRelease $Left (\e -> do
res <- showInfoHandler wid ideR session
return e {gtkReturn = res})
return ed
typeAndCommentEditor :: IDERef -> Session -> Editor (String,String)
typeAndCommentEditor ideR session para noti =
splitEditor (typeEditor ideR session,
paraName <<<- ParaName "Type"
$ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)
$ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)
$ emptyParams)
(multilineStringEditor,
paraName <<<- ParaName "Comment"
$ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)
$ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)
$ emptyParams)
(paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)
$ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)
$ para) noti
symbolEditor :: IDERef -> Session -> Editor String
symbolEditor ideR session parameters notifier = do
window <- reflectIDE (readIDE window) ideR session
ed@(w,i,ext) <- stringEditor (\_ -> True) parameters notifier
registerEvent notifier AfterKeyRelease (Left (\event -> do
mbText <- ext
case mbText of
Just t -> do
reflectIDE (do
triggerEvent ideR (SearchMeta t)
rw <- liftIO $ getRealWidget w
when (isJust rw) $ liftIO $ do
widgetGrabFocus (fromJust rw)
editableSelectRegion (castToEditable (fromJust rw)) 0 0
editableSetPosition (castToEditable (fromJust rw)) (-1)) ideR session
Nothing -> return ()
return event))
return ed
showInfoHandler :: Widget -> IDERef -> Session -> IO Bool
showInfoHandler wid ideR session = do
mbFrame <- binGetChild (castToAlignment wid)
mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child"))
mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2"))
mbTV <- binGetChild (castToScrolledWindow (forceJust mbScrolled "InfoPane>>typeEditor: Can't find child3"))
buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4"))
(l,r) <- textBufferGetSelectionBounds buf
symbol <- textBufferGetText buf l r True
reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session
return False
initInfo :: PanePath -> Notebook -> Descr -> IDEAction
initInfo panePath nb idDescr = do
panes <- readIDE panes
paneMap <- readIDE paneMap
prefs <- readIDE prefs
(pane,cids) <- reifyIDE $ \ideR session -> do
ibox <- vBoxNew False 0
bb <- hButtonBoxNew
buttonBoxSetLayout bb ButtonboxSpread
definitionB <- buttonNewWithLabel "Source"
moduB <- buttonNewWithLabel "Modules"
usesB <- buttonNewWithLabel "Usage"
docuB <- buttonNewWithLabel "Docu"
searchB <- buttonNewWithLabel "Find"
widgetSetSensitivity docuB False
boxPackStartDefaults bb definitionB
boxPackStartDefaults bb moduB
boxPackStartDefaults bb usesB
boxPackStartDefaults bb docuB
boxPackStartDefaults bb searchB
(widget,injb,ext,notifier) <- buildEditor (idDescrDescr ideR session) idDescr
boxPackStart ibox widget PackGrow 0
boxPackEnd ibox bb PackNatural 0
--openType
sw <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport sw ibox
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
currentDescr' <- newIORef idDescr
let info = IDEInfo sw currentDescr' injb ext
-- mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets
widget `onFocus` (\_ -> do reflectIDE (makeActive info) ideR session
return False)
definitionB `onClicked` (reflectIDE gotoSource ideR session)
moduB `onClicked` (reflectIDE gotoModule' ideR session)
usesB `onClicked` (reflectIDE calledBy' ideR session)
searchB `onClicked` (do
mbDescr <- ext idDescr
case mbDescr of
Nothing -> return ()
Just descr -> reflectIDE (do
triggerEvent ideR (SearchMeta (descrName' descr))
showInfo) ideR session)
notebookInsertOrdered nb sw (paneName info) Nothing
widgetShowAll sw
return (info,[])
addPaneAdmin pane [] panePath
liftIO $widgetGrabFocus (sw pane)
liftIO $bringPaneToFront pane
gotoSource :: IDEAction
gotoSource = do
mbInfo <- getInfoCont
case mbInfo of
Nothing -> do ideMessage Normal "gotoSource:noDefition"
return ()
Just info -> goToDefinition info >> return ()
gotoModule' :: IDEAction
gotoModule' = do
mbInfo <- getInfoCont
ideR <- ask
case mbInfo of
Nothing -> return ()
Just info -> triggerEvent ideR (SelectIdent info) >> return ()
calledBy' :: IDEAction
calledBy' = do
mbInfo <- getInfoCont
case mbInfo of
Nothing -> return ()
Just info -> calledBy info >> return ()
setSymbol :: String -> IDEAction
setSymbol symbol = do
ideR <- ask
currentInfo' <- readIDE currentInfo
case currentInfo' of
Nothing -> return ()
Just ((_,symbolTable1),(_,symbolTable2)) ->
case getIdentifierDescr symbol symbolTable1 symbolTable2 of
[] -> return ()
(a:r) -> do
setInfo a
showInfo
if length (a:r) > 1
then triggerEvent ideR (DescrChoice (a:r)) >> return ()
else triggerEvent ideR (SelectIdent a) >> return ()
setInfo :: Descr -> IDEAction
setInfo identifierDescr = do
mbPane <- getPane
case mbPane of
Nothing -> do
prefs <- readIDE prefs
layout <- readIDE layout
let pp = getStandardPanePath (logPanePath prefs) layout
nb <- getNotebook pp
initInfo pp nb identifierDescr
Just info -> do
oldDescr <- liftIO $ readIORef (currentDescr info)
liftIO $ do
writeIORef (currentDescr info) identifierDescr
(injector info) identifierDescr
recordInfoHistory identifierDescr oldDescr
getInfoCont :: IDEM (Maybe (Descr))
getInfoCont = do
mbPane <- getPane
case mbPane of
Nothing -> return Nothing
Just p -> liftIO $ readIORef (currentDescr p) >>= return . Just
--
-- | Lookup of an identifier description
--
getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [Descr]
getIdentifierDescr str st1 st2 =
let r1 = case str `Map.lookup` st1 of
Nothing -> []
Just r -> r
r2 = case str `Map.lookup` st2 of
Nothing -> []
Just r -> r
in r1 ++ r2
-- * GUI History
recordInfoHistory :: Descr -> Descr -> IDEAction
recordInfoHistory descr oldDescr = do
ideR <- ask
triggerEvent ideR (RecordHistory
((InfoElementSelected descr),
(InfoElementSelected oldDescr)))
return ()
replayInfoHistory :: Descr -> IDEAction
replayInfoHistory descr = do
setInfo descr