leksah-0.12.0.3: src/IDE/SymbolNavigation.hs
-----------------------------------------------------------------------------
--
-- Module : IDE.SymbolNavigation
-- Copyright : (c) Sanny Sannof, Juergen Nicklisch-Franken
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
-- | The source editor part of Leksah
--
-----------------------------------------------------------------------------------
module IDE.SymbolNavigation (
createHyperLinkSupport,
mapControlCommand
) where
import Data.List
import Data.Ord
import Data.Maybe
import Data.Monoid
import Data.IORef
import IDE.Core.Types
import IDE.Core.CTypes
import IDE.Core.State
import IDE.Metainfo.Provider
import IDE.Utils.GUIUtils
import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
import Graphics.UI.Gtk.Gdk.Cursor
import Graphics.UI.Gtk
import Graphics.UI.Frame.ViewFrame
import qualified Data.Set as Set
import Control.Applicative
import Distribution.ModuleName
import qualified Data.Text as T
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Graphics.UI.Gtk.Multiline.TextBuffer
import Graphics.UI.Gtk.SourceView.SourceGutter
import Graphics.UI.Gtk.SourceView
import qualified Graphics.UI.Gtk.Multiline.TextView
import qualified Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (when)
import Control.Monad.Trans.Reader (ask)
data Locality = LocalityPackage | LocalityWorkspace | LocalitySystem -- in which category symbol is located
deriving (Ord,Eq,Show)
createHyperLinkSupport ::
SourceView -> -- ^ source buffer view
ScrolledWindow -> -- ^ container window
(Bool -> Bool -> TextIter -> IO (TextIter, TextIter)) -> -- ^ identifiermapper (bools=control,shift)
(Bool -> Bool -> String -> IO ()) -> -- ^ click handler
IO [Connection]
createHyperLinkSupport sv sw identifierMapper clickHandler = do
let tv = castToTextView sv
tvb <- castToTextBuffer <$> get tv textViewBuffer :: IO TextBuffer
let myAttr = textBufferTagTable :: ReadWriteAttr TextBuffer TextTagTable TextTagTable
ttt <- castToTextTagTable <$> (get tvb myAttr) :: IO TextTagTable
-- textBuffer
noUnderline <- textTagNew Nothing
set noUnderline [ textTagUnderline := UnderlineNone, textTagUnderlineSet := True ]
underline <- textTagNew Nothing
set underline [ textTagUnderline := UnderlineSingle, textTagUnderlineSet := True ]
textTagTableAdd ttt noUnderline
textTagTableAdd ttt underline
cursor <- cursorNew Hand2
cursorDef <- cursorNew Arrow
id1 <- sw `onLeaveNotify` \e -> do
pointerUngrab (Gdk.eventTime e)
return True
let moveOrClick e click = do
sx <- scrolledWindowGetHAdjustment sw >>= adjustmentGetValue
sy <- scrolledWindowGetVAdjustment sw >>= adjustmentGetValue
let ex = Gdk.eventX e + sx
ey = Gdk.eventY e + sy
mods = Gdk.eventModifier e
ctrlPressed = (mapControlCommand Gdk.Control) `elem` mods
shiftPressed = Gdk.Shift `elem` mods
iter <- textViewGetIterAtLocation tv (round ex) (round ey)
(szx, szy) <- widgetGetSize sw
if Gdk.eventX e < 0 || Gdk.eventY e < 0
|| round(Gdk.eventX e) > szx || round(Gdk.eventY e) > szy then do
pointerUngrab (Gdk.eventTime e)
return True
else do
(beg, en) <- identifierMapper ctrlPressed shiftPressed iter
slice <- liftIO $ textBufferGetSlice tvb beg en True
startIter <- textBufferGetStartIter tvb
endIter <- textBufferGetEndIter tvb
textBufferRemoveTag tvb underline startIter endIter
offs <- textIterGetLineOffset beg
offsc <- textIterGetLineOffset iter
if (length slice > 1) then do
if (click) then do
pointerUngrab (Gdk.eventTime e)
clickHandler ctrlPressed shiftPressed slice
else do
textBufferApplyTag tvb underline beg en
Just screen <- screenGetDefault
dw <- widgetGetDrawWindow tv
pointerGrab dw False [PointerMotionMask,ButtonPressMask,LeaveNotifyMask] (Nothing :: Maybe DrawWindow) (Just cursor) (Gdk.eventTime e)
return ()
return ()
else do
pointerUngrab (Gdk.eventTime e)
return ()
return True;
lineNumberBugFix <- newIORef Nothing
let fixBugWithX e = do
dw <- widgetGetDrawWindow tv
ptr <- drawWindowGetPointer dw
let hasNoControlModifier e = not $ (mapControlCommand Gdk.Control) `elem` (Gdk.eventModifier e)
let
eventIsHintSafe (e@Gdk.Motion {}) = Gdk.eventIsHint e
eventIsHintSafe _ = False
case ptr of
Just (_, ptrx, _, _) -> do
lnbf <- readIORef lineNumberBugFix
-- print ("ishint?, adjusted, event.x, ptr.x, adjustment,hasControl?",eventIsHintSafe e,ptrx - fromMaybe (-1000) lnbf , Gdk.eventX e, ptrx, lnbf, hasNoControlModifier e)
when (eventIsHintSafe e && hasNoControlModifier e) $ do
-- get difference between event X and pointer x
-- event X is in coordinates of sourceView text
-- pointer X is in coordinates of window (remember "show line numbers" ?)
writeIORef lineNumberBugFix $ Just (ptrx - round (Gdk.eventX e)) -- captured difference
-- When control key is pressed, mostly NON-HINT events come,
-- GTK gives (mistakenly?) X in window coordinates in such cases
let nx = if (isJust lnbf && not (eventIsHintSafe e))
then fromIntegral $ ptrx - fromJust lnbf -- translate X back
else Gdk.eventX e
return $ e { Gdk.eventX = nx}
_ -> return e
id2 <- onMotionNotify sw True $ \e -> do
ne <- fixBugWithX e
moveOrClick ne False
return True
id3 <- onButtonPress sw $ \e -> do
-- print ("button press")
ne <- fixBugWithX e
-- print ("click adjustment: old, new", Gdk.eventX e, Gdk.eventX ne)
moveOrClick ne True
return $ map ConnectC [id1,id2,id3]
{--
launchSymbolNavigationDialog_ :: String -> (Descr -> IDEM ()) -> IDEM ()
launchSymbolNavigationDialog_ txt act = do
dia <- liftIO $ dialogNew
win <- getMainWindow
ideR <- ask
wi <- getSystemInfo
wiW <- getWorkspaceInfo
wiP <- getPackageInfo
case (wi,wiW,wiP) of
(Just (GenScopeC (PackScope _ syms)),
Just (GenScopeC (PackScope _ symsW), GenScopeC (PackScope _ _ )),
Just (GenScopeC (PackScope _ symsP), GenScopeC (PackScope _ _ ))) -> do
let symbolsT = map T.pack $ Set.toList $ (symbols syms `Set.union` symbols symsP)
liftIO $ do
print "============================"
print $ symLookup "launchAutoCompleteDialog" symsP
windowSetTransientFor dia win
windowSetTitle dia "Go to Symbol"
upper <- dialogGetUpper dia
lower <- dialogGetActionArea dia
vb <- vBoxNew False 0
boxPackStart upper vb PackNatural 7
en <- entryNew
store <- listStoreNew []
tv <- treeViewNewWithModel store
treeViewSetFixedHeightMode tv True
treeViewSetHoverExpand tv True
mapM_ (\(i,s) -> do
col <- treeViewColumnNew
renderer <- cellRendererTextNew
treeViewColumnSetSizing col TreeViewColumnFixed
treeViewColumnSetResizable col True
treeViewColumnSetFixedWidth col ([200,300,200] !! i)
treeViewAppendColumn tv col
cellLayoutPackStart col renderer True
cellLayoutSetAttributes col renderer store
$ \(locality, _, ss) -> [cellText := replaceCR $ ss !! i] ++
case (i, locality) of
(2, _) -> [cellTextScale := 0.8, cellTextScaleSet := True]
(0, LocalityWorkspace) ->
[cellTextStyle := StyleItalic, cellTextStyleSet := True, cellTextWeightSet := False, cellTextScaleSet := False]
(0, LocalityPackage) ->
[cellTextWeight := 1000, cellTextWeightSet := True, cellTextStyleSet := False, cellTextScaleSet := False]
_ -> [cellTextStyleSet := False, cellTextWeightSet := False, cellTextScaleSet := False]
treeViewColumnSetTitle col s) $ zip [0..] ["symbol","module","type/kind"]
boxPackEnd vb tv PackNatural 7
boxPackEnd vb en PackNatural 0
widgetSetSizeRequest tv 900 600
bb <- hButtonBoxNew
closeB <- buttonNewFromStock "gtk-cancel"
okB <- buttonNewFromStock "gtk-ok"
okB `onClicked` do
dialogResponse dia ResponseOk
widgetHideAll dia
closeB `onClicked` do
dialogResponse dia ResponseCancel
widgetHideAll dia
boxPackEnd bb closeB PackNatural 0
boxPackEnd bb okB PackNatural 0
boxPackStart lower bb PackNatural 7
set okB [widgetCanDefault := True]
buttonSetLabel okB "Goto"
widgetGrabDefault okB
widgetShowAll dia
entrySetText en txt
let getSymbolLocality symbolName = case (symLookup symbolName symsP, symLookup symbolName symsW) of
((_:_),_) -> LocalityPackage
(_,(_:_)) -> LocalityWorkspace
_ -> LocalitySystem
let
compareLocalityThenLength (Real d1 ) (Real d2) =
let
desc1 = dscName' d1
desc2 = dscName' d2
l1 = getSymbolLocality $ desc1
l2 = getSymbolLocality $ desc2
lcomp = compare l1 l2
in if lcomp == EQ
then compare (length desc1) (length desc2)
else lcomp
compareLocalityThenLength _ _ = error "compareLocalityThenLength: not real desciptions"
let updateList = do
txt <- T.pack <$> entryGetText en
let ttxt = T.toLower txt
let symz_ = take 50
$ sortBy (comparing getSymbolLocality)
$ map (T.unpack)
$ filter (matchCamelCase (txt :: T.Text) (ttxt:: T.Text)) (symbolsT ::[T.Text])
let symz = sortBy compareLocalityThenLength
$ filter (not . isReexported)
$ concatMap (\sym -> symLookup sym syms `mappend` symLookup sym symsP) symz_
listStoreClear store
mapM (\descr_ -> do
case descr_ of
Real descr -> do
let modn = case dscMbModu' descr of
Just mn -> intercalate"." $ components $ modu mn
Nothing -> "?"
let symbolName = dscName' descr
let typeDesc = map BS.w2c $ BS.unpack $ fromMaybe BS.empty $ dscMbTypeStr' descr
listStoreAppend store (getSymbolLocality symbolName, descr_, [symbolName,modn,take 80 typeDesc])
-- treeVie
return ()
_ -> return ()
) symz
when (length symz > 0) $ do
treeViewSetCursor tv [0] Nothing
return ()
print ("symz found: ",length symz)
return ()
let gotoSelectedSymbol = do
cursor <- treeViewGetCursor tv
case cursor of
([pos],_) -> do
(_,descr,_) <- listStoreGetValue store pos
dialogResponse dia ResponseCancel
widgetHideAll dia
liftIO $ reflectIDE (act descr) ideR
return ()
_ -> return ()
updateList
let modifyTreeViewCursor :: (Int -> Int) -> IO ()
modifyTreeViewCursor op = do
cur <- treeViewGetCursor tv
case cur of
([pos],_) -> do
let npos = op pos
storeSize <- listStoreGetSize store
let npos' = if npos < 0 then 0 else if npos >= storeSize then storeSize-1 else npos
when (npos < storeSize) $ do
treeViewSetCursor tv [npos'] Nothing
return ()
_ -> return ()
onEditableChanged en $ do
updateList
return ()
en `onKeyPress` \e -> do
case Gdk.eventKeyName e of
"Escape" -> do
dialogResponse dia ResponseCancel
widgetHideAll dia
return True
"Up" -> do
modifyTreeViewCursor (\x -> x-1)
return True
"Down" -> do
modifyTreeViewCursor (\x -> x+1)
return True
"Return" -> do
gotoSelectedSymbol
return True
nm -> do
print nm
return False
resp <- dialogRun dia
return ()
_ -> return ()
return ()
-- this will be camel case one day
matchCamelCase :: T.Text -> T.Text -> T.Text -> Bool
matchCamelCase search lsearch item =
search `T.isInfixOf` item || (lsearch `T.isInfixOf` (T.toLower item))
compareLength :: [a] -> [a] -> Ordering
compareLength s1 s2 = compare (length s1) (length s2)
compareLocality :: Locality -> Locality -> Ordering
compareLocality s1 s2 = compare s1 s2
replaceCR [] = []
replaceCR ('\n':ss) = ' ':(replaceCR ss)
replaceCR ('\r':ss) = ' ':(replaceCR ss)
replaceCR (s:ss) = s:(replaceCR ss)
--}