leksah-0.1: src/IDE/FindPane.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.FindPane
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>
-- Stability : experimental
-- Portability : portable
--
-- | The pane of ide for searching in a text buffer
--
-------------------------------------------------------------------------------
module IDE.FindPane (
IDEFind(..)
, FindAction(..)
, FindState(..)
, editFind
) where
import Graphics.UI.Gtk hiding (get)
import Graphics.UI.Gtk.SourceView
import Data.Maybe
import Control.Monad.Reader
import Data.List
import IDE.Core.State
import IDE.Framework.ViewFrame
import IDE.SourceEditor
-------------------------------------------------------------------------------
--
-- * Interface
--
class FindAction alpha where
doFind :: alpha
editFindInc :: SearchHint -> alpha
editFindKey :: Event -> alpha
editGotoLine :: alpha
editGotoLineEnd :: alpha
editGotoLineKey :: Event -> alpha
instance FindAction IDEAction where
doFind = doFind'
editFindInc = editFindInc'
editFindKey = editFindKey'
editGotoLine = editGotoLine'
editGotoLineEnd = editGotoLineEnd'
editGotoLineKey = editGotoLineKey'
instance IDEObject IDEFind
instance CastablePane IDEFind where
casting _ = FindCasting
downCast _ (PaneC a) = case casting a of
FindCasting -> Just a
_ -> Nothing
instance Recoverable FindState where
toPaneState a = FindSt a
instance Pane IDEFind
where
primPaneName _ = "Find"
getAddedIndex _ = 0
getTopWidget = castToWidget . findBox
paneId b = "*Find"
makeActive p = throwIDE "don't activate find bar"
close pane = do
(panePath,_) <- guiPropertiesFromName (paneName pane)
nb <- getNotebook panePath
mbI <- lift $notebookPageNum nb (getTopWidget pane)
case mbI of
Nothing -> lift $ do
sysMessage Normal "notebook page not found: unexpected"
return ()
Just i -> do
lift $notebookRemovePage nb i
removePaneAdmin pane
instance RecoverablePane IDEFind FindState where
saveState p = do
mbFind <- getPane FindCasting
case mbFind of
Nothing -> return Nothing
Just p -> lift $ do
return (Just (StateC FindState))
recoverState pp FindState = do
nb <- getNotebook pp
initFind pp nb
-------------------------------------------------------------------------------
--
-- * Implementation
--
doFind' :: IDEAction
doFind' = do
find :: IDEFind <- getFind
lift $ bringPaneToFront find
lift $ widgetGrabFocus (getTopWidget find)
getFind :: IDEM IDEFind
getFind = do
mbFind <- getPane FindCasting
case mbFind of
Nothing -> do
prefs <- readIDE prefs
layout <- readIDE layout
let pp = getStandardPanePath (controlPanePath prefs) layout
nb <- getNotebook pp
initFind pp nb
mbFind <- getPane FindCasting
case mbFind of
Nothing -> throwIDE "Can't init find pane"
Just m -> return m
Just m -> return m
initFind :: PanePath -> Notebook -> IDEAction
initFind panePath nb = do
ideR <- ask
panes <- readIDE panes
paneMap <- readIDE paneMap
prefs <- readIDE prefs
currentInfo <- readIDE currentInfo
(buf,cids) <- lift $ do
hBox <- hBoxNew False 10
bBox <- hButtonBoxNew
entry <- entryNew
widgetSetName entry "searchEntry"
caseSensitiveButton <- toggleButtonNew
buttonSetLabel caseSensitiveButton "Case sensitive"
widgetSetName caseSensitiveButton "caseSensitiveButton"
entireWordButton <- toggleButtonNew
buttonSetLabel entireWordButton "Entire word"
widgetSetName entireWordButton "entireWordButton"
wrapAroundButton <- toggleButtonNew
buttonSetLabel wrapAroundButton "Wrap around"
toggleButtonSetActive wrapAroundButton True
widgetSetName wrapAroundButton "wrapAroundButton"
spinL <- spinButtonNewWithRange 1.0 1000.0 10.0
widgetSetName spinL "gotoLineEntry"
boxPackStart hBox entry PackNatural 10
boxPackStart bBox caseSensitiveButton PackNatural 10
boxPackStart bBox entireWordButton PackNatural 10
boxPackStart bBox wrapAroundButton PackNatural 10
boxPackStart hBox bBox PackNatural 10
boxPackStart hBox spinL PackNatural 10
entry `afterInsertText` (\ _ _ -> do
runReaderT ((editFindInc Insert)::IDEAction) ideR
t <- entryGetText entry
return (length t))
entry `afterDeleteText` (\ _ _ -> do runReaderT ((editFindInc Delete)::IDEAction)
ideR; return ())
entry `afterKeyPress` (\ e -> do runReaderT ((editFindKey e)::IDEAction)
ideR; return True)
spinL `afterKeyPress` (\ e -> do runReaderT ((editGotoLineKey e)::IDEAction)
ideR; return True)
spinL `afterEntryActivate` runReaderT editGotoLineEnd ideR
spinL `afterFocusOut` (\ _ -> do runReaderT (editGotoLineEnd::IDEAction) ideR;
return False)
let find = IDEFind hBox caseSensitiveButton wrapAroundButton entireWordButton
spinL entry
notebookInsertOrdered nb hBox (paneName find)
widgetShowAll hBox
return (find,[])
addPaneAdmin buf (BufConnections [] [] []) panePath
lift $widgetGrabFocus (findBox buf)
getFindEntry' :: IDEFind -> Entry
getFindEntry' f = findEntry f
getCaseSensitive' :: IDEFind -> ToggleButton
getCaseSensitive' f = caseSensitive f
getWrapAround' :: IDEFind -> ToggleButton
getWrapAround' f = wrapAround f
getEntireWord' :: IDEFind -> ToggleButton
getEntireWord' f = entireWord f
getGotoLineSpin' :: IDEFind -> SpinButton
getGotoLineSpin' f = gotoLine f
red = Color 640000 10000 10000
white = Color 64000 64000 64000
black = Color 0 0 0
{-- can't be used currently becuase of an export error
toEnum 1 = SourceSearchVisibleOnly
toEnum 2 = SourceSearchTextOnly
toEnum 4 = SourceSearchCaseInsensitive
--}
-- | Keys for searching
editFindKey' :: Event -> IDEAction
editFindKey' k@(Key _ _ _ _ _ _ _ _ _ _)
| eventKeyName k == "Down" =
editFindInc Forward
| eventKeyName k == "Up" =
editFindInc Backward
| eventKeyName k == "Escape" = do
--entry <- getFindEntry
inBufContext' () $ \_ gtkbuf currentBuffer _ -> lift $ do
i1 <- textBufferGetStartIter gtkbuf
i2 <- textBufferGetEndIter gtkbuf
textBufferRemoveTagByName gtkbuf "found" i1 i2
startMark <- textBufferGetInsert gtkbuf
st1 <- textBufferGetIterAtMark gtkbuf startMark
textBufferPlaceCursor gtkbuf st1
widgetGrabFocus $ sourceView currentBuffer
| otherwise = return ()
editFindKey' _ = return ()
editFindInc' :: SearchHint -> IDEAction
editFindInc' hint = do
find :: IDEFind <- getFind
let entry = getFindEntry' find
lift $ widgetGrabFocus entry
lift $ bringPaneToFront find
when (hint == Initial) $ lift $ editableSelectRegion entry 0 (-1)
search <- lift $entryGetText entry
if null search
then return ()
else do
let caseSensitiveW = getCaseSensitive' find
caseSensitive <- lift $toggleButtonGetActive caseSensitiveW
let entireWButton = getEntireWord' find
entireW <- lift $toggleButtonGetActive entireWButton
let wrapAroundButton = getWrapAround' find
wrapAround <- lift $toggleButtonGetActive wrapAroundButton
res <- editFind entireW caseSensitive wrapAround search "" hint
if res || null search
then lift $do
widgetModifyBase entry StateNormal white
widgetModifyText entry StateNormal black
else lift $do
widgetModifyBase entry StateNormal red
widgetModifyText entry StateNormal white
lift $do
widgetGrabFocus entry
editableSelectRegion entry 0 (-1)
editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool
editFind entireWord caseSensitive wrapAround search dummy hint =
let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in
if null search
then return False
else inBufContext' False $ \_ gtkbuf currentBuffer _ -> lift $ do
i1 <- textBufferGetStartIter gtkbuf
i2 <- textBufferGetEndIter gtkbuf
textBufferRemoveTagByName gtkbuf "found" i1 i2
startMark <- textBufferGetInsert gtkbuf
st1 <- textBufferGetIterAtMark gtkbuf startMark
mbsr2 <-
if hint == Backward
then do
textIterBackwardChar st1
textIterBackwardChar st1
mbsr <- backSearch st1 search searchflags entireWord searchflags
case mbsr of
Nothing ->
if wrapAround
then do backSearch i2 search searchflags entireWord searchflags
else return Nothing
Just (start,end) -> return (Just (start,end))
else do
if hint == Forward
then textIterForwardChar st1
else return True
mbsr <- forwardSearch st1 search searchflags entireWord searchflags
case mbsr of
Nothing ->
if wrapAround
then do forwardSearch i1 search searchflags entireWord searchflags
else return Nothing
Just (start,end) -> return (Just (start,end))
case mbsr2 of
Just (start,end) -> do --found
--widgetGrabFocus sourceView
textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing
textBufferApplyTagByName gtkbuf "found" start end
textBufferPlaceCursor gtkbuf start
return True
Nothing -> return False
where
backSearch iter string flags entireWord searchflags = do
mbsr <- sourceIterBackwardSearch iter search searchflags Nothing
case mbsr of
Nothing -> return Nothing
Just (iter1,iter2) ->
if entireWord
then do
b1 <- textIterStartsWord iter1
b2 <- textIterEndsWord iter2
if b1 && b2 then return $Just (iter1,iter2) else return Nothing
else return (Just (iter1,iter2))
forwardSearch iter string flags entireWord searchflags = do
mbsr <- sourceIterForwardSearch iter search searchflags Nothing
case mbsr of
Nothing -> return Nothing
Just (iter1,iter2) ->
if entireWord
then do
b1 <- textIterStartsWord iter1
b2 <- textIterEndsWord iter2
if b1 && b2 then return $Just (iter1,iter2) else return Nothing
else return $Just (iter1,iter2)
editGotoLine' :: IDEAction
editGotoLine' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do
find :: IDEFind <- getFind
let spin = getGotoLineSpin' find
lift $ bringPaneToFront find
lift $do
max <- textBufferGetLineCount gtkbuf
spinButtonSetRange spin 1.0 (fromIntegral max)
widgetGrabFocus spin
editGotoLineKey' :: Event -> IDEAction
editGotoLineKey' k@(Key _ _ _ _ _ _ _ _ _ _)
| eventKeyName k == "Escape" =
inBufContext' () $ \_ gtkbuf currentBuffer _ -> do
find :: IDEFind <- getFind
let spin = getGotoLineSpin' find
lift $ do
widgetGrabFocus $ sourceView currentBuffer
| otherwise = return ()
editGotoLineKey' _ = return ()
editGotoLineEnd' :: IDEAction
editGotoLineEnd' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do
find :: IDEFind <- getFind
let spin = getGotoLineSpin' find
lift $ bringPaneToFront find
lift $ do
line <- spinButtonGetValueAsInt spin
iter <- textBufferGetStartIter gtkbuf
textIterSetLine iter (line - 1)
textBufferPlaceCursor gtkbuf iter
textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing
widgetGrabFocus $ sourceView currentBuffer