leksah-0.16.2.2: src/IDE/Completion.hs
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Completion
-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GPL
--
-- Maintainer : <maintainer@leksah.org>
-- Stability : provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
module IDE.Completion (complete, cancel, setCompletionSize, smartIndent) where
import Prelude hiding(getChar, getLine)
import Data.List as List (stripPrefix, isPrefixOf, filter)
import Data.Char
import Data.IORef
import Control.Monad
import IDE.Core.State
import IDE.Metainfo.Provider
(keywords, getDescription, getCompletionOptions)
import IDE.TextEditor as TE
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Reader (ask)
import qualified Control.Monad.Reader as Gtk (liftIO)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Applicative ((<$>))
import Data.Text (Text)
import qualified Data.Text as T
(replicate, empty, commonPrefixes, pack, unpack, null, stripPrefix,
isPrefixOf)
import System.Log.Logger (debugM)
import GI.Gtk.Objects.Window
(windowMove, windowGetScreen, windowGetSize, Window(..),
windowNew, setWindowTransientFor, setWindowDefaultHeight,
setWindowDefaultWidth, setWindowResizable, setWindowDecorated,
setWindowTypeHint, windowResize)
import Data.GI.Base
(unsafeManagedPtrGetPtr, unsafeCastTo, get, set)
import GI.Gdk.Enums (GrabStatus(..), WindowTypeHint(..))
import GI.Gtk.Objects.Container
(containerRemove, containerAdd, containerSetBorderWidth)
import GI.Gtk.Objects.Paned (panedNew)
import GI.Gtk.Objects.ScrolledWindow (scrolledWindowNew)
import GI.Gtk.Objects.Adjustment (noAdjustment)
import GI.Gtk.Objects.Widget
(Widget(..), widgetShowAll, widgetGetAllocation, widgetGetParent,
widgetHide, onWidgetButtonReleaseEvent, onWidgetMotionNotifyEvent,
widgetGetWindow, onWidgetButtonPressEvent, getWidgetVisible,
widgetModifyFont, widgetSetSizeRequest)
import GI.Gtk.Objects.TreeView
(treeViewSetCursor, onTreeViewRowActivated, treeViewRowActivated,
treeViewScrollToCell, treeViewGetColumn, treeViewGetModel,
TreeView(..), treeViewGetSelection, setTreeViewHeadersVisible,
treeViewAppendColumn, treeViewSetModel, treeViewNew)
import Data.GI.Gtk.ModelView.SeqStore
(seqStoreAppend, seqStoreClear, seqStoreGetValue, SeqStore(..),
seqStoreNew)
import GI.Pango.Structs.FontDescription
(fontDescriptionSetFamily, fontDescriptionNew,
fontDescriptionFromString)
import GI.Gtk.Objects.TreeViewColumn
(noTreeViewColumn, treeViewColumnPackStart, setTreeViewColumnMinWidth,
setTreeViewColumnSizing, treeViewColumnNew)
import GI.Gtk.Enums (TreeViewColumnSizing(..), WindowType(..), Orientation(..))
import GI.Gtk.Objects.CellRendererText
(setCellRendererTextText, cellRendererTextNew)
import Data.GI.Gtk.ModelView.CellLayout
(cellLayoutSetDataFunction)
import GI.Gtk.Objects.TreeSelection
(treeSelectionGetSelected, treeSelectionSelectPath,
treeSelectionSelectedForeach,
onTreeSelectionChanged)
import GI.Gtk.Objects.Paned
(panedSetPosition, panedGetPosition, panedGetChild2, Paned(..),
panedGetChild1, panedAdd2, panedAdd1)
import GI.Gdk.Structs.EventKey
(getEventKeyKeyval, getEventKeyState)
import GI.Gdk.Functions
(pointerUngrab, pointerGrab, keyvalToUnicode, keyvalName)
import GI.Gtk.Interfaces.TreeModel
(treeModelGetPath, treeModelIterNChildren)
import GI.Gdk.Structs.EventButton
(getEventButtonTime, getEventButtonY, getEventButtonX,
getEventButtonButton)
import GI.Gdk.Flags (EventMask(..))
import GI.Gdk.Objects.Cursor (noCursor)
import GI.Gdk.Structs.EventMotion
(getEventMotionY, getEventMotionX)
import GI.Gtk.Structs.TreePath (treePathGetIndices, TreePath(..))
import Graphics.UI.Frame.Rectangle
(getRectangleHeight, getRectangleWidth, getRectangleY,
getRectangleX, Rectangle(..))
import GI.Gdk.Objects.Window (windowGetOrigin)
import qualified GI.Gdk.Objects.Window as Gdk (noWindow)
import GI.Gdk.Objects.Screen
(screenGetHeight, screenGetWidth, screenGetMonitorAtPoint)
import Data.GI.Gtk.ModelView.Types
(equalManagedPtr, treePathGetIndices', treePathNewFromIndices')
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import GI.Gtk (widgetOverrideFont)
complete :: TextEditor editor => EditorView editor -> Bool -> IDEAction
complete sourceView always = do
currentState' <- readIDE currentState
prefs' <- readIDE prefs
(_, completion') <- readIDE completion
case (currentState',completion') of
(IsCompleting c, Just (CompletionWindow window tv st)) -> do
isWordChar <- getIsWordChar sourceView
updateOptions window tv st sourceView c isWordChar always
(IsRunning,_) -> when (always || not (completeRestricted prefs'))
(initCompletion sourceView always)
_ -> return ()
cancel :: IDEAction
cancel = do
currentState' <- readIDE currentState
(_, completion') <- readIDE completion
case (currentState',completion') of
(IsCompleting conn , Just (CompletionWindow window tv st)) ->
cancelCompletion window tv st conn
_ -> return ()
setCompletionSize :: Int -> Int -> IDEAction
setCompletionSize x y | x > 10 && y > 10 = do
(_, completion) <- readIDE completion
case completion of
Just (CompletionWindow window _ _) -> windowResize window (fromIntegral x) (fromIntegral y)
Nothing -> return ()
modifyIDE_ $ \ide -> ide{completion = ((x, y), completion)}
setCompletionSize _ _ = return ()
getIsWordChar :: forall editor. TextEditor editor => EditorView editor -> IDEM (Char -> Bool)
getIsWordChar sourceView = do
ideR <- ask
buffer <- getBuffer sourceView
(_, end) <- getSelectionBounds buffer
sol <- backwardToLineStartC end
eol <- forwardToLineEndC end
line <- getSlice buffer sol eol False
let isImport = "import " `T.isPrefixOf` line
isIdent a = isAlphaNum a || a == '\'' || a == '_' || (isImport && a == '.')
isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'
|| a == '!' || a == '@' || a == '%' || a == '&' || a == '?'
prev <- backwardCharC end
prevChar <- getChar prev
case prevChar of
Just prevChar | isIdent prevChar -> return isIdent
Just prevChar | isOp prevChar -> return isOp
_ -> return $ const False
initCompletion :: forall editor. TextEditor editor => EditorView editor -> Bool -> IDEAction
initCompletion sourceView always = do
ideR <- ask
((width, height), completion') <- readIDE completion
isWordChar <- getIsWordChar sourceView
case completion' of
Just (CompletionWindow window' tree' store') -> do
cids <- addEventHandling window' sourceView tree' store' isWordChar always
modifyIDE_ (\ide -> ide{currentState = IsCompleting cids})
updateOptions window' tree' store' sourceView cids isWordChar always
Nothing -> do
windows <- getWindows
prefs <- readIDE prefs
window <- windowNew WindowTypePopup
setWindowTypeHint window WindowTypeHintUtility
setWindowDecorated window False
setWindowResizable window True
setWindowDefaultWidth window $ fromIntegral width
setWindowDefaultHeight window $ fromIntegral height
setWindowTransientFor window $ head windows
containerSetBorderWidth window 3
paned <- panedNew OrientationHorizontal
containerAdd window paned
nameScrolledWindow <- scrolledWindowNew noAdjustment noAdjustment
widgetSetSizeRequest nameScrolledWindow 250 40
tree <- treeViewNew
containerAdd nameScrolledWindow tree
store <- seqStoreNew []
treeViewSetModel tree (Just store)
font <- case textviewFont prefs of
Just str ->
fontDescriptionFromString str
Nothing -> do
f <- fontDescriptionNew
fontDescriptionSetFamily f "Monospace"
return f
widgetOverrideFont tree (Just font)
column <- treeViewColumnNew
setTreeViewColumnSizing column TreeViewColumnSizingFixed
setTreeViewColumnMinWidth column 800 -- OSX does not like it if there is no hscroll
treeViewAppendColumn tree column
renderer <- cellRendererTextNew
treeViewColumnPackStart column renderer True
cellLayoutSetDataFunction column renderer store $ setCellRendererTextText renderer
setTreeViewHeadersVisible tree False
descriptionBuffer <- newDefaultBuffer Nothing ""
(descriptionView, descriptionScrolledWindow) <- newView descriptionBuffer (textviewFont prefs)
updateStyle descriptionBuffer
visible <- liftIO $ newIORef False
activeView <- liftIO $ newIORef Nothing
treeSelection <- treeViewGetSelection tree
onTreeSelectionChanged treeSelection $
treeSelectionSelectedForeach treeSelection $ \_model treePath _iter ->
reflectIDE (void $ withWord store treePath (\name -> do
description <- getDescription name
setText descriptionBuffer description
)) ideR
panedAdd1 paned nameScrolledWindow
panedAdd2 paned descriptionScrolledWindow
cids <- addEventHandling window sourceView tree store isWordChar always
modifyIDE_ (\ide -> ide{currentState = IsCompleting cids,
completion = ((width, height), Just (CompletionWindow window tree store))})
updateOptions window tree store sourceView cids isWordChar always
addEventHandling :: TextEditor editor => Window -> EditorView editor -> TreeView -> SeqStore Text
-> (Char -> Bool) -> Bool -> IDEM Connections
addEventHandling window sourceView tree store isWordChar always = do
ideR <- ask
cidsPress <- TE.onKeyPress sourceView $ do
e <- lift ask
keyVal <- getEventKeyKeyval e
name <- keyvalName keyVal
modifier <- getEventKeyState e
char <- toEnum . fromIntegral <$> keyvalToUnicode keyVal
Just model <- treeViewGetModel tree
selection <- treeViewGetSelection tree
count <- treeModelIterNChildren model Nothing
Just column <- treeViewGetColumn tree 0
let whenVisible f = getWidgetVisible tree >>= \case
True -> f
False -> return False
down = whenVisible $ do
maybeRow <- liftIO $ getRow tree
let newRow = maybe 0 (+ 1) maybeRow
when (newRow < count) $ do
path <- treePathNewFromIndices' [newRow]
treeSelectionSelectPath selection path
treeViewScrollToCell tree (Just path) noTreeViewColumn False 0 0
return True
up = whenVisible $ do
maybeRow <- liftIO $ getRow tree
let newRow = maybe 0 (\ row -> row - 1) maybeRow
when (newRow >= 0) $ do
path <- treePathNewFromIndices' [newRow]
treeSelectionSelectPath selection path
treeViewScrollToCell tree (Just path) noTreeViewColumn False 0 0
return True
case (name, modifier, char) of
(Just "Tab", _, _) -> whenVisible . liftIDE $ do
tryToUpdateOptions window tree store sourceView True isWordChar always
return True
(Just "Return", _, _) -> getWidgetVisible tree >>= \case
True -> do
maybeRow <- liftIO $ getRow tree
case maybeRow of
Just row -> do
path <- treePathNewFromIndices' [row]
liftIDE $ withWord store path (replaceWordStart sourceView isWordChar) >>= \case
Just True -> liftIDE $ smartIndent sourceView
_ -> return ()
liftIDE $ postAsyncIDE cancel
return True
Nothing -> liftIDE $ do
cancel
smartIndent sourceView
return True
False -> liftIDE $ do
smartIndent sourceView
return True
(Just "Down", _, _) -> down
(Just "Up", _, _) -> up
(Just super, _, 'a') | super `elem` ["Super_L", "Super_R"] -> do
liftIO $ debugM "leksah" "Completion - Super 'a' key press"
down
(Just super, _, 'l') | super `elem` ["Super_L", "Super_R"] -> do
liftIO $ debugM "leksah" "Completion - Super 'l' key press"
up
(_, _, c) | isWordChar c -> return False
(Just "BackSpace", _, _) -> return False
(Just key, _, _) | key `elem` ["Shift_L", "Shift_R", "Super_L", "Super_R"] -> return False
_ -> do liftIDE cancel
return False
cidsRelease <- TE.onKeyRelease sourceView $ do
e <- lift ask
name <- getEventKeyKeyval e >>= keyvalName
modifier <- getEventKeyState e
case (name, modifier) of
(Just "BackSpace", _) -> do
liftIDE $ complete sourceView False
return False
_ -> return False
resizeHandler <- liftIO $ newIORef Nothing
idButtonPress <- ConnectC window <$> onWidgetButtonPressEvent window (\e -> do
button <- getEventButtonButton e
x <- getEventButtonX e
y <- getEventButtonY e
time <- getEventButtonTime e
widgetGetWindow window >>= \case
Nothing -> return ()
Just drawWindow -> do
status <- pointerGrab
drawWindow
False
[EventMaskPointerMotionMask, EventMaskButtonReleaseMask]
Gdk.noWindow
noCursor
time
when (status == GrabStatusSuccess) $ do
(width, height) <- windowGetSize window
liftIO $ writeIORef resizeHandler $ Just $ \newX newY ->
reflectIDE (
setCompletionSize (fromIntegral width + floor (newX - x)) (fromIntegral height + floor (newY - y))) ideR
return True)
idMotion <- ConnectC window <$> onWidgetMotionNotifyEvent window (\e -> do
mbResize <- readIORef resizeHandler
case mbResize of
Just resize -> do
x <- getEventMotionX e
y <- getEventMotionY e
resize x y
return True
Nothing -> return False)
idButtonRelease <- ConnectC window <$> onWidgetButtonReleaseEvent window (\e -> do
mbResize <- liftIO $ readIORef resizeHandler
case mbResize of
Just resize -> do
x <- getEventButtonX e
y <- getEventButtonY e
resize x y
getEventButtonTime e >>= pointerUngrab
liftIO $ writeIORef resizeHandler Nothing
return True
Nothing -> return False)
idSelected <- ConnectC tree <$> onTreeViewRowActivated tree (\treePath column -> (`reflectIDE` ideR) $ do
withWord store treePath (replaceWordStart sourceView isWordChar)
postAsyncIDE cancel)
return $ concat [cidsPress, cidsRelease, [idButtonPress, idMotion, idButtonRelease, idSelected]]
smartIndent :: TextEditor editor => EditorView editor -> IDEM ()
smartIndent sourceView = do
indentWidth <- tabWidth <$> readIDE prefs
buffer <- getBuffer sourceView
(selStart, selEnd) <- getSelectionBounds buffer
lineStart <- backwardToLineStartC selStart
line <- getText buffer lineStart selStart True
let lastWord = reverse . takeWhile (\c -> isAlphaNum c || c `elem` ['\'','_']) . reverse $ T.unpack line
lastOp = reverse . takeWhile (\c -> not (isAlphaNum c) && c `notElem` ['\'','_','\"',' ',']',')','}',',',';']) . reverse $ T.unpack line
indentAmount = length . takeWhile (==' ') $ T.unpack line
extraIndent = T.pack lastWord `elem` keywords || (not (null lastOp) && lastOp `notElem` ["--", "\\"])
newIndent = if extraIndent
then (indentAmount `div` indentWidth + 1) * indentWidth
else indentAmount
delete buffer selStart selEnd
insert buffer selStart $ "\n" <> T.replicate newIndent " "
withWord :: SeqStore Text -> TreePath -> (Text -> IDEM a) -> IDEM (Maybe a)
withWord store treePath f =
treePathGetIndices' treePath >>= \case
[row] -> do
value <- seqStoreGetValue store row
Just <$> f value
_ -> return Nothing
-- Return value indicates if the we did nothing and return key should
-- still be cause a new line to be started.
replaceWordStart :: TextEditor editor => EditorView editor -> (Char -> Bool) -> Text -> IDEM Bool
replaceWordStart sourceView isWordChar name = do
buffer <- getBuffer sourceView
(selStart, selEnd) <- getSelectionBounds buffer
start <- findWordStart selStart isWordChar
wordStart <- getText buffer start selEnd True
case T.stripPrefix wordStart name of
Just "" -> return True
Just extra -> do
end <- findWordEnd selEnd isWordChar
wordFinish <- getText buffer selEnd end True
case T.stripPrefix wordFinish extra of
Just extra2 | not (T.null wordFinish) -> do
selectRange buffer end end
insert buffer end extra2
_ -> insert buffer selEnd extra
return False
Nothing -> return False
cancelCompletion :: Window -> TreeView -> SeqStore Text -> Connections -> IDEAction
cancelCompletion window tree store connections = do
seqStoreClear (store :: SeqStore Text)
signalDisconnectAll connections
widgetHide window
modifyIDE_ (\ide -> ide{currentState = IsRunning})
updateOptions :: forall editor. TextEditor editor => Window -> TreeView -> SeqStore Text -> EditorView editor -> Connections -> (Char -> Bool) -> Bool -> IDEAction
updateOptions window tree store sourceView connections isWordChar always = do
result <- tryToUpdateOptions window tree store sourceView False isWordChar always
unless result $ cancelCompletion window tree store connections
tryToUpdateOptions :: TextEditor editor => Window -> TreeView -> SeqStore Text -> EditorView editor -> Bool -> (Char -> Bool) -> Bool -> IDEM Bool
tryToUpdateOptions window tree store sourceView selectLCP isWordChar always = do
ideR <- ask
seqStoreClear (store :: SeqStore Text)
buffer <- getBuffer sourceView
(selStart, end) <- getSelectionBounds buffer
start <- findWordStart selStart isWordChar
equal <- iterEqual start end
if equal
then return False
else do
wordStart <- getText buffer start end True
liftIO $ do -- dont use postGUIAsync - it causes bugs related to several repeated tryToUpdateOptions in thread
reflectIDE (do
options <- getCompletionOptions wordStart
processResults window tree store sourceView wordStart options selectLCP isWordChar always) ideR
return ()
return True
findWordStart :: TextEditor editor => EditorIter editor -> (Char -> Bool) -> IDEM (EditorIter editor)
findWordStart iter isWordChar = do
maybeWS <- backwardFindCharC iter (not . isWordChar) Nothing
case maybeWS of
Nothing -> atOffset iter 0
Just ws -> forwardCharC ws
findWordEnd :: TextEditor editor => EditorIter editor -> (Char -> Bool) -> IDEM (EditorIter editor)
findWordEnd iter isWordChar = do
maybeWE <- forwardFindCharC iter (not . isWordChar) Nothing
case maybeWE of
Nothing -> forwardToLineEndC iter
Just we -> return we
longestCommonPrefix a b = case T.commonPrefixes a b of
Nothing -> T.empty
Just (p, _, _) -> p
processResults :: TextEditor editor => Window -> TreeView -> SeqStore Text -> EditorView editor -> Text -> [Text]
-> Bool -> (Char -> Bool) -> Bool -> IDEAction
processResults window tree store sourceView wordStart options selectLCP isWordChar always =
case options of
[] -> cancel
_ | not always && (not . null $ drop 200 options) -> cancel
_ -> do
buffer <- getBuffer sourceView
(selStart, end) <- getSelectionBounds buffer
start <- findWordStart selStart isWordChar
currentWordStart <- getText buffer start end True
let newWordStart = if selectLCP && currentWordStart == wordStart && not (null options)
then foldl1 longestCommonPrefix options
else currentWordStart
when (T.isPrefixOf wordStart newWordStart) $ do
seqStoreClear store
let newOptions = List.filter (T.isPrefixOf newWordStart) options
forM_ (take 200 newOptions) (seqStoreAppend store)
rect <- getIterLocation sourceView start
startx <- getRectangleX rect
starty <- getRectangleY rect
width <- getRectangleWidth rect
height <- getRectangleHeight rect
(wWindow, hWindow) <- windowGetSize window
(x, y) <- bufferToWindowCoords sourceView (fromIntegral startx, fromIntegral (starty+height))
mbDrawWindow <- getWindow sourceView
case mbDrawWindow of
Nothing -> return ()
Just drawWindow -> do
(_, ox, oy) <- windowGetOrigin drawWindow
Just namesSW <- widgetGetParent tree
rNames <- widgetGetAllocation namesSW
wNames <- getRectangleWidth rNames
hNames <- getRectangleHeight rNames
paned <- widgetGetParent namesSW >>= liftIO . unsafeCastTo Paned . fromJust
Just first <- panedGetChild1 paned
Just second <- panedGetChild2 paned
screen <- windowGetScreen window
monitor <- screenGetMonitorAtPoint screen (ox+fromIntegral x) (oy+fromIntegral y)
monitorLeft <- screenGetMonitorAtPoint screen (ox+fromIntegral x-wWindow+wNames) (oy+fromIntegral y)
monitorRight <- screenGetMonitorAtPoint screen (ox+fromIntegral x+wWindow) (oy+fromIntegral y)
monitorBelow <- screenGetMonitorAtPoint screen (ox+fromIntegral x) (oy+fromIntegral y+hWindow)
wScreen <- screenGetWidth screen
hScreen <- screenGetHeight screen
top <- if monitorBelow /= monitor || (oy+fromIntegral y+hWindow) > hScreen
then do
sourceSW <- getScrolledWindow sourceView
hSource <- widgetGetAllocation sourceSW >>= getRectangleHeight
scrollToIter sourceView end 0.1 (Just (1.0, 1.0 - (fromIntegral hWindow / fromIntegral hSource)))
(_, newy) <- bufferToWindowCoords sourceView (fromIntegral startx, fromIntegral (starty+height))
return (oy+fromIntegral newy)
else return (oy+fromIntegral y)
liftIO $ debugM "leksah" $ "Completion processResults " <> show (monitorRight /= monitor, monitorLeft /= monitor, ox, x, wWindow, wScreen, wNames)
swap <- if (monitorRight /= monitor || (ox+fromIntegral x+wWindow) > wScreen) && monitorLeft == monitor && (ox+fromIntegral x-wWindow+wNames) > 0
then do
windowMove window (ox+fromIntegral x-wWindow+wNames) top
return $ first `equalManagedPtr` namesSW
else do
windowMove window (ox+fromIntegral x) top
return . not $ first `equalManagedPtr` namesSW
when swap $ do
pos <- panedGetPosition paned
containerRemove paned first
containerRemove paned second
panedAdd1 paned second
panedAdd2 paned first
panedSetPosition paned (wWindow-pos)
unless (null newOptions) $ do
path <- treePathNewFromIndices' [0]
treeViewSetCursor tree path noTreeViewColumn False
widgetShowAll window
when (newWordStart /= currentWordStart) $
void $ replaceWordStart sourceView isWordChar newWordStart
getRow tree = do
Just model <- treeViewGetModel tree
selection <- treeViewGetSelection tree
treeSelectionGetSelected selection >>= \case
(True, _, iter) -> do
[row] <- treeModelGetPath model iter >>= treePathGetIndices
return $ Just row
_ -> return Nothing