{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.TextEditor.GtkSourceView -- Copyright : 2007-2013 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.TextEditor.GtkSourceView ( TextEditor(..) , EditorBuffer(..) , EditorView(..) , EditorIter(..) , EditorMark(..) , EditorTag(..) , EditorTagTable(..) , GtkSourceView(..) , newGtkBuffer ) where import IDE.TextEditor.Class (TextEditor(..), EditorStyle(..)) import IDE.Core.Types (LogRefType(..), LogRef(..), LogRefType, colorHexString, Prefs(..), IDE(..), IDEM) import Control.Monad.IO.Class (MonadIO(..)) import Data.Typeable (Typeable) import Control.Applicative ((<$>)) import System.FilePath (()) import IDE.Core.State (onIDE, reflectIDE, readIDE, getDataDir) import Control.Monad (void, when, forM_) import Control.Monad.Reader.Class (MonadReader(..)) import Graphics.UI.Editor.Basics (Connection(..)) import Data.Maybe (isJust, fromMaybe, isNothing, maybeToList, fromJust) import Data.IORef (writeIORef, readIORef, newIORef) import Data.Char (isDigit, isSymbol, isAlphaNum) import Control.Monad.Trans.Class (MonadTrans(..)) import IDE.Utils.GUIUtils (fontDescription) import Data.Text (Text) import qualified Data.Text as T (drop, dropWhile, all, length, pack) import Data.Monoid ((<>)) import Control.Arrow (Arrow(..)) import System.Log.Logger (debugM) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (nullPtr, castPtr) import qualified GI.GtkSource as Source import GI.GtkSource (viewSetDrawSpaces, setViewTabWidth, setViewShowLineNumbers, setViewRightMarginPosition, setViewShowRightMargin, setViewIndentWidth, setViewDrawSpaces, bufferUndo, bufferSetStyleScheme, styleSchemeManagerGetScheme, styleSchemeManagerGetSchemeIds, styleSchemeManagerAppendSearchPath, styleSchemeManagerNew, bufferRemoveSourceMarks, bufferRedo, viewSetMarkAttributes, onMarkAttributesQueryTooltipText, markAttributesSetIconName, markAttributesNew, setViewShowLineMarks, setViewSmartHomeEnd, setViewAutoIndent, setViewIndentOnTab, setViewInsertSpacesInsteadOfTabs, setViewHighlightCurrentLine, viewNewWithBuffer, bufferCreateSourceMark, getBufferCanUndo, getBufferCanRedo, bufferEndNotUndoableAction, bufferBeginNotUndoableAction, bufferSetMaxUndoLevels, bufferNew, bufferNewWithLanguage, languageManagerGuessLanguage, languageManagerSetSearchPath, languageManagerGetSearchPath, languageManagerNew) import GI.Gio (contentTypeGuess) import GI.Gtk.Objects.TextBuffer (afterTextBufferChanged, setTextBufferText, onTextBufferMarkSet, afterTextBufferInsertText, afterTextBufferEndUserAction, afterTextBufferModifiedChanged, textBufferSetModified, textBufferSelectRange, textBufferRemoveTagByName, textBufferPlaceCursor, textBufferPasteClipboard, textBufferInsert, textBufferGetText, textBufferGetStartIter, textBufferGetSlice, textBufferGetSelectionBounds, textBufferGetSelectionBound, textBufferGetModified, textBufferGetLineCount, textBufferGetIterAtOffset, textBufferGetIterAtMark, textBufferGetIterAtLine, textBufferGetInsert, textBufferGetEndIter, textBufferEndUserAction, textBufferDeleteSelection, textBufferDelete, textBufferCutClipboard, textBufferGetMark, textBufferCopyClipboard, textBufferBeginUserAction, textBufferApplyTagByName, textBufferGetTagTable, textBufferSetText) import GI.Gtk.Objects.TextTag import GI.Gtk.Objects.TextTagTable (noTextTagTable, textTagTableLookup, TextTagTable(..), textTagTableAdd) import GI.Gtk.Objects.TextMark (textMarkGetName, TextMark(..)) import GI.Gtk.Objects.TextView (textViewSetEditable, onTextViewPopulatePopup, onTextViewMoveCursor, afterTextViewToggleOverwrite, afterTextViewMoveCursor, textViewScrollToIter, textViewScrollToMark, textViewGetOverwrite, textViewGetIterLocation, textViewGetIterAtLocation, textViewBufferToWindowCoords, textViewSetWrapMode, getTextViewBuffer) import Data.GI.Base.ManagedPtr (castTo, withManagedPtr, unsafeCastTo) import GI.GObject.Functions (signalHandlersBlockMatched, signalLookup) import Data.GI.Base.BasicTypes (GObject(..)) import GI.GObject.Flags (SignalMatchType(..)) import GI.GtkSource.Enums (SmartHomeEndType(..)) import GI.Gtk.Enums (PolicyType(..), TextWindowType(..), WrapMode(..)) import GI.Gtk.Objects.ScrolledWindow (ScrolledWindow(..), scrolledWindowSetPolicy, scrolledWindowNew) import GI.Gtk.Objects.Adjustment (noAdjustment) import GI.Gtk.Objects.Container (containerAdd) import GI.Gtk.Objects.Widget (onWidgetKeyReleaseEvent, onWidgetLeaveNotifyEvent, onWidgetMotionNotifyEvent, onWidgetKeyPressEvent, onWidgetFocusOutEvent, onWidgetButtonPressEvent, onWidgetButtonReleaseEvent, widgetAddEvents, afterWidgetFocusInEvent, widgetGrabFocus, toWidget, widgetGetParent, widgetGetWindow, widgetModifyFont) import GI.Pango.Enums (Underline(..)) import GI.GtkSource.Flags (DrawSpacesFlags(..)) import Data.GI.Base.BasicConversions (gflagsToWord) import GI.Gdk.Flags (ModifierType(..), EventMask(..)) import GI.GLib (pattern PRIORITY_DEFAULT, idleAdd, sourceRemove) import GI.Gdk (setRGBAAlpha, setRGBABlue, setRGBAGreen, setRGBARed, newZeroRGBA, RGBA, getEventButtonState) import GI.Gtk.Structs.TextIter (textIterSetOffset, textIterSetLineOffset, textIterSetLine, textIterGetBuffer, textIterStartsWord, textIterStartsLine, textIterIsEnd, textIterIsStart, textIterGetOffset, textIterGetCharsInLine, textIterGetChar, textIterForwardWordEnd, textIterForwardToLineEnd, textIterForwardSearch, textIterForwardFindChar, textIterForwardChars, textIterForwardChar, textIterEndsWord, textIterBackwardChars, textIterGetLineOffset, textIterBackwardWordStart, textIterBackwardFindChar, textIterBackwardChar, textIterEqual, textIterGetLine, textIterCopy, TextIter(..)) import Data.Text.Encoding (encodeUtf8) import qualified GI.Gdk as Gdk (Window(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import GI.Gtk.Objects.Menu (Menu(..)) import Data.GI.Base.Constructible (Constructible(..)) import Data.GI.Base.Attributes (AttrOp(..)) import Text.PrinterParser (Color(..)) import GI.Gtk (widgetOverrideFont, setTextTagUnderlineRgba) import GI.GtkSource.Objects.StyleScheme (styleSchemeGetStyle, StyleScheme(..)) import GI.GtkSource.Objects.Style import GI.Pango.Enums (Weight (..), Style (..)) transformGtkIter :: EditorIter GtkSourceView -> (TextIter -> IO a) -> IDEM (EditorIter GtkSourceView) transformGtkIter (GtkIter i) f = do new <- textIterCopy i liftIO $ f new return (GtkIter new) transformGtkIterMaybe :: EditorIter GtkSourceView -> (TextIter -> IO Bool) -> IDEM (Maybe (EditorIter GtkSourceView)) transformGtkIterMaybe (GtkIter i) f = do new <- textIterCopy i found <- liftIO $ f new return $ if found then Just (GtkIter new) else Nothing data GtkSourceView = GtkSourceView deriving( Typeable, Show ) newGtkBuffer :: Maybe FilePath -> Text -> IDEM (EditorBuffer GtkSourceView) newGtkBuffer mbFilename contents = do liftIO $ debugM "lekash" "newGtkBuffer" lm <- languageManagerNew dataDir <- getDataDir oldPath <- languageManagerGetSearchPath lm languageManagerSetSearchPath lm (Just $ T.pack (dataDir "language-specs") : oldPath) mbLang <- case mbFilename of Just filename -> do guess <- contentTypeGuess (Just $ T.pack filename) (Just $ encodeUtf8 contents) languageManagerGuessLanguage lm (Just $ T.pack filename) $ case guess of (_, True) -> Just "text/x-haskell" (t, False) -> Just t Nothing -> languageManagerGuessLanguage lm Nothing (Just "text/x-haskell") mbLang2 <- case mbLang of Nothing -> languageManagerGuessLanguage lm Nothing (Just "text/x-haskell") _ -> return mbLang buffer <- case mbLang2 of Just sLang -> bufferNewWithLanguage sLang Nothing -> bufferNew noTextTagTable bufferSetMaxUndoLevels buffer (-1) bufferBeginNotUndoableAction buffer liftIO $ debugM "lekash" "newGtkBuffer setTextBufferText" setTextBufferText buffer contents bufferEndNotUndoableAction buffer liftIO $ debugM "lekash" "newGtkBuffer setup tag table" tagTable <- textBufferGetTagTable buffer textTagNew (Just "search-match") >>= textTagTableAdd tagTable textTagNew (Just "selection-match") >>= textTagTableAdd tagTable textTagNew (Just "context") >>= textTagTableAdd tagTable textTagNew (Just "breakpoint") >>= textTagTableAdd tagTable forM_ [minBound .. maxBound :: LogRefType] $ \ refType -> textTagNew (Just . T.pack $ show refType) >>= textTagTableAdd tagTable return $ GtkBuffer buffer -- | Sets the style for a type of tag in the buffer by looking in the stylescheme -- for a style with the given name, otherwise use the provided action -- that sets some style on the TextTag (for standard sourceview styleschemes we can't -- edit the stylescheme files) setTagStyle :: Source.Buffer -> Text -> StyleScheme -> (Text -> IDEM ()) -> IDEM () setTagStyle sb tagName scheme applyDefaultStyle = do tagTable <- textBufferGetTagTable sb mbTag <- textTagTableLookup tagTable tagName forM_ mbTag $ \tag -> do mbStyle <- styleSchemeGetStyle scheme tagName case mbStyle of Just style -> applyStyle tag style Nothing -> applyDefaultStyle tagName where applyStyle :: TextTag -> Source.Style -> IDEM () applyStyle tag style = do mbBg <- getStyleBackground style forM_ mbBg (setTextTagBackground tag) mbFg <- getStyleForeground style forM_ mbFg (setTextTagForeground tag) bold <- getStyleBold style when bold (setTextTagWeight tag (fromIntegral . fromEnum $ WeightBold)) italic <- getStyleItalic style when italic (setTextTagStyle tag StyleItalic) instance TextEditor GtkSourceView where data EditorBuffer GtkSourceView = GtkBuffer Source.Buffer data EditorView GtkSourceView = GtkView Source.View data EditorMark GtkSourceView = GtkMark TextMark data EditorIter GtkSourceView = GtkIter TextIter data EditorTagTable GtkSourceView = GtkTagTable TextTagTable data EditorTag GtkSourceView = GtkTag TextTag newBuffer = newGtkBuffer applyTagByName (GtkBuffer sb) name (GtkIter first) (GtkIter last) = textBufferApplyTagByName sb name first last beginNotUndoableAction (GtkBuffer sb) = bufferBeginNotUndoableAction sb beginUserAction (GtkBuffer sb) = textBufferBeginUserAction sb canRedo (GtkBuffer sb) = getBufferCanRedo sb canUndo (GtkBuffer sb) = getBufferCanUndo sb copyClipboard (GtkBuffer sb) = textBufferCopyClipboard sb createMark (GtkView sv) refType (GtkIter i) tooltip = do sb <- getTextViewBuffer sv >>= liftIO . unsafeCastTo Source.Buffer n <- textIterGetLine i let cat = T.pack $ show refType name = T.pack (show n) <> " " <> tooltip mark <- textBufferGetMark sb name when (isNothing mark) . void $ bufferCreateSourceMark sb (Just name) cat i cutClipboard (GtkBuffer sb) = textBufferCutClipboard sb delete (GtkBuffer sb) (GtkIter first) (GtkIter last) = textBufferDelete sb first last deleteSelection (GtkBuffer sb) = void $ textBufferDeleteSelection sb True True endNotUndoableAction (GtkBuffer sb) = bufferEndNotUndoableAction sb endUserAction (GtkBuffer sb) = textBufferEndUserAction sb getEndIter (GtkBuffer sb) = GtkIter <$> textBufferGetEndIter sb getInsertMark (GtkBuffer sb) = GtkMark <$> textBufferGetInsert sb getIterAtLine (GtkBuffer sb) line = GtkIter <$> textBufferGetIterAtLine sb (fromIntegral line) getIterAtMark (GtkBuffer sb) (GtkMark m) = GtkIter <$> textBufferGetIterAtMark sb m getIterAtOffset (GtkBuffer sb) offset = GtkIter <$> textBufferGetIterAtOffset sb (fromIntegral offset) getLineCount (GtkBuffer sb) = fromIntegral <$> textBufferGetLineCount sb getModified (GtkBuffer sb) = textBufferGetModified sb getSelectionBoundMark (GtkBuffer sb) = GtkMark <$> textBufferGetSelectionBound sb getSelectionBounds (GtkBuffer sb) = (\(_, a, b) -> (GtkIter a, GtkIter b)) <$> textBufferGetSelectionBounds sb getInsertIter (GtkBuffer sb) = GtkIter <$> do insertMark <- textBufferGetInsert sb textBufferGetIterAtMark sb insertMark getSlice (GtkBuffer sb) (GtkIter first) (GtkIter last) includeHidenChars = textBufferGetSlice sb first last includeHidenChars getStartIter (GtkBuffer sb) = GtkIter <$> textBufferGetStartIter sb getTagTable (GtkBuffer sb) = GtkTagTable <$> textBufferGetTagTable sb getText (GtkBuffer sb) (GtkIter first) (GtkIter last) includeHidenChars = textBufferGetText sb first last includeHidenChars hasSelection (GtkBuffer sb) = (\(b, _, _) -> b) <$> textBufferGetSelectionBounds sb insert (GtkBuffer sb) (GtkIter i) text = textBufferInsert sb i text (-1) newView (GtkBuffer sb) mbFontString = do liftIO $ debugM "lekash" "newView (GtkSourceView)" prefs <- readIDE prefs fd <- fontDescription mbFontString sv <- viewNewWithBuffer sb -- Disable source_mark_updated handler in sv because it schedules a full redraw -- that turns out to be unnecessary and very costly in Leksah signal <- signalLookup "source_mark_updated" =<< liftIO (gobjectType (undefined :: Source.Buffer)) liftIO $ withManagedPtr sv $ \svPtr -> signalHandlersBlockMatched sb [SignalMatchTypeId, SignalMatchTypeData] signal 0 Nothing nullPtr (castPtr svPtr) liftIO $ debugM "lekash" "newView set attirbutes" setViewHighlightCurrentLine sv True setViewInsertSpacesInsteadOfTabs sv True setViewIndentOnTab sv True setViewAutoIndent sv True setViewSmartHomeEnd sv SmartHomeEndTypeBefore setViewShowLineMarks sv True liftIO $ debugM "lekash" "newView set up mark attributes" forM_ [minBound..maxBound] $ \ refType -> do let cat = T.pack $ show refType icon = case refType of ErrorRef -> "ide_error" WarningRef -> "ide_warning" TestFailureRef -> "software-update-urgent" LintRef -> "ide_suggestion" BreakpointRef -> "media-playback-pause" ContextRef -> "media-playback-start" attributes <- markAttributesNew markAttributesSetIconName attributes icon onMarkAttributesQueryTooltipText attributes $ \ mark -> maybe "" (T.drop 1 . T.dropWhile isDigit) <$> textMarkGetName mark viewSetMarkAttributes sv cat attributes (fromIntegral $ 1 + fromEnum(maxBound :: LogRefType) - fromEnum refType) textViewSetWrapMode sv (if wrapLines prefs then WrapModeWord else WrapModeNone) sw <- scrolledWindowNew noAdjustment noAdjustment containerAdd sw sv widgetOverrideFont sv (Just fd) return (GtkView sv, sw) pasteClipboard (GtkBuffer sb) clipboard (GtkIter i) defaultEditable = textBufferPasteClipboard sb clipboard (Just i) defaultEditable placeCursor (GtkBuffer sb) (GtkIter i) = textBufferPlaceCursor sb i redo (GtkBuffer sb) = bufferRedo sb removeTagByName (GtkBuffer sb) name = do first <- textBufferGetStartIter sb last <- textBufferGetEndIter sb textBufferRemoveTagByName sb name first last bufferRemoveSourceMarks sb first last (Just name) selectRange (GtkBuffer sb) (GtkIter first) (GtkIter last) = textBufferSelectRange sb first last setModified (GtkBuffer sb) modified = void $ textBufferSetModified sb modified setStyle (GtkBuffer sb) EditorStyle {..} = do liftIO $ debugM "lekash" "setStyle (GtkSourceView)" case styleName of Nothing -> return () Just str -> do styleManager <- liftIO styleSchemeManagerNew dataDir <- liftIO getDataDir styleSchemeManagerAppendSearchPath styleManager . T.pack $ dataDir "data/styles" ids <- fromMaybe [] <$> styleSchemeManagerGetSchemeIds styleManager let preferedNames = if preferDark then [str<>"-dark", str] else [str] forM_ (take 1 $ filter (`elem` ids) preferedNames) $ \ name -> do scheme <- styleSchemeManagerGetScheme styleManager name bufferSetStyleScheme sb (Just scheme) tagTable <- getTagTable (GtkBuffer sb) let isDark = name `elem` ["leksah-dark", "oblivion", "cobalt", "industrial"] setBG (dark, light) (Just tag) = background tag (if isDark then dark else light) setBG _ Nothing = return () setUnderline mbCol = maybe (return ()) (\tag -> underline tag UnderlineError mbCol) -- This is ugly, we just have to make sure we only provide -- styleschemes that include styles for these tags let applyDefaultStyling tagName = do mbTag <- lookupTag tagTable tagName case tagName of "selection-match" -> setBG matchBG mbTag "search-match" -> setBG foundBG mbTag "BreakpointRef" -> setBG breakpointBG mbTag "ContextRef" -> setBG contextBG mbTag "ErrorRef" -> setUnderline Nothing mbTag "WarningRef" -> setUnderline (Just $ Color 214 176 4) mbTag "TestFailureRef" -> setUnderline (Just $ Color 207 18 241) mbTag "LintRef" -> setUnderline (Just $ Color 21 110 209) mbTag _ -> return () let tagNames = ["selection-match", "search-match"] ++ map (T.pack . show) [ErrorRef, WarningRef, TestFailureRef, LintRef, BreakpointRef, ContextRef] forM_ tagNames $ \tagName -> do setTagStyle sb tagName scheme applyDefaultStyling setText (GtkBuffer sb) text = setTextBufferText sb text undo (GtkBuffer sb) = bufferUndo sb afterChanged (GtkBuffer sb) f = do ideR <- ask id1 <- ConnectC sb <$> afterTextBufferChanged sb (reflectIDE f ideR) return [id1] afterModifiedChanged (GtkBuffer sb) f = do ideR <- ask id1 <- ConnectC sb <$> afterTextBufferModifiedChanged sb (reflectIDE f ideR) return [id1] -- View bufferToWindowCoords (GtkView sv) (x, y) = (fromIntegral *** fromIntegral) <$> textViewBufferToWindowCoords sv TextWindowTypeWidget (fromIntegral x) (fromIntegral y) drawTabs (GtkView sv) = viewSetDrawSpaces sv [DrawSpacesFlagsTab, DrawSpacesFlagsSpace, DrawSpacesFlagsTrailing] getBuffer (GtkView sv) = GtkBuffer <$> (getTextViewBuffer sv >>= (liftIO . unsafeCastTo Source.Buffer)) getWindow (GtkView sv) = widgetGetWindow sv getIterAtLocation (GtkView sv) x y = GtkIter #ifdef MIN_VERSION_GTK_3_20 . snd #endif <$> textViewGetIterAtLocation sv (fromIntegral x) (fromIntegral y) getIterLocation (GtkView sv) (GtkIter i) = textViewGetIterLocation sv i getOverwrite (GtkView sv) = textViewGetOverwrite sv getScrolledWindow (GtkView sv) = widgetGetParent sv >>= \case Just v -> liftIO $ unsafeCastTo ScrolledWindow v Nothing -> error "getScrolledWindow failed" getEditorWidget (GtkView sv) = liftIO $ toWidget sv grabFocus (GtkView sv) = widgetGrabFocus sv scrollToMark (GtkView sv) (GtkMark m) withMargin mbAlign = uncurry (textViewScrollToMark sv m withMargin (isJust mbAlign)) $ fromMaybe (0,0) mbAlign scrollToIter (GtkView sv) (GtkIter i) withMargin mbAlign = void $ uncurry (textViewScrollToIter sv i withMargin (isJust mbAlign)) $ fromMaybe (0,0) mbAlign setFont (GtkView sv) mbFontString = do fd <- fontDescription mbFontString widgetModifyFont sv (Just fd) setIndentWidth (GtkView sv) width = setViewIndentWidth sv (fromIntegral width) setWrapMode v@(GtkView sv) wrapLines = do sw <- getScrolledWindow v if wrapLines then do textViewSetWrapMode sv WrapModeWord scrolledWindowSetPolicy sw PolicyTypeNever PolicyTypeAutomatic else do textViewSetWrapMode sv WrapModeNone scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic setRightMargin (GtkView sv) mbRightMargin = case mbRightMargin of Just n -> do setViewShowRightMargin sv True setViewRightMarginPosition sv (fromIntegral n) Nothing -> setViewShowRightMargin sv False setShowLineNumbers (GtkView sv) show = setViewShowLineNumbers sv show setTabWidth (GtkView sv) width = setViewTabWidth sv (fromIntegral width) -- Events afterFocusIn (GtkView sv) f = do ideR <- ask id1 <- ConnectC sv <$> afterWidgetFocusInEvent sv (\e -> reflectIDE f ideR >> return False) return [id1] afterMoveCursor v@(GtkView sv) f = do ideR <- ask (GtkBuffer sb) <- getBuffer v id1 <- ConnectC sv <$> afterTextViewMoveCursor sv (\_ _ _ -> reflectIDE f ideR) widgetAddEvents sv (gflagsToWord [EventMaskButtonReleaseMask]) id2 <- ConnectC sv <$> onWidgetButtonReleaseEvent sv (\e -> reflectIDE f ideR >> return False) id3 <- ConnectC sb <$> afterTextBufferEndUserAction sb (reflectIDE f ideR) return [id1, id2, id3] afterToggleOverwrite (GtkView sv) f = do ideR <- ask id1 <- ConnectC sv <$> afterTextViewToggleOverwrite sv (reflectIDE f ideR) return [id1] onButtonPress (GtkView sv) f = do id1 <- onIDE onWidgetButtonPressEvent sv f return [id1] onButtonRelease (GtkView sv) f = do id1 <- onIDE onWidgetButtonReleaseEvent sv f return [id1] onCompletion v@(GtkView sv) start cancel = do ideR <- ask (GtkBuffer sb) <- getBuffer v -- when multiple afterBufferInsertText are called quickly, -- we cancel previous idle action which was not processed, -- its handler is stored here. -- Paste operation is example of such sequential events (each word!). lastHandler <- liftIO $ newIORef Nothing id1 <- ConnectC sb <$> afterTextBufferInsertText sb (\iter text _ -> do lh <- readIORef lastHandler debugM "leksah" $ "Removing " <> show lh mapM_ sourceRemove $ maybeToList lh h <- idleAdd PRIORITY_DEFAULT $ do writeIORef lastHandler Nothing let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.' let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-' || a == '!' || a == '@' || a == '%' || a == '&' || a == '?' if T.all isIdent text || T.all isOp text then do (hasSel, iterC, _) <- textBufferGetSelectionBounds sb if not hasSel then do atC <- textIterEqual iter iterC when atC $ reflectIDE start ideR return False else do reflectIDE cancel ideR return False else do reflectIDE cancel ideR return False writeIORef lastHandler (Just h) return ()) id2 <- ConnectC sv <$> onTextViewMoveCursor sv (\_ _ _ -> reflectIDE cancel ideR) id3 <- ConnectC sv <$> onWidgetButtonPressEvent sv (\e -> reflectIDE cancel ideR >> return False) id4 <- ConnectC sv <$> onWidgetFocusOutEvent sv (\e -> reflectIDE cancel ideR >> return False) return [id1, id2, id3, id4] onKeyPress (GtkView sv) f = do id1 <- onIDE onWidgetKeyPressEvent sv f return [id1] onMotionNotify (GtkView sv) f = do id1 <- onIDE onWidgetMotionNotifyEvent sv f return [id1] onLeaveNotify (GtkView sv) f = do id1 <- onIDE onWidgetLeaveNotifyEvent sv f return [id1] onKeyRelease (GtkView sv) f = do id1 <- onIDE onWidgetKeyReleaseEvent sv f return [id1] onLookupInfo (GtkView sv) f = do widgetAddEvents sv $ gflagsToWord [EventMaskButtonReleaseMask] id1 <- onIDE onWidgetButtonReleaseEvent sv $ do e <- lift ask mod <- getEventButtonState e case mod of [ModifierTypeControlMask] -> f >> return True _ -> return False return [id1] onMotionNotifyEvent (GtkView sv) handler = do widgetAddEvents sv $ gflagsToWord [EventMaskButtonMotionMask, EventMaskButton1MotionMask] -- TODO: this doesn't work yet event gets fired anyways: restrict event to being fired when left mouse button is pressed down id1 <- onIDE onWidgetMotionNotifyEvent sv handler --TODO this is potentially slowing leksah, a better event (if there was any) could be more efficient here widgetAddEvents sv $ gflagsToWord [EventMaskButtonMotionMask, EventMaskButton1MotionMask] -- TODO: this doesn't work yet event gets fired anyways: restrict event to being fired when left mouse button is pressed down return [id1] onPopulatePopup (GtkView sv) f = do ideR <- ask id1 <- ConnectC sv <$> onTextViewPopulatePopup sv (\menu -> reflectIDE (f =<< liftIO (unsafeCastTo Menu menu)) ideR) return [id1] onSelectionChanged (GtkBuffer sb) handler = do ideR <- ask id1 <- ConnectC sb <$> onTextBufferMarkSet sb (\ _ mark -> do name <- textMarkGetName mark when (name == Just "insert") $ reflectIDE handler ideR) return [id1] -- Iter backwardCharC i = transformGtkIter i textIterBackwardChar backwardFindCharC i pred mbLimit = transformGtkIterMaybe i $ \x -> textIterBackwardFindChar x (return . pred) $ case mbLimit of Just (GtkIter limit) -> Just limit Nothing -> Nothing backwardWordStartC i = transformGtkIterMaybe i textIterBackwardWordStart backwardToLineStartC i = transformGtkIter i $ \new -> do n <- textIterGetLineOffset new textIterBackwardChars new n return () endsWord (GtkIter i) = textIterEndsWord i forwardCharC i = transformGtkIter i textIterForwardChar forwardCharsC i n = transformGtkIter i $ flip textIterForwardChars (fromIntegral n) forwardFindCharC i pred mbLimit = transformGtkIterMaybe i $ \x -> textIterForwardFindChar x (return . pred) $ case mbLimit of Just (GtkIter limit) -> Just limit Nothing -> Nothing forwardSearch (GtkIter i) str flags mbLimit = textIterForwardSearch i str flags ( case mbLimit of Just (GtkIter limit) -> Just limit Nothing -> Nothing) >>= \case (False, _, _) -> return Nothing (True, a, b) -> return $ Just (GtkIter a, GtkIter b) forwardToLineEndC i = transformGtkIter i textIterForwardToLineEnd forwardWordEndC i = transformGtkIterMaybe i textIterForwardWordEnd getChar (GtkIter i) = textIterGetChar i >>= \case '\0' -> return Nothing c -> return $ Just c getCharsInLine (GtkIter i) = fromIntegral <$> textIterGetCharsInLine i getLine (GtkIter i) = fromIntegral <$> textIterGetLine i getLineOffset (GtkIter i) = fromIntegral <$> textIterGetLineOffset i getOffset (GtkIter i) = fromIntegral <$> textIterGetOffset i isStart (GtkIter i) = textIterIsStart i isEnd (GtkIter i) = textIterIsEnd i iterEqual (GtkIter i1) (GtkIter i2) = textIterEqual i1 i2 startsLine (GtkIter i) = textIterStartsLine i startsWord (GtkIter i) = textIterStartsWord i atEnd (GtkIter i) = GtkIter <$> do buffer <- textIterGetBuffer i textBufferGetEndIter buffer atLine i line = transformGtkIter i $ flip textIterSetLine (fromIntegral line) atLineOffset i column = transformGtkIter i $ flip textIterSetLineOffset (fromIntegral column) atOffset i offset = transformGtkIter i $ flip textIterSetOffset (fromIntegral offset) atStart (GtkIter i) = GtkIter <$> do buffer <- textIterGetBuffer i textBufferGetEndIter buffer -- Tag Table newTag (GtkTagTable tt) name = GtkTag <$> do t <- textTagNew (Just name) textTagTableAdd tt t return t lookupTag (GtkTagTable tt) name = fmap GtkTag <$> textTagTableLookup tt name -- Tag background (GtkTag t) color = setTextTagBackground t . T.pack $ colorHexString color underline (GtkTag t) value Nothing = setTextTagUnderline t value underline (GtkTag t) value (Just (Color r g b)) = do col <- newZeroRGBA setRGBARed col (fromIntegral r / 255) setRGBAGreen col (fromIntegral g / 255) setRGBABlue col (fromIntegral b / 255) setRGBAAlpha col 1 setTextTagUnderline t value setTextTagUnderlineRgba t col setEditable (GtkView view) b = textViewSetEditable view b