----------------------------------------------------------------------------- -- -- 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) --}