leksah-0.16.2.2: src/IDE/Pane/SourceBuffer.hs
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fwarn-unused-imports #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Pane.SourceBuffer
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
-- | The source editor part of Leksah
--
-----------------------------------------------------------------------------------
module IDE.Pane.SourceBuffer (
IDEBuffer(..)
, BufferState(..)
, allBuffers
, maybeActiveBuf
, selectSourceBuf
, goToSourceDefinition
, goToSourceDefinition'
, goToDefinition
, insertInBuffer
, fileNew
, fileOpenThis
, filePrint
, fileRevert
, fileClose
, fileCloseAll
, fileCloseAllButPackage
, fileCloseAllButWorkspace
, fileSave
, fileSaveAll
, fileSaveBuffer
, fileCheckAll
, editUndo
, editRedo
, editCut
, editCopy
, editPaste
, editDelete
, editSelectAll
, editComment
, editUncomment
, editShiftRight
, editShiftLeft
, editToCandy
, editFromCandy
, editKeystrokeCandy
, switchBuffersCandy
, updateStyle
, updateStyle'
, addLogRef
, removeLogRefs
, removeBuildLogRefs
, removeFileExtLogRefs
, removeTestLogRefs
, removeLintLogRefs
, markRefInSourceBuf
, inBufContext
, inActiveBufContext
, align
, startComplete
, selectedText
, selectedTextOrCurrentLine
, selectedTextOrCurrentIdentifier
, insertTextAfterSelection
, selectedModuleName
, selectedLocation
, recentSourceBuffers
, newTextBuffer
, belongsToPackages
, belongsToPackages'
, belongsToPackage
, belongsToWorkspace
, belongsToWorkspace'
, getIdentifierUnderCursorFromIter
, useCandyFor
) where
import Prelude hiding(getChar, getLine)
import Control.Applicative
import System.FilePath
import System.Directory
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List hiding(insert, delete)
import Data.Maybe
import Data.Char
import Data.Typeable
import IDE.Core.State
import IDE.Utils.GUIUtils
import IDE.Utils.FileUtils
import IDE.Utils.DirectoryUtils
import IDE.SourceCandy
import IDE.SymbolNavigation
import IDE.Completion as Completion (complete,cancel, smartIndent)
import IDE.TextEditor
import Data.IORef (writeIORef,readIORef,newIORef)
import Control.Event (triggerEvent)
import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo)
import IDE.BufferMode
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (filterM, void, unless, when, liftM, forM_)
import Control.Exception as E (catch, SomeException)
import qualified IDE.Command.Print as Print
import Control.Monad.Trans.Class (MonadTrans(..))
import System.Log.Logger (errorM, warningM, debugM)
import Data.Text (Text)
import qualified Data.Text as T
(length, findIndex, replicate, lines,
dropWhileEnd, unlines, strip, null, pack, unpack)
import Data.Monoid ((<>))
import qualified Data.Text.IO as T (writeFile, readFile)
import Data.Time (UTCTime(..))
import qualified Data.Foldable as F (Foldable(..), forM_, toList)
import Data.Traversable (forM)
import Language.Haskell.HLint3 (Idea(..))
-- import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Data.Sequence as Seq
import Data.Sequence (ViewR(..), (|>))
import Data.Time.Clock (addUTCTime, diffUTCTime)
import qualified GI.Gtk.Objects.Notebook as Gtk (Notebook(..))
import qualified GI.Gtk.Objects.Window as Gtk (Window(..))
import GI.Gtk.Objects.ScrolledWindow
(setScrolledWindowShadowType, scrolledWindowSetPolicy)
import GI.Gtk.Enums
(FileChooserAction(..), WindowPosition(..), ResponseType(..),
ButtonsType(..), MessageType(..), ShadowType(..), PolicyType(..),
Orientation(..))
import GI.Gdk.Structs.EventKey
(getEventKeyState, getEventKeyKeyval)
import GI.Gdk.Functions (keyvalName)
import GI.Gdk.Flags (ModifierType(..))
import GI.Gtk.Flags (TextSearchFlags(..))
import GI.Gtk.Objects.MessageDialog
(setMessageDialogText, constructMessageDialogButtons, setMessageDialogMessageType,
MessageDialog(..))
import GI.Gtk.Objects.Dialog
(dialogRun, constructDialogUseHeaderBar)
import GI.Gtk.Objects.Window
(setWindowTitle, setWindowWindowPosition, windowSetTransientFor)
import Data.GI.Base (new')
import GI.Gtk.Objects.Widget
(widgetHide, widgetShow, widgetDestroy)
import GI.Gtk.Objects.Notebook
(notebookPageNum, notebookGetNthPage, Notebook(..))
import GI.Gtk.Objects.FileChooserDialog (FileChooserDialog(..))
import GI.Gtk.Interfaces.FileChooser
(fileChooserGetFilename, fileChooserSelectFilename,
fileChooserSetAction)
import Graphics.UI.Editor.Parameters
(dialogRun', dialogSetDefaultResponse', dialogAddButton')
import GI.Gtk.Objects.Clipboard (clipboardGet)
import GI.Gdk.Structs.Atom (atomIntern)
import GI.Gdk.Structs.EventButton (getEventButtonType)
import GI.Gdk.Enums (EventType(..))
import GI.Gtk
(boxPackStart, boxNew, Container(..),
containerAdd, infoBarGetContentArea,
labelNew, infoBarNew)
import Data.GI.Base.ManagedPtr (unsafeCastTo)
import Control.Concurrent.MVar (tryPutMVar)
--time :: MonadIO m => String -> m a -> m a
--time name action = do
-- liftIO . debugM "leksah" $ name <> " start"
-- start <- liftIO $ realToFrac <$> getPOSIXTime
-- result <- action
-- end <- liftIO $ realToFrac <$> getPOSIXTime
-- liftIO . debugM "leksah" $ name <> " took " <> show ((end - start) * 1000000) <> "us"
-- return result
allBuffers :: MonadIDE m => m [IDEBuffer]
allBuffers = liftIDE getPanes
instance RecoverablePane IDEBuffer BufferState IDEM where
saveState (p@IDEBuffer {sourceView=v}) = do
buf <- getBuffer v
ins <- getInsertMark buf
iter <- getIterAtMark buf ins
offset <- getOffset iter
case fileName p of
Nothing -> do
ct <- readIDE candy
text <- getCandylessText ct buf
return (Just (BufferStateTrans (bufferName p) text offset))
Just fn -> return (Just (BufferState fn offset))
recoverState pp (BufferState n i) = do
mbbuf <- newTextBuffer pp (T.pack $ takeFileName n) (Just n)
case mbbuf of
Just (IDEBuffer {sourceView=v}) -> do
postAsyncIDEIdle $ do
liftIO $ debugM "leksah" "SourceBuffer recoverState idle callback"
gtkBuf <- getBuffer v
iter <- getIterAtOffset gtkBuf i
placeCursor gtkBuf iter
mark <- getInsertMark gtkBuf
scrollToMark v mark 0.0 (Just (1.0,0.3))
liftIO $ debugM "leksah" "SourceBuffer recoverState done"
return mbbuf
Nothing -> return Nothing
recoverState pp (BufferStateTrans bn text i) = do
mbbuf <- newTextBuffer pp bn Nothing
case mbbuf of
Just (buf@IDEBuffer {sourceView=v}) -> do
postAsyncIDEIdle $ do
liftIO $ debugM "leksah" "SourceBuffer recoverState idle callback"
useCandy <- useCandyFor buf
gtkBuf <- getBuffer v
setText gtkBuf text
when useCandy $ modeTransformToCandy (mode buf)
(modeEditInCommentOrString (mode buf)) gtkBuf
iter <- getIterAtOffset gtkBuf i
placeCursor gtkBuf iter
mark <- getInsertMark gtkBuf
scrollToMark v mark 0.0 (Just (1.0,0.3))
liftIO $ debugM "leksah" "SourceBuffer recoverState done"
return (Just buf)
Nothing -> return Nothing
makeActive (actbuf@IDEBuffer {sourceView=sv}) = do
ideR <- ask
eBuf <- getBuffer sv
writeCursorPositionInStatusbar sv
writeOverwriteInStatusbar sv
ids1 <- eBuf `afterModifiedChanged` markActiveLabelAsChanged
ids2 <- sv `afterMoveCursor` writeCursorPositionInStatusbar sv
-- ids3 <- sv `onLookupInfo` selectInfo sv -- obsolete by hyperlinks
ids4 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv
ids5 <- eBuf `afterChanged` do
tb <- readIDE triggerBuild
void . liftIO $ tryPutMVar tb ()
activateThisPane actbuf $ concat [ids1, ids2, ids4, ids5]
triggerEventIDE (Sensitivity [(SensitivityEditor, True)])
grabFocus sv
checkModTime actbuf
return ()
closePane pane = do makeActive pane
fileClose
buildPane panePath notebook builder = return Nothing
builder pp nb w = return (Nothing,[])
-- startComplete :: IDEAction
startComplete = do
mbBuf <- maybeActiveBuf
currentState' <- readIDE currentState
case mbBuf of
Nothing -> return ()
Just (IDEBuffer {sourceView=v}) -> complete v True
-- selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer)
selectSourceBuf fp = do
fpc <- liftIO $ myCanonicalizePath fp
buffers <- allBuffers
let buf = filter (\b -> case fileName b of
Just fn -> equalFilePath fn fpc
Nothing -> False) buffers
case buf of
hdb:tl -> do
makeActive hdb
return (Just hdb)
otherwise -> do
fe <- liftIO $ doesFileExist fpc
if fe
then do
prefs <- readIDE prefs
pp <- getBestPathForId "*Buffer"
liftIO $ debugM "lekash" "selectSourceBuf calling newTextBuffer"
nbuf <- newTextBuffer pp (T.pack $ takeFileName fpc) (Just fpc)
liftIO $ debugM "lekash" "selectSourceBuf newTextBuffer returned"
return nbuf
else do
ideMessage Normal (__ "File path not found " <> T.pack fpc)
return Nothing
goToDefinition :: Descr -> IDEAction
goToDefinition idDescr = do
mbWorkspaceInfo <- getWorkspaceInfo
mbSystemInfo <- getSystemInfo
let mbPackagePath = (mbWorkspaceInfo >>= (packagePathFromScope . fst))
<|> (mbSystemInfo >>= packagePathFromScope)
mbSourcePath = (mbWorkspaceInfo >>= (sourcePathFromScope . fst))
<|> (mbSystemInfo >>= sourcePathFromScope)
liftIO . debugM "leksah" $ show (mbPackagePath, dscMbLocation idDescr, mbSourcePath)
case (mbPackagePath, dscMbLocation idDescr, mbSourcePath) of
(Just packagePath, Just loc, _) -> void (goToSourceDefinition (dropFileName packagePath) loc)
(_, Just loc, Just sourcePath) -> void (goToSourceDefinition' sourcePath loc)
(_, _, Just sp) -> void (selectSourceBuf sp)
_ -> return ()
where
packagePathFromScope :: GenScope -> Maybe FilePath
packagePathFromScope (GenScopeC (PackScope l _)) =
case dscMbModu idDescr of
Just mod -> case pack mod `Map.lookup` l of
Just pack -> pdMbSourcePath pack
Nothing -> Nothing
Nothing -> Nothing
sourcePathFromScope :: GenScope -> Maybe FilePath
sourcePathFromScope (GenScopeC (PackScope l _)) =
case dscMbModu idDescr of
Just mod -> case pack mod `Map.lookup` l of
Just pack ->
case filter (\md -> mdModuleId md == fromJust (dscMbModu idDescr))
(pdModules pack) of
(mod : tl) -> mdMbSourcePath mod
[] -> Nothing
Nothing -> Nothing
Nothing -> Nothing
goToSourceDefinition :: FilePath -> Location -> IDEM (Maybe IDEBuffer)
goToSourceDefinition packagePath loc =
goToSourceDefinition' (packagePath </> locationFile loc) loc
goToSourceDefinition' :: FilePath -> Location -> IDEM (Maybe IDEBuffer)
goToSourceDefinition' sourcePath Location{..} = do
mbBuf <- selectSourceBuf sourcePath
case mbBuf of
Just buf ->
inActiveBufContext () $ \_ sv ebuf _ _ -> do
liftIO $ debugM "lekash" "goToSourceDefinition calculating range"
lines <- getLineCount ebuf
iterTemp <- getIterAtLine ebuf (max 0 (min (lines-1)
(locationSLine -1)))
chars <- getCharsInLine iterTemp
iter <- atLineOffset iterTemp (max 0 (min (chars-1) (locationSCol -1)))
iter2Temp <- getIterAtLine ebuf (max 0 (min (lines-1) (locationELine -1)))
chars2 <- getCharsInLine iter2Temp
iter2 <- atLineOffset iter2Temp (max 0 (min (chars2-1) locationECol))
-- ### we had a problem before using postAsyncIDEIdle
postAsyncIDEIdle $ do
liftIO $ debugM "lekash" "goToSourceDefinition triggered selectRange"
selectRange ebuf iter iter2
liftIO $ debugM "lekash" "goToSourceDefinition triggered scrollToIter"
scrollToIter sv iter 0.0 (Just (1.0,0.3))
return ()
Nothing -> return ()
return mbBuf
insertInBuffer :: Descr -> IDEAction
insertInBuffer idDescr = do
mbPaneName <- lastActiveBufferPane
case mbPaneName of
Nothing -> return ()
Just name -> do
PaneC p <- paneFromName name
let mbBuf = cast p
case mbBuf of
Nothing -> return ()
Just buf ->
inBufContext () buf $ \_ _ ebuf buf _ -> do
mark <- getInsertMark ebuf
iter <- getIterAtMark ebuf mark
insert ebuf iter (dscName idDescr)
updateStyle' :: IDEBuffer -> IDEAction
updateStyle' IDEBuffer {sourceView = sv} = getBuffer sv >>= updateStyle
removeLogRefs :: (FilePath -> FilePath -> Bool) -> [LogRefType] -> IDEAction
removeLogRefs toRemove' types = do
(remove, keep) <- Seq.partition toRemove <$> readIDE allLogRefs
let removeDetails = Map.fromListWith (<>) . nub $ map (\ref ->
(logRefRootPath ref </> logRefFilePath ref,
[logRefType ref])) $ F.toList remove
modifyIDE_ (\ide -> ide{allLogRefs = keep})
buffers <- allBuffers
let matchingBufs = filter (maybe False (`Map.member` removeDetails) . fileName) buffers
F.forM_ matchingBufs $ \ (IDEBuffer {..}) -> do
buf <- getBuffer sourceView
F.forM_ (maybe [] (fromMaybe [] . (`Map.lookup` removeDetails)) fileName) $
removeTagByName buf . T.pack . show
triggerEventIDE (ErrorsRemoved False toRemove)
return ()
where
toRemove ref = toRemove' (logRefRootPath ref) (logRefFilePath ref)
&& logRefType ref `elem` types
removeFileLogRefs :: FilePath -> [LogRefType] -> IDEAction
removeFileLogRefs file types = do
liftIO . debugM "leksah" $ "removeFileLogRefs " <> file <> " " <> show types
removeLogRefs (\r f -> r </> f == file) types
removeFileExtLogRefs :: FilePath -> String -> [LogRefType] -> IDEAction
removeFileExtLogRefs root fileExt types = do
liftIO . debugM "leksah" $ "removeFileTypeLogRefs " <> root <> " " <> fileExt <> " " <> show types
removeLogRefs (\r f -> r == root && takeExtension f == fileExt) types
removePackageLogRefs :: FilePath -> [LogRefType] -> IDEAction
removePackageLogRefs root types = do
liftIO . debugM "leksah" $ "removePackageLogRefs " <> root <> " " <> show types
removeLogRefs (\r _ -> r == root) types
removeBuildLogRefs :: FilePath -> IDEAction
removeBuildLogRefs file = removeFileLogRefs file [ErrorRef, WarningRef]
removeTestLogRefs :: FilePath -> IDEAction
removeTestLogRefs root = removePackageLogRefs root [TestFailureRef]
removeLintLogRefs :: FilePath -> IDEAction
removeLintLogRefs file = removeFileLogRefs file [LintRef]
canResolve :: LogRef -> Bool
canResolve LogRef { logRefIdea = Just (_, Idea{..}) }
= ideaHint /= "Reduce duplication" && isJust ideaTo
canResolve _ = False
addLogRef :: Bool -> Bool -> LogRef -> IDEAction
addLogRef hlintFileScope backgroundBuild ref = do
liftIO . debugM "leksah" $ "addLogRef " <> show hlintFileScope <> " " <> show (logRefType ref) <> " " <> logRefFullFilePath ref
-- Put most important errors first.
-- If the importance of two errors is the same then
-- then the older one might be stale (unless it is in the same file)
allLogRefs <- readIDE allLogRefs
currentError <- readIDE currentError
let (moreImportant, rest) =
Seq.spanl (\old ->
let samePackage = logRefRootPath old == logRefRootPath ref
sameFile = logRefFullFilePath old == logRefFullFilePath ref in
-- Work out when the old ref is more important than the new
case (logRefType ref, logRefType old) of
(ErrorRef , ErrorRef ) -> sameFile
(ErrorRef , _ ) -> False
(WarningRef , ErrorRef ) -> samePackage
(WarningRef , WarningRef ) -> samePackage
(WarningRef , _ ) -> False
(TestFailureRef, ErrorRef ) -> samePackage -- Probably should never be True
(TestFailureRef, TestFailureRef) -> samePackage
(TestFailureRef, _ ) -> False
(LintRef , LintRef ) -> (if hlintFileScope then sameFile else samePackage)
&& (canResolve old
|| not (canResolve ref))
(LintRef , _ ) -> samePackage
(ContextRef , _ ) -> False
(BreakpointRef , _ ) -> False) allLogRefs
currErr = if currentError `elem` map Just (F.toList moreImportant)
then currentError
else Nothing
modifyIDE_ $ \ ide ->
ide{ allLogRefs = (moreImportant |> ref) <> rest
, currentEBC = (currErr, currentBreak ide, currentContext ide)
}
buffers <- allBuffers
let matchingBufs = filter (maybe False (equalFilePath (logRefFullFilePath ref)) . fileName) buffers
F.forM_ matchingBufs $ \ buf -> markRefInSourceBuf buf ref False
triggerEventIDE $ ErrorAdded
(not backgroundBuild && Seq.null moreImportant) (Seq.length moreImportant) ref
return ()
markRefInSourceBuf :: IDEBuffer -> LogRef -> Bool -> IDEAction
markRefInSourceBuf buf logRef scrollTo = do
useCandy <- useCandyFor buf
candy' <- readIDE candy
contextRefs <- readIDE contextRefs
prefs <- readIDE prefs
inBufContext () buf $ \_ sv ebuf buf _ -> do
let tagName = T.pack $ show (logRefType logRef)
liftIO . debugM "lekash" . T.unpack $ "markRefInSourceBuf getting or creating tag " <> tagName
liftIO $ debugM "lekash" "markRefInSourceBuf calculating range"
let start' = (srcSpanStartLine (logRefSrcSpan logRef),
srcSpanStartColumn (logRefSrcSpan logRef))
let end' = (srcSpanEndLine (logRefSrcSpan logRef),
srcSpanEndColumn (logRefSrcSpan logRef))
start <- if useCandy
then positionToCandy candy' ebuf start'
else return start'
end <- if useCandy
then positionToCandy candy' ebuf end'
else return end'
lines <- getLineCount ebuf
iterTmp <- getIterAtLine ebuf (max 0 (min (lines-1) (fst start - 1)))
chars <- getCharsInLine iterTmp
iter <- atLineOffset iterTmp (max 0 (min (chars-1) (snd start)))
iter2 <- if start == end
then do
maybeWE <- forwardWordEndC iter
case maybeWE of
Nothing -> atEnd iter
Just we -> return we
else do
newTmp <- getIterAtLine ebuf (max 0 (min (lines-1) (fst end - 1)))
chars <- getCharsInLine newTmp
new <- atLineOffset newTmp (max 0 (min (chars-1) (snd end)))
forwardCharC new
let last (Seq.viewr -> EmptyR) = Nothing
last (Seq.viewr -> xs :> x) = Just x
last _ = Nothing
latest = last contextRefs
isOldContext = case (logRefType logRef, latest) of
(ContextRef, Just ctx) | ctx /= logRef -> True
_ -> False
unless isOldContext $ do
liftIO $ debugM "lekash" "markRefInSourceBuf calling applyTagByName"
lineStart <- backwardToLineStartC iter
createMark sv (logRefType logRef) lineStart $ refDescription logRef
applyTagByName ebuf tagName iter iter2
when scrollTo $ do
liftIO $ debugM "lekash" "markRefInSourceBuf triggered placeCursor"
placeCursor ebuf iter
mark <- getInsertMark ebuf
liftIO $ debugM "lekash" "markRefInSourceBuf trigged scrollToMark"
scrollToMark sv mark 0.3 Nothing
when isOldContext $ selectRange ebuf iter iter2
-- | Tries to create a new text buffer, fails when the given filepath
-- does not exist or when it is not a text file.
newTextBuffer :: PanePath -> Text -> Maybe FilePath -> IDEM (Maybe IDEBuffer)
newTextBuffer panePath bn mbfn =
case mbfn of
Nothing -> buildPane "" Nothing
Just fn ->
do eErrorContents <- liftIO $
catch (Right <$> T.readFile fn)
(\e -> return $ Left (show (e :: IOError)))
case eErrorContents of
Right contents -> do
modTime <- liftIO $ getModificationTime fn
buildPane contents (Just modTime)
Left err -> do
ideMessage Normal (__ "Error reading file " <> T.pack err)
return Nothing
where buildPane contents mModTime = do
nb <- getNotebook panePath
prefs <- readIDE prefs
let useCandy = candyState prefs
ct <- readIDE candy
(ind,rbn) <- figureOutPaneName bn 0
buildThisPane panePath nb (builder' useCandy mbfn ind bn rbn ct prefs contents mModTime)
data CharacterCategory = IdentifierCharacter | SpaceCharacter | SyntaxCharacter
deriving (Eq)
getCharacterCategory :: Maybe Char -> CharacterCategory
getCharacterCategory Nothing = SpaceCharacter
getCharacterCategory (Just c)
| isAlphaNum c || c == '\'' || c == '_' = IdentifierCharacter
| isSpace c = SpaceCharacter
| otherwise = SyntaxCharacter
builder' :: Bool ->
Maybe FilePath ->
Int ->
Text ->
Text ->
CandyTable ->
Prefs ->
Text ->
Maybe UTCTime ->
PanePath ->
Gtk.Notebook ->
Gtk.Window ->
IDEM (Maybe IDEBuffer,Connections)
builder' useCandy mbfn ind bn rbn ct prefs fileContents modTime pp nb windows =
case textEditorType prefs of
"GtkSourceView" -> newGtkBuffer mbfn fileContents >>= makeBuffer modTime
"Yi" -> newYiBuffer mbfn fileContents >>= makeBuffer modTime
"CodeMirror" -> newCMBuffer mbfn fileContents >>= makeBuffer modTime
_ -> newDefaultBuffer mbfn fileContents >>= makeBuffer modTime
where
makeBuffer :: TextEditor editor => Maybe UTCTime -> EditorBuffer editor -> IDEM (Maybe IDEBuffer,Connections)
makeBuffer modTime buffer = do
liftIO $ debugM "lekash" "makeBuffer"
ideR <- ask
beginNotUndoableAction buffer
let mode = modeFromFileName mbfn
when (useCandy && isHaskellMode mode) $ modeTransformToCandy mode
(modeEditInCommentOrString mode) buffer
endNotUndoableAction buffer
setModified buffer False
siter <- getStartIter buffer
placeCursor buffer siter
iter <- getEndIter buffer
-- create a new SourceView Widget
(sv, sw) <- newView buffer (textviewFont prefs)
-- Files opened from the unpackDirectory are meant for documentation
-- and are not actually a source dependency, they should not be editable.
homeDir <- liftIO getHomeDirectory
let isEditable = fromMaybe True $ do
dir <- unpackDirectory prefs
let expandedDir = case dir of
'~':rest -> homeDir ++ rest
rest -> rest
file <- mbfn
return (not $ (splitDirectories expandedDir) `isPrefixOf` (splitDirectories file))
setEditable sv isEditable
setShowLineNumbers sv $ showLineNumbers prefs
setRightMargin sv $ case rightMargin prefs of
(False,_) -> Nothing
(True,v) -> Just v
setIndentWidth sv $ tabWidth prefs
setTabWidth sv 8 -- GHC treats tabs as 8 we should display them that way
drawTabs sv
updateStyle buffer
if wrapLines prefs
then scrolledWindowSetPolicy sw PolicyTypeNever PolicyTypeAutomatic
else scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic
liftIO $ debugM "lekash" "makeBuffer setScrolledWindowShadowType"
setScrolledWindowShadowType sw ShadowTypeIn
liftIO $ debugM "lekash" "makeBuffer setScrolledWindowShadowType done"
box <- boxNew OrientationVertical 0
when (not isEditable) $ liftIO $ do
bar <- infoBarNew
lab <- labelNew (Just "This file is opened in read-only mode because it comes from a non-local package")
area <- infoBarGetContentArea bar >>= unsafeCastTo Container
containerAdd area lab
-- infoBarAddButton bar "Enable editing" (fromIntegral . fromEnum $ ResponseTypeReject)
-- infoBarSetShowCloseButton bar True
boxPackStart box bar False False 0
widgetShow bar
boxPackStart box sw True True 0
modTimeRef <- liftIO $ newIORef modTime
let buf = IDEBuffer {
fileName = mbfn,
bufferName = bn,
addedIndex = ind,
sourceView =sv,
vBox = box,
modTime = modTimeRef,
mode = mode}
-- events
ids1 <- afterFocusIn sv $ makeActive buf
ids2 <- onCompletion sv (Completion.complete sv False) Completion.cancel
ids3 <- onButtonPress sv $ do
e <- lift ask
click <- getEventButtonType e
liftIDE $
case click of
EventType2buttonPress -> do
(start, end) <- getIdentifierUnderCursor buffer
selectRange buffer start end
return True
_ -> return False
(GetTextPopup mbTpm) <- triggerEvent ideR (GetTextPopup Nothing)
ids4 <- case mbTpm of
Just tpm -> sv `onPopulatePopup` \menu -> liftIO $ tpm ideR menu
Nothing -> do
sysMessage Normal "SourceBuffer>> no text popup"
return []
hasMatch <- liftIO $ newIORef False
ids5 <- onSelectionChanged buffer $ do
(iStart, iEnd) <- getSelectionBounds buffer
lStart <- (+1) <$> getLine iStart
cStart <- getLineOffset iStart
lEnd <- (+1) <$> getLine iEnd
cEnd <- getLineOffset iEnd
triggerEventIDE_ . SelectSrcSpan $
case mbfn of
Just fn -> Just (SrcSpan fn lStart cStart lEnd cEnd)
Nothing -> Nothing
let tagName = "selection-match"
hasSelection <- hasSelection buffer
m <- liftIO $ readIORef hasMatch
when m $ removeTagByName buffer tagName
r <- if hasSelection
then do
candy' <- readIDE candy
sTxt <- getCandylessPart candy' buffer iStart iEnd
let strippedSTxt = T.strip sTxt
if T.null strippedSTxt
then return False
else do
bi1 <- getStartIter buffer
bi2 <- getEndIter buffer
r1 <- forwardApplying bi1 strippedSTxt (Just iStart) tagName buffer
r2 <- forwardApplying iEnd strippedSTxt (Just bi2) tagName buffer
return (r1 || r2)
else return False
liftIO $ writeIORef hasMatch r
return ()
ids6 <- onKeyPress sv $ do
e <- lift ask
keyval <- getEventKeyKeyval e
name <- keyvalName keyval
modifier <- getEventKeyState e
liftIDE $ do
let moveToNextWord iterOp sel = do
sel' <- iterOp sel
rs <- isRangeStart sel'
if rs then return sel' else moveToNextWord iterOp sel'
let calculateNewPosition iterOp = getInsertIter buffer >>= moveToNextWord iterOp
let continueSelection keepSelBound nsel = do
if keepSelBound
then do
sb <- getSelectionBoundMark buffer >>= getIterAtMark buffer
selectRange buffer nsel sb
else
placeCursor buffer nsel
scrollToIter sv nsel 0 Nothing
case (name, map mapControlCommand modifier, keyval) of
(Just "Left",[ModifierTypeControlMask],_) -> do
calculateNewPosition backwardCharC >>= continueSelection False
return True
(Just "Left",[ModifierTypeShiftMask, ModifierTypeControlMask],_) -> do
calculateNewPosition backwardCharC >>= continueSelection True
return True
(Just "Right",[ModifierTypeControlMask],_) -> do
calculateNewPosition forwardCharC >>= continueSelection False --placeCursor buffer
return True
(Just "Right",[ModifierTypeControlMask, ModifierTypeControlMask],_) -> do
calculateNewPosition forwardCharC >>= continueSelection True
return True
(Just "BackSpace",[ModifierTypeControlMask],_) -> do -- delete word
here <- getInsertIter buffer
there <- calculateNewPosition backwardCharC
delete buffer here there
return True
(Just "underscore",[ModifierTypeControlMask, ModifierTypeControlMask],_) -> do
(start, end) <- getIdentifierUnderCursor buffer
slice <- getSlice buffer start end True
triggerEventIDE (SelectInfo slice False)
return True
-- Redundant should become a go to definition directly
(Just "minus",[ModifierTypeControlMask],_) -> do
(start, end) <- getIdentifierUnderCursor buffer
slice <- getSlice buffer start end True
triggerEventIDE (SelectInfo slice True)
return True
(Just "Return", [], _) ->
readIDE currentState >>= \case
IsCompleting _ -> return False
_ -> smartIndent sv >> return True
_ ->
-- liftIO $ print ("sourcebuffer key:",name,modifier,keyval)
return False
ids7 <- do
ideR <- ask
sw <- getScrolledWindow sv
createHyperLinkSupport sv sw (\ctrl shift iter -> do
(beg, en) <- getIdentifierUnderCursorFromIter (iter, iter)
return (beg, if ctrl then en else beg)) (\_ shift' slice ->
unless (T.null slice) $ do
-- liftIO$ print ("slice",slice)
triggerEventIDE (SelectInfo slice shift')
return ()
)
return (Just buf,concat [ids1, ids2, ids3, ids4, ids5, ids6, ids7])
forwardApplying :: TextEditor editor
=> EditorIter editor
-> Text -- txt
-> Maybe (EditorIter editor)
-> Text -- tagname
-> EditorBuffer editor
-> IDEM Bool
forwardApplying tI txt mbTi tagName ebuf = do
mbFTxt <- forwardSearch tI txt [TextSearchFlagsVisibleOnly, TextSearchFlagsTextOnly] mbTi
case mbFTxt of
Just (start, end) -> do
startsWord <- startsWord start
endsWord <- endsWord end
when (startsWord && endsWord) $
applyTagByName ebuf tagName start end
(|| (startsWord && endsWord)) <$> forwardApplying end txt mbTi tagName ebuf
Nothing -> return False
isIdent a = isAlphaNum a || a == '\'' || a == '_' -- parts of haskell identifiers
isRangeStart sel = do -- if char and previous char are of different char categories
currentChar <- getChar sel
let mbStartCharCat = getCharacterCategory currentChar
mbPrevCharCat <- getCharacterCategory <$> (backwardCharC sel >>= getChar)
return $ isNothing currentChar || currentChar == Just '\n' || mbStartCharCat /= mbPrevCharCat && (mbStartCharCat == SyntaxCharacter || mbStartCharCat == IdentifierCharacter)
-- | Get an iterator pair (start,end) delimiting the identifier currently under the cursor
getIdentifierUnderCursor :: forall editor. TextEditor editor => EditorBuffer editor -> IDEM (EditorIter editor, EditorIter editor)
getIdentifierUnderCursor buffer = do
(startSel, endSel) <- getSelectionBounds buffer
getIdentifierUnderCursorFromIter (startSel, endSel)
-- | Get an iterator pair (start,end) delimiting the identifier currently contained inside the provided iterator pair
getIdentifierUnderCursorFromIter :: TextEditor editor => (EditorIter editor, EditorIter editor) -> IDEM (EditorIter editor, EditorIter editor)
getIdentifierUnderCursorFromIter (startSel, endSel) = do
let isIdent a = isAlphaNum a || a == '\'' || a == '_'
let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'
|| a == '!' || a == '@' || a == '%' || a == '&' || a == '?'
mbStartChar <- getChar startSel
mbEndChar <- getChar endSel
let isSelectChar =
case mbStartChar of
Just startChar | isIdent startChar -> isIdent
Just startChar | isOp startChar -> isOp
_ -> const False
start <- case mbStartChar of
Just startChar | isSelectChar startChar -> do
maybeIter <- backwardFindCharC startSel (not.isSelectChar) Nothing
case maybeIter of
Just iter -> forwardCharC iter
Nothing -> return startSel
_ -> return startSel
end <- case mbEndChar of
Just endChar | isSelectChar endChar -> do
maybeIter <- forwardFindCharC endSel (not.isSelectChar) Nothing
case maybeIter of
Just iter -> return iter
Nothing -> return endSel
_ -> return endSel
return (start, end)
checkModTime :: MonadIDE m => IDEBuffer -> m (Bool, Bool)
checkModTime buf = do
currentState' <- readIDE currentState
case currentState' of
IsShuttingDown -> return (False, False)
_ -> do
let name = paneName buf
case fileName buf of
Just fn -> do
exists <- liftIO $ doesFileExist fn
if exists
then do
nmt <- liftIO $ getModificationTime fn
modTime' <- liftIO $ readIORef (modTime buf)
case modTime' of
Nothing -> error $"checkModTime: time not set " ++ show (fileName buf)
Just mt ->
if nmt /= mt -- Fonts get messed up under windows when adding this line.
-- Praises to whoever finds out what happens and how to fix this
then do
load <- readIDE (autoLoad . prefs)
if load
then do
ideMessage Normal $ __ "Auto Loading " <> T.pack fn
revert buf
return (False, True)
else do
window <- liftIDE getMainWindow
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeNone]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md (__ "File \"" <> name <> __ "\" has changed on disk.")
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "_Load From Disk") (AnotherResponseType 1)
dialogAddButton' md (__ "_Always Load From Disk") (AnotherResponseType 2)
dialogAddButton' md (__ "_Don't Load") (AnotherResponseType 3)
dialogSetDefaultResponse' md (AnotherResponseType 1)
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
AnotherResponseType 1 -> do
revert buf
return (False, True)
AnotherResponseType 2 -> do
revert buf
modifyIDE_ $ \ide -> ide{prefs = (prefs ide) {autoLoad = True}}
return (False, True)
AnotherResponseType 3 -> dontLoad fn
ResponseTypeDeleteEvent -> dontLoad fn
_ -> return (False, False)
else return (False, False)
else return (False, False)
Nothing -> return (False, False)
where
dontLoad fn = do
nmt2 <- liftIO $ getModificationTime fn
liftIO $ writeIORef (modTime buf) (Just nmt2)
return (True, True)
setModTime :: IDEBuffer -> IDEAction
setModTime buf = do
let name = paneName buf
case fileName buf of
Nothing -> return ()
Just fn -> liftIO $ E.catch
(do
nmt <- getModificationTime fn
writeIORef (modTime buf) (Just nmt))
(\(e:: SomeException) -> do
sysMessage Normal (T.pack $ show e)
return ())
fileRevert :: IDEAction
fileRevert = inActiveBufContext () $ \ _ _ _ currentBuffer _ ->
revert currentBuffer
revert :: MonadIDE m => IDEBuffer -> m ()
revert (buf@IDEBuffer{sourceView = sv}) = do
useCandy <- useCandyFor buf
ct <- readIDE candy
let name = paneName buf
case fileName buf of
Nothing -> return ()
Just fn -> liftIDE $ do
buffer <- getBuffer sv
fc <- liftIO $ readFile fn
mt <- liftIO $ getModificationTime fn
beginNotUndoableAction buffer
setText buffer $ T.pack fc
when useCandy $
modeTransformToCandy (mode buf)
(modeEditInCommentOrString (mode buf))
buffer
endNotUndoableAction buffer
setModified buffer False
return mt
liftIO $ writeIORef (modTime buf) (Just mt)
writeCursorPositionInStatusbar :: TextEditor editor => EditorView editor -> IDEAction
writeCursorPositionInStatusbar sv = do
buf <- getBuffer sv
mark <- getInsertMark buf
iter <- getIterAtMark buf mark
line <- getLine iter
col <- getLineOffset iter
triggerEventIDE (StatusbarChanged [CompartmentBufferPos (line,col)])
return ()
writeOverwriteInStatusbar :: TextEditor editor => EditorView editor -> IDEAction
writeOverwriteInStatusbar sv = do
mode <- getOverwrite sv
triggerEventIDE (StatusbarChanged [CompartmentOverlay mode])
return ()
selectInfo :: TextEditor editor => EditorView editor -> IDEAction
selectInfo sv = do
ideR <- ask
buf <- getBuffer sv
(l,r) <- getIdentifierUnderCursor buf
symbol <- getText buf l r True
triggerEvent ideR (SelectInfo symbol False)
return ()
markActiveLabelAsChanged :: IDEAction
markActiveLabelAsChanged = do
mbPath <- getActivePanePath
case mbPath of
Nothing -> return ()
Just path -> do
nb <- getNotebook path
mbBS <- maybeActiveBuf
F.forM_ mbBS (markLabelAsChanged nb)
markLabelAsChanged :: Notebook -> IDEBuffer -> IDEAction
markLabelAsChanged nb (buf@IDEBuffer{sourceView = sv}) = do
liftIO $ debugM "leksah" "markLabelAsChanged"
ebuf <- getBuffer sv
modified <- getModified ebuf
w <- getTopWidget buf
markLabel nb w modified
fileSaveBuffer :: MonadIDE m => TextEditor editor => Bool -> Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> m Bool
fileSaveBuffer query nb _ ebuf (ideBuf@IDEBuffer{sourceView = sv}) i = liftIDE $ do
ideR <- ask
window <- getMainWindow
prefs <- readIDE prefs
useCandy <- useCandyFor ideBuf
candy <- readIDE candy
(panePath,connects) <- guiPropertiesFromName (paneName ideBuf)
let mbfn = fileName ideBuf
page <- liftIO $ notebookGetNthPage nb (fromIntegral i)
if isJust mbfn && not query
then do (modifiedOnDiskNotLoaded, modifiedOnDisk) <- checkModTime ideBuf -- The user is given option to reload
modifiedInBuffer <- getModified ebuf
if modifiedOnDiskNotLoaded || modifiedInBuffer
then do
fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf
useCandy candy $fromJust mbfn
setModTime ideBuf
return True
else return modifiedOnDisk
else reifyIDE $ \ideR -> do
dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1]
setWindowTitle dialog (__ "Save File")
windowSetTransientFor dialog $ Just window
fileChooserSetAction dialog FileChooserActionSave
dialogAddButton' dialog "gtk-cancel" ResponseTypeCancel
dialogAddButton' dialog "gtk-save" ResponseTypeAccept
case mbfn of
Just fn -> void (fileChooserSelectFilename dialog fn)
Nothing -> return ()
widgetShow dialog
response <- dialogRun' dialog
mbFileName <- case response of
ResponseTypeAccept -> fileChooserGetFilename dialog
ResponseTypeCancel -> return Nothing
ResponseTypeDeleteEvent -> return Nothing
_ -> return Nothing
widgetDestroy dialog
case mbFileName of
Nothing -> return False
Just fn -> do
dfe <- doesFileExist fn
resp <- if dfe
then do md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeCancel]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __ "File already exist."
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "_Overwrite") ResponseTypeYes
dialogSetDefaultResponse' md ResponseTypeCancel
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- toEnum . fromIntegral <$> dialogRun md
widgetHide md
return resp
else return ResponseTypeYes
case resp of
ResponseTypeYes -> do
reflectIDE (do
fileSave' (forceLineEnds prefs) (removeTBlanks prefs)
nb ideBuf useCandy candy fn
closePane ideBuf
cfn <- liftIO $ myCanonicalizePath fn
newTextBuffer panePath (T.pack $ takeFileName cfn) (Just cfn)
) ideR
return True
_ -> return False
where
fileSave' :: Bool -> Bool -> Notebook -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IDEAction
fileSave' forceLineEnds removeTBlanks nb ideBuf useCandy candyTable fn = do
buf <- getBuffer sv
text <- getCandylessText candyTable buf
let text' = if removeTBlanks
then T.unlines $ map (T.dropWhileEnd $ \c -> c == ' ') $ T.lines text
else text
alreadyExists <- liftIO $ doesFileExist fn
mbModTimeBefore <- if alreadyExists
then liftIO $ Just <$> getModificationTime fn
else return Nothing
succ <- liftIO $ E.catch (do T.writeFile fn text'; return True)
(\(e :: SomeException) -> do
sysMessage Normal . T.pack $ show e
return False)
-- Truely horrible hack to work around HFS+ only having 1sec resolution
-- and ghc ignoring files unless the modifiction time has moved forward.
-- The limitation means we can do at most 1 reload a second, but
-- this hack allows us to take an advance of up to 30 reloads (by
-- moving the modidification time up to 30s into the future).
modTimeChanged <- liftIO $ case mbModTimeBefore of
Nothing -> return True
Just modTime -> do
newModTime <- getModificationTime fn
let diff = diffUTCTime modTime newModTime
if
| (newModTime > modTime) -> return True -- All good mode time has moved on
| diff < 30 -> do
setModificationTimeOnOSX fn (addUTCTime 1 modTime)
updatedModTime <- getModificationTime fn
return (updatedModTime > modTime)
| diff < 32 -> do
-- Reached our limit of how far in the future we want to set the modifiction time.
-- Using 32 instead of 31 in case NTP or something is adjusting the clock back.
warningM "leksah" $ "Modification time for " <> fn
<> " was already " <> show (diffUTCTime modTime newModTime)
<> " in the future"
-- We still want to keep the modification time the same though.
-- If it went back the future date ghc has might cause it to
-- continue to ignore the file.
setModificationTimeOnOSX fn modTime
return False
| otherwise -> do
-- This should never happen unless something else is messing
-- with the modification time or the clock.
-- If it does happen we will leave the modifiction time alone.
errorM "leksah" $ "Modification time for " <> fn
<> " was already " <> show (diffUTCTime modTime newModTime)
<> " in the future"
return True
-- Only consider the file saved if the modification time changed
-- otherwise another save is really needed to trigger ghc.
when modTimeChanged $ do
setModified buf (not succ)
markLabelAsChanged nb ideBuf
triggerEventIDE_ $ SavedFile fn
fileSave :: Bool -> IDEM Bool
fileSave query = inActiveBufContext False $ fileSaveBuffer query
fileSaveAll :: MonadIDE m => (IDEBuffer -> m Bool) -> m Bool
fileSaveAll filterFunc = do
bufs <- allBuffers
filtered <- filterM filterFunc bufs
results <- forM filtered (\buf -> inBufContext False buf (fileSaveBuffer False))
return $ True `elem` results
fileCheckBuffer :: (MonadIDE m, TextEditor editor) => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> m Bool
fileCheckBuffer nb _ ebuf ideBuf i = do
let mbfn = fileName ideBuf
if isJust mbfn
then do (_, modifiedOnDisk) <- checkModTime ideBuf -- The user is given option to reload
modifiedInBuffer <- liftIDE $ getModified ebuf
return (modifiedOnDisk || modifiedInBuffer)
else return False
fileCheckAll :: MonadIDE m => (IDEBuffer -> m [alpha]) -> m [alpha]
fileCheckAll filterFunc = do
bufs <- allBuffers
liftM concat . forM bufs $ \ buf -> do
ps <- filterFunc buf
case ps of
[] -> return []
_ -> do
modified <- inBufContext False buf fileCheckBuffer
if modified
then return ps
else return []
fileNew :: IDEAction
fileNew = do
prefs <- readIDE prefs
pp <- getBestPathForId "*Buffer"
newTextBuffer pp (__ "Unnamed") Nothing
return ()
fileClose :: IDEM Bool
fileClose = inActiveBufContext True fileClose'
fileClose' :: TextEditor editor => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> IDEM Bool
fileClose' nb _ ebuf currentBuffer i = do
window <- getMainWindow
modified <- getModified ebuf
cancel <- reifyIDE $ \ideR ->
if modified
then do
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeCancel]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __ "Save changes to document: "
<> paneName currentBuffer
<> "?"
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "_Save") ResponseTypeYes
dialogAddButton' md (__ "_Don't Save") ResponseTypeNo
dialogSetDefaultResponse' md ResponseTypeYes
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
ResponseTypeYes -> do
reflectIDE (fileSave False) ideR
return False
ResponseTypeCancel -> return True
ResponseTypeNo -> return False
_ -> return False
else return False
if cancel
then return False
else do
closeThisPane currentBuffer
F.forM_ (fileName currentBuffer) addRecentlyUsedFile
return True
fileCloseAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool
fileCloseAll filterFunc = do
bufs <- allBuffers
filtered <- filterM filterFunc bufs
if null filtered
then return True
else do
makeActive (head filtered)
r <- fileClose
if r
then fileCloseAll filterFunc
else return False
fileCloseAllButPackage :: IDEAction
fileCloseAllButPackage = do
mbActivePath <- fmap ipdPackageDir <$> readIDE activePack
bufs <- allBuffers
case mbActivePath of
Just p -> mapM_ (close' p) bufs
Nothing -> return ()
where
close' dir (buf@IDEBuffer {sourceView = sv}) = do
(pane,_) <- guiPropertiesFromName (paneName buf)
nb <- getNotebook pane
i <- notebookPageNum nb (vBox buf)
if i < 0
then throwIDE (__ "notebook page not found: unexpected")
else do
ebuf <- getBuffer sv
when (isJust (fileName buf)) $ do
modified <- getModified ebuf
when (not modified && not (isSubPath dir (fromJust (fileName buf))))
$ do fileClose' nb sv ebuf buf (fromIntegral i); return ()
fileCloseAllButWorkspace :: IDEAction
fileCloseAllButWorkspace = do
mbWorkspace <- readIDE workspace
bufs <- allBuffers
when (not (null bufs) && isJust mbWorkspace) $
mapM_ (close' (fromJust mbWorkspace)) bufs
where
close' workspace (buf@IDEBuffer {sourceView = sv}) = do
(pane,_) <- guiPropertiesFromName (paneName buf)
nb <- getNotebook pane
i <- notebookPageNum nb (vBox buf)
if i < 0
then throwIDE (__ "notebook page not found: unexpected")
else do
ebuf <- getBuffer sv
when (isJust (fileName buf)) $ do
modified <- getModified ebuf
when (not modified && not (isSubPathOfAny workspace (fromJust (fileName buf))))
$ do fileClose' nb sv ebuf buf (fromIntegral i); return ()
isSubPathOfAny workspace fileName =
let paths = ipdPackageDir <$> wsPackages workspace
in any (`isSubPath` fileName) paths
fileOpenThis :: FilePath -> IDEAction
fileOpenThis fp = do
liftIO . debugM "leksah" $ "fileOpenThis " ++ fp
prefs <- readIDE prefs
fpc <- liftIO $ myCanonicalizePath fp
buffers <- allBuffers
let buf = filter (\b -> case fileName b of
Just fn -> equalFilePath fn fpc
Nothing -> False) buffers
case buf of
hdb:_ -> do
window <- getMainWindow
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeNone]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __ "Buffer already open."
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "Make _Active") (AnotherResponseType 1)
dialogAddButton' md (__ "_Open Second") (AnotherResponseType 2)
dialogSetDefaultResponse' md (AnotherResponseType 1)
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
AnotherResponseType 2 -> reallyOpen prefs fpc
_ -> makeActive hdb
[] -> reallyOpen prefs fpc
where
reallyOpen prefs fpc = do
pp <- getBestPathForId "*Buffer"
newTextBuffer pp (T.pack $ takeFileName fpc) (Just fpc)
return ()
filePrint :: IDEAction
filePrint = inActiveBufContext () filePrint'
filePrint' :: TextEditor editor => Notebook -> EditorView view -> EditorBuffer editor -> IDEBuffer -> Int -> IDEM ()
filePrint' nb _ ebuf currentBuffer _ = do
let pName = paneName currentBuffer
window <- getMainWindow
print <- reifyIDE $ \ideR -> do
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeNone]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __"Print document: "
<> pName
<> "?"
windowSetTransientFor md (Just window)
dialogAddButton' md (__"_Print") ResponseTypeYes
dialogSetDefaultResponse' md ResponseTypeYes
dialogAddButton' md (__"_Don't Print") ResponseTypeNo
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
ResponseTypeYes -> return True
ResponseTypeCancel -> return False
ResponseTypeNo -> return False
_ -> return False
when print $ do
--real code
modified <- getModified ebuf
cancel <- reifyIDE $ \ideR ->
if modified
then do
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeNone]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __"Save changes to document: "
<> pName
<> "?"
windowSetTransientFor md (Just window)
dialogAddButton' md (__"_Save") ResponseTypeYes
dialogSetDefaultResponse' md ResponseTypeYes
dialogAddButton' md (__"_Don't Save") ResponseTypeNo
dialogAddButton' md (__"_Cancel Printing") ResponseTypeCancel
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
ResponseTypeYes -> do
reflectIDE (fileSave False) ideR
return False
ResponseTypeCancel -> return True
ResponseTypeNo -> return False
_ -> return False
else
return False
unless cancel $
case fileName currentBuffer of
Just name -> do
status <- liftIO $ Print.print name
case status of
Left error -> liftIO $ showErrorDialog (Just window) (T.pack $ show error)
Right _ -> liftIO $ showDialog (Just window) "Print job has been sent successfully" MessageTypeInfo
return ()
Nothing -> return ()
editUndo :: IDEAction
editUndo = inActiveBufContext () $ \_ view buf _ _ -> do
can <- canUndo buf
when can $ do
undo buf
scrollToCursor view
editRedo :: IDEAction
editRedo = inActiveBufContext () $ \_ view buf _ _ -> do
can <- canRedo buf
when can $ redo buf
scrollToCursor view
editDelete :: IDEAction
editDelete = inActiveBufContext () $ \_ view ebuf _ _ -> do
deleteSelection ebuf
scrollToCursor view
editSelectAll :: IDEAction
editSelectAll = inActiveBufContext () $ \_ _ ebuf _ _ -> do
start <- getStartIter ebuf
end <- getEndIter ebuf
selectRange ebuf start end
editCut :: IDEAction
editCut = inActiveBufContext () $ \_ _ ebuf _ _ -> do
clip <- clipboardGet =<< atomIntern "CLIPBOARD" False
cutClipboard ebuf clip True
editCopy :: IDEAction
editCopy = inActiveBufContext () $ \_ view ebuf _ _ -> do
clip <- clipboardGet =<< atomIntern "CLIPBOARD" False
copyClipboard ebuf clip
scrollToCursor view
editPaste :: IDEAction
editPaste = inActiveBufContext () $ \_ _ ebuf _ _ -> do
mark <- getInsertMark ebuf
iter <- getIterAtMark ebuf mark
clip <- clipboardGet =<< atomIntern "CLIPBOARD" False
pasteClipboard ebuf clip iter True
editShiftLeft :: IDEAction
editShiftLeft = do
prefs <- readIDE prefs
let str = T.replicate (tabWidth prefs) " "
b <- canShiftLeft str prefs
when b $ do
doForSelectedLines [] $ \ebuf lineNr -> do
sol <- getIterAtLine ebuf lineNr
sol2 <- forwardCharsC sol (tabWidth prefs)
delete ebuf sol sol2
return ()
where
canShiftLeft str prefs = do
boolList <- doForSelectedLines [] $ \ebuf lineNr -> do
sol <- getIterAtLine ebuf lineNr
sol2 <- forwardCharsC sol (tabWidth prefs)
str1 <- getText ebuf sol sol2 True
return (str1 == str)
return (F.foldl' (&&) True boolList)
editShiftRight :: IDEAction
editShiftRight = do
prefs <- readIDE prefs
let str = T.replicate (tabWidth prefs) " "
doForSelectedLines [] $ \ebuf lineNr -> do
sol <- getIterAtLine ebuf lineNr
insert ebuf sol str
return ()
alignChar :: Char -> IDEAction
alignChar char = do
positions <- positionsOfChar
let alignTo = F.foldl' max 0 (mapMaybe snd positions)
when (alignTo > 0) $ alignChar (Map.fromList positions) alignTo
where
positionsOfChar :: IDEM [(Int, Maybe Int)]
positionsOfChar = doForSelectedLines [] $ \ebuf lineNr -> do
sol <- getIterAtLine ebuf lineNr
eol <- forwardToLineEndC sol
line <- getText ebuf sol eol True
return (lineNr, T.findIndex (==char) line)
alignChar :: Map Int (Maybe Int) -> Int -> IDEM ()
alignChar positions alignTo = do
doForSelectedLines [] $ \ebuf lineNr ->
case lineNr `Map.lookup` positions of
Just (Just n) -> do
sol <- getIterAtLine ebuf lineNr
insertLoc <- forwardCharsC sol n
insert ebuf insertLoc (T.replicate (alignTo - n) " ")
_ -> return ()
return ()
transChar :: Char -> Char
transChar ':' = toEnum 0x2237 --PROPORTION
transChar '>' = toEnum 0x2192 --RIGHTWARDS ARROW
transChar '<' = toEnum (toEnum 0x2190) --LEFTWARDS ARROW
transChar c = c
align :: Char -> IDEAction
align = alignChar . transChar
addRecentlyUsedFile :: FilePath -> IDEAction
addRecentlyUsedFile fp = do
state <- readIDE currentState
unless (isStartingOrClosing state) $ do
recentFiles' <- readIDE recentFiles
unless (fp `elem` recentFiles') $
modifyIDE_ (\ide -> ide{recentFiles = take 12 (fp : recentFiles')})
triggerEventIDE UpdateRecent
return ()
removeRecentlyUsedFile :: FilePath -> IDEAction
removeRecentlyUsedFile fp = do
state <- readIDE currentState
unless (isStartingOrClosing state) $ do
recentFiles' <- readIDE recentFiles
when (fp `elem` recentFiles') $
modifyIDE_ (\ide -> ide{recentFiles = filter (/= fp) recentFiles'})
triggerEventIDE UpdateRecent
return ()
-- | Get the currently selected text or Nothing is no text is selected
selectedText :: IDEM (Maybe Text)
selectedText = do
candy' <- readIDE candy
inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do
hasSelection <- hasSelection ebuf
if hasSelection
then do
(i1,i2) <- getSelectionBounds ebuf
text <- getCandylessPart candy' ebuf i1 i2
return $ Just text
else return Nothing
-- | Get the currently selected text, or, if none, the current line text
selectedTextOrCurrentLine :: IDEM (Maybe Text)
selectedTextOrCurrentLine = do
candy' <- readIDE candy
inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do
hasSelection <- hasSelection ebuf
(i1, i2) <- if hasSelection
then getSelectionBounds ebuf
else do
(i, _) <- getSelectionBounds ebuf
line <- getLine i
iStart <- getIterAtLine ebuf line
iEnd <- forwardToLineEndC iStart
return (iStart, iEnd)
Just <$> getCandylessPart candy' ebuf i1 i2
-- | Get the currently selected text, or, if none, tries to selected the current identifier (the one under the cursor)
selectedTextOrCurrentIdentifier :: IDEM (Maybe Text)
selectedTextOrCurrentIdentifier = do
st <- selectedText
case st of
Just t -> return $ Just t
Nothing -> do
candy' <- readIDE candy
inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do
(l,r) <- getIdentifierUnderCursor ebuf
t <- getCandylessPart candy' ebuf l r
return $ if T.null t
then Nothing
else Just t
selectedLocation :: IDEM (Maybe (Int, Int))
selectedLocation = do
candy' <- readIDE candy
inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do
useCandy <- useCandyFor currentBuffer
(start, _) <- getSelectionBounds ebuf
line <- getLine start
lineOffset <- getLineOffset start
res <- if useCandy
then positionFromCandy candy' ebuf (line, lineOffset)
else return (line, lineOffset)
return $ Just res
insertTextAfterSelection :: Text -> IDEAction
insertTextAfterSelection str = do
candy' <- readIDE candy
inActiveBufContext () $ \_ _ ebuf currentBuffer _ -> do
useCandy <- useCandyFor currentBuffer
hasSelection <- hasSelection ebuf
when hasSelection $ do
realString <- if useCandy then stringToCandy candy' str else return str
(_,i) <- getSelectionBounds ebuf
insert ebuf i realString
(_,i1) <- getSelectionBounds ebuf
i2 <- forwardCharsC i1 (T.length realString)
selectRange ebuf i1 i2
-- | Returns the packages to which this file belongs
-- uses the 'bufferProjCache' and might extend it
belongsToPackages :: MonadIDE m => FilePath -> m [IDEPackage]
belongsToPackages fp = do
bufferToProject' <- readIDE bufferProjCache
ws <- readIDE workspace
case Map.lookup fp bufferToProject' of
Just p -> return p
Nothing -> case ws of
Nothing -> return []
Just workspace -> do
let res = filter (belongsToPackage fp) (wsPackages workspace)
modifyIDE_ (\ide -> ide{bufferProjCache = Map.insert fp res bufferToProject'})
return res
-- | Returns the packages to which this buffer belongs
-- uses the 'bufferProjCache' and might extend it
belongsToPackages' :: MonadIDE m => IDEBuffer -> m [IDEPackage]
belongsToPackages' = maybe (return []) belongsToPackages . fileName
-- | Checks whether a file belongs to a package (includes files in
-- sandbox source dirs)
belongsToPackage :: FilePath -> IDEPackage -> Bool
belongsToPackage f = (`isSubPath` f) . ipdPackageDir
-- | Checks whether a file belongs to the workspace
belongsToWorkspace :: MonadIDE m => FilePath -> m Bool
belongsToWorkspace fp = not . null <$> belongsToPackages fp
-- | Checks whether a file belongs to the workspace
belongsToWorkspace' :: MonadIDE m => IDEBuffer -> m Bool
belongsToWorkspace' = maybe (return False) belongsToWorkspace . fileName
useCandyFor :: MonadIDE m => IDEBuffer -> m Bool
useCandyFor aBuffer = do
prefs <- readIDE prefs
return (candyState prefs && isHaskellMode (mode aBuffer))
switchBuffersCandy :: IDEAction
switchBuffersCandy = do
prefs <- readIDE prefs
buffers <- allBuffers
forM_ buffers $ \b@IDEBuffer{sourceView=sv} -> do
buf <- getBuffer sv
if candyState prefs
then modeTransformToCandy (mode b) (modeEditInCommentOrString (mode b)) buf
else modeTransformFromCandy (mode b) buf