{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC  -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances -XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- 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
,   goToDefinition

,   fileNew
,   fileOpenThis
,   fileOpen
,   fileRevert
,   fileClose
,   fileCloseAll
,   fileCloseAllButPackage
,   fileSave
,   fileSaveAll
,   fileSaveBuffer
,   fileCheckAll
,   editUndo
,   editRedo
,   editCut
,   editCopy
,   editPaste
,   editDelete
,   editSelectAll

,   editComment
,   editUncomment
,   editShiftRight
,   editShiftLeft

,   editToCandy
,   editFromCandy
,   editKeystrokeCandy
,   editCandy

,   markRefInSourceBuf
,   inBufContext'
,   inBufContext
,   inActiveBufContext'
,   inActiveBufContext

,   align
,   startComplete

,   selectedText
,   insertTextAfterSelection
,   selectedModuleName
,   selectedLocation
,   recentSourceBuffers
,   newTextBuffer
) where

import Graphics.UI.Gtk hiding (afterToggleOverwrite)
import Graphics.UI.Gtk.SourceView
import Graphics.UI.Gtk.Multiline.TextView
import Graphics.UI.Gtk.General.Enums	(Click(..))
import Graphics.UI.Gtk.Gdk.Events (eventClick)
import Control.Monad.Reader
import System.IO
import System.FilePath
import System.Directory
import Text.Printf
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import Data.Maybe
import Data.Typeable
import System.Time

import IDE.Core.State
import IDE.FileUtils
import IDE.SourceCandy
import IDE.Completion as Completion (complete,cancel)
import Debug.Trace (trace)
import qualified System.IO.UTF8 as UTF8
import Data.IORef (writeIORef,readIORef,newIORef,IORef(..))
import Graphics.UI.Frame.Panes (IDEPane(..))
import Data.Char (isAlphaNum)
import Control.Event (triggerEvent)
import SrcLoc
    (srcLocCol, srcLocLine, srcSpanEnd, srcSpanStart)
import IDE.Metainfo.GHCUtils (parseHeader)
import GHC (SrcLoc(..), unLoc, moduleNameString, HsModule(..))

--
-- | A text editor pane description
--
data IDEBuffer      =   IDEBuffer {
    fileName        ::  Maybe FilePath
,   bufferName      ::  String
,   addedIndex      ::  Int
,   sourceView      ::  SourceView
,   scrolledWindow  ::  ScrolledWindow
,   modTime         ::  IORef (Maybe (ClockTime))
,   language        ::  Maybe String
} deriving (Typeable)

data BufferState            =   BufferState FilePath Int
                            |   BufferStateTrans String String Int
    deriving(Eq,Ord,Read,Show,Typeable)

instance IDEObject IDEBuffer
instance Pane IDEBuffer IDEM
    where
    primPaneName    =   bufferName
    getAddedIndex   =   addedIndex
    getTopWidget    =   castToWidget . scrolledWindow
    paneId b        =   case fileName b of
                            Just s  -> s
                            Nothing -> "?" ++ bufferName b
    makeActive actbuf = do
      ideR    <-  ask
      sbLC    <-  getStatusbarLC
      sbIO    <-  getStatusbarIO
      infos   <-  readIDE accessibleInfo
      let sv = sourceView actbuf
      (cids) <- reifyIDE $ \ideR   -> do
          gtkBuf  <- textViewGetBuffer sv
          bringPaneToFront actbuf
          writeCursorPositionInStatusbar sv sbLC
          writeOverwriteInStatusbar sv sbIO
          id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markActiveLabelAsChanged) ideR
          id2 <- sv `afterMoveCursor`
              (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC)
          id3 <- gtkBuf `afterEndUserAction`  writeCursorPositionInStatusbar sv sbLC
          sv `widgetAddEvents` [ButtonReleaseMask]
          id5 <- sv `onButtonRelease`
            (\ e -> do
              writeCursorPositionInStatusbar sv sbLC
              when (controlIsPressed e) $ showInfo sv ideR
              return False)
          id6 <- sv `afterToggleOverwrite`  writeOverwriteInStatusbar sv sbIO
          return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3]
      activatePane actbuf cids
      triggerEventIDE (Sensitivity [(SensitivityEditor, True)])
      checkModTime actbuf
      return ()
    close pane = do makeActive pane
                    fileClose

instance RecoverablePane IDEBuffer BufferState IDEM where
    saveState p     =   do  buf     <-  liftIO $ textViewGetBuffer (sourceView p)
                            ins     <-  liftIO $ textBufferGetInsert buf
                            iter    <-  liftIO $ textBufferGetIterAtMark buf ins
                            offset  <-  liftIO $ textIterGetOffset iter
                            case fileName p of
                                Nothing ->  do
                                    ct      <-  readIDE candy
                                    text    <-  liftIO $ 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 (takeFileName n) (Just n)
        case mbbuf of
            Just buf -> liftIO $ do
                gtkBuf  <-  textViewGetBuffer (sourceView buf)
                iter    <-  textBufferGetIterAtOffset gtkBuf i
                textBufferPlaceCursor gtkBuf iter
                mark    <-  textBufferGetInsert gtkBuf
                idleAdd  (do
                    textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))
                    return False) priorityDefaultIdle
                return ()
            Nothing -> return ()
    recoverState pp (BufferStateTrans bn text i) =   do
        mbbuf    <-  newTextBuffer pp bn Nothing
        useCandy    <- getCandyState
        case mbbuf of
            Just buf -> do
                candy'      <- readIDE candy
                liftIO $ do
                    gtkBuf  <-  textViewGetBuffer (sourceView buf)
                    textBufferSetText gtkBuf text

                    when useCandy $ transformToCandy candy' gtkBuf
                    iter    <-  textBufferGetIterAtOffset gtkBuf i
                    textBufferPlaceCursor gtkBuf iter
                    mark    <-  textBufferGetInsert gtkBuf
                    idleAdd  (do
                        textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))
                        return False) priorityDefaultIdle
                    return ()
            Nothing -> return ()


startComplete :: IDEAction
startComplete = do
    trace "start complete" return ()
    mbBuf <- maybeActiveBuf
    currentState' <- readIDE currentState
    case mbBuf of
        Nothing     -> return ()
        Just buf    -> complete (sourceView buf) True

selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer)
selectSourceBuf fp = do
    fpc <-  liftIO $ canonicalizePath 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"
                    nbuf <- newTextBuffer pp (takeFileName fpc) (Just fpc)
                    return nbuf
                else return Nothing

recentSourceBuffers :: IDEM [PaneName]
recentSourceBuffers = do
    recentPanes' <- readIDE recentPanes
    mbBufs       <- mapM mbPaneFromName recentPanes'
    return $ map paneName ((catMaybes $ map (\ (PaneC p) -> cast p) $ catMaybes mbBufs) :: [IDEBuffer])

lastActiveBufferPane :: IDEM (Maybe PaneName)
lastActiveBufferPane = do
    rs <- recentSourceBuffers
    case rs of
        (hd : _) -> return (Just hd)
        _        -> return Nothing

goToDefinition :: Descr -> IDEAction
goToDefinition idDescr = do
    mbAccesibleInfo      <-  readIDE accessibleInfo
    mbCurrentInfo        <-  readIDE currentInfo
    if isJust mbAccesibleInfo && isJust mbCurrentInfo
        then do
            let packageId       =   pack $ descrModu idDescr
            let mbPack          =   case packageId `Map.lookup` fst
                                            (fromJust mbAccesibleInfo) of
                                        Just it ->  Just it
                                        Nothing ->  packageId `Map.lookup` fst (fst
                                                                 (fromJust mbCurrentInfo))
            case mbPack of
                Just pack       ->  case filter (\md -> moduleIdMD md == descrModu idDescr)
                                                    (exposedModulesPD pack) of
                                        (mod : tl)   ->  if isJust (mbSourcePathMD mod)
                                                        then goToSourceDefinition
                                                                (fromJust $ mbSourcePathMD mod)
                                                                (mbLocation idDescr)
                                                        else return ()
                                        []          -> do ideMessage Normal "no module"
                Nothing         ->  do ideMessage Normal "no package"
        else ideMessage Normal  "no infos"

goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction
goToSourceDefinition fp mbLocation = do
    mbBuf     <- selectSourceBuf fp
    when (isJust mbBuf && isJust mbLocation) $
        inActiveBufContext () $ \_ gtkbuf buf _ -> do
            let location    =   fromJust mbLocation
            lines           <-  textBufferGetLineCount gtkbuf
            iter            <-  textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1)
                                    ((locationSLine location) -1)))
            chars           <-  textIterGetCharsInLine iter
            textIterSetLineOffset iter (max 0 (min (chars-1) (locationSCol location)))
            iter2           <-  textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1)
                                    ((locationELine location) -1)))
            chars2          <-  textIterGetCharsInLine iter2
            textIterSetLineOffset iter2 (max 0 (min (chars2-1) (locationECol location)))
            textBufferPlaceCursor gtkbuf iter
            smark           <-  textBufferGetSelectionBound gtkbuf
            textBufferMoveMark gtkbuf smark iter2
            -- ### we had a problem before using this idleAdd thing
            idleAdd  (do
                textViewScrollToIter (sourceView buf) iter 0.0 (Just (0.3,0.3))
                return False) priorityDefaultIdle
            return ()

markRefInSourceBuf :: Int -> IDEBuffer -> LogRef -> Bool -> IDEAction
markRefInSourceBuf index buf logRef scrollTo = do
    useCandy    <- getCandyState
    candy'      <- readIDE candy
    contextRefs <- readIDE contextRefs
    inBufContext () buf $ \_ gtkbuf buf _ -> do
        let tagName = (show $ logRefType logRef) ++ show index
        tagTable <- textBufferGetTagTable gtkbuf
        mbTag <- textTagTableLookup tagTable tagName
        case mbTag of
            Just existingTag -> do
                i1 <- textBufferGetStartIter gtkbuf
                i2 <- textBufferGetEndIter gtkbuf
                textBufferRemoveTagByName gtkbuf tagName i1 i2
            Nothing -> do
                errtag <- textTagNew (Just tagName)
                case logRefType logRef of
                    ErrorRef -> do
                        set errtag[textTagUnderline := UnderlineError]
                    WarningRef -> do
                        set errtag[textTagUnderline := UnderlineError]
                    BreakpointRef -> do
                        set errtag[textTagBackground := "yellow"]
                    ContextRef -> do
                        set errtag[textTagBackground := "pink"]
                textTagTableAdd tagTable errtag

        let start' = srcLocToPair $ srcSpanStart (logRefSrcSpan logRef)
        let end'   = srcLocToPair $ srcSpanEnd   (logRefSrcSpan logRef)
        start <- if useCandy
                    then positionToCandy candy' gtkbuf start'
                    else return start'
        end   <- if useCandy
                    then positionToCandy candy' gtkbuf end'
                    else return end'
        lines   <-  textBufferGetLineCount gtkbuf
        iter    <-  textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) ((fst start)-1)))
        chars   <-  textIterGetCharsInLine iter
        textIterSetLineOffset iter (max 0 (min (chars-1) (snd start)))

        iter2 <- if start == end
            then do
                copy <- textIterCopy iter
                textIterForwardWordEnd copy
                return copy
            else do
                new     <-  textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) ((fst end)-1)))
                chars   <-  textIterGetCharsInLine new
                textIterSetLineOffset new (max 0 (min (chars-1) (snd end)))
                textIterForwardChar new
                return new

        let latest = if null contextRefs then Nothing else Just $ last contextRefs
        let isOldContext = case (logRefType logRef, latest) of
                                (ContextRef, Just ctx) | ctx /= logRef -> True
                                _ -> False
        unless isOldContext $ textBufferApplyTagByName gtkbuf tagName iter iter2
        when scrollTo $ textBufferPlaceCursor gtkbuf iter
        mark <- textBufferGetInsert gtkbuf
        when scrollTo $ do
            idleAdd (do
                textViewScrollToMark (sourceView buf) mark 0.3 Nothing
                when (isOldContext && scrollTo) $ textBufferSelectRange gtkbuf iter iter2
                return False) priorityDefaultIdle
            return ()

srcLocToPair :: SrcLoc -> (Int,Int)
srcLocToPair srcLoc = (srcLocLine srcLoc, srcLocCol srcLoc)

allBuffers :: IDEM [IDEBuffer]
allBuffers = getPanes

maybeActiveBuf :: IDEM (Maybe IDEBuffer)
maybeActiveBuf = do
    mbActivePane <- getActivePane
    mbPane       <- lastActiveBufferPane
    case (mbPane,mbActivePane) of
        (Just paneName1, Just (paneName2,_)) | paneName1 == paneName2 -> do
            (PaneC pane) <- paneFromName paneName1
            let mbActbuf = cast pane
            return mbActbuf
        _ -> return Nothing

newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM (Maybe IDEBuffer)
newTextBuffer panePath bn mbfn = do
    cont <- case mbfn of
                Nothing -> return True
                Just fn -> liftIO $ doesFileExist fn
    if cont
        then do
            nb      <-  getNotebook panePath
            prefs   <-  readIDE prefs
            bs      <-  getCandyState
            ct      <-  readIDE candy
            (ind,rbn) <- figureOutPaneName bn 0
            pane    <-  newPane panePath nb (builder bs mbfn ind bn rbn ct prefs)
            return (Just pane)
        else do
            ideMessage Normal ("File does not exist " ++ (fromJust mbfn))
            return Nothing

builder :: Bool ->
    Maybe FilePath ->
    Int ->
    String ->
    String ->
    CandyTable ->
    Prefs ->
    PanePath ->
    Notebook ->
    Window ->
    IDERef ->
    IO (IDEBuffer,Connections)
builder bs mbfn ind bn rbn ct prefs pp nb windows ideR = do
    lm       <- sourceLanguageManagerNew
    (mbLanguage, mbSLang)  <- sourceLanguageForFilename lm mbfn

    -- create a new SourceBuffer object
    buffer   <- case mbSLang of
                    Just sLang -> sourceBufferNewWithLanguage sLang
                    Nothing -> sourceBufferNew Nothing
    sourceBufferSetMaxUndoLevels buffer (-1)
    tagTable <- textBufferGetTagTable buffer
    foundTag <- textTagNew (Just "found")
    set foundTag [textTagBackground := "yellow"]
    textTagTableAdd tagTable foundTag

    -- load up and display a file
    (fileContents,modTime) <- case mbfn of
        Just fn -> do
            fc <- UTF8.readFile fn
            mt <- getModificationTime fn
            return (fc,Just mt)
        Nothing -> return ("\n",Nothing)
    sourceBufferBeginNotUndoableAction buffer
    textBufferSetText buffer fileContents
    when bs $ transformToCandy ct (castToTextBuffer buffer)
    sourceBufferEndNotUndoableAction buffer
    textBufferSetModified buffer False
    siter <- textBufferGetStartIter buffer
    textBufferPlaceCursor buffer siter
    iter <- textBufferGetEndIter buffer
    textBufferCreateMark buffer (Just "end") iter True

    -- create a new SourceView Widget
    sv <- sourceViewNewWithBuffer buffer
    fd <- case textviewFont prefs of
        Just str -> do
            fontDescriptionFromString str
        Nothing -> do
            f <- fontDescriptionNew
            fontDescriptionSetFamily f "Monospace"
            return f
    widgetModifyFont sv (Just fd)
    set sv [sourceViewHighlightCurrentLine := True]
    sourceViewSetShowLineNumbers sv (showLineNumbers prefs)
    case rightMargin prefs of
        Just n -> do
            set sv [sourceViewShowRightMargin := True]
            sourceViewSetRightMarginPosition sv (fromIntegral n)
        Nothing -> set sv [sourceViewShowRightMargin := False]
    sourceViewSetInsertSpacesInsteadOfTabs sv True
    sourceViewSetIndentWidth sv (tabWidth prefs)
    sourceViewSetTabWidth sv (tabWidth prefs)
    sourceViewSetIndentOnTab sv True
    sourceViewSetAutoIndent sv True
    sourceViewSetSmartHomeEnd sv SourceSmartHomeEndBefore
    case sourceStyle prefs of
        Nothing  -> return ()
        Just str -> do
            styleManager <- sourceStyleSchemeManagerNew
            ids <- sourceStyleSchemeManagerGetSchemeIds styleManager
            when (elem str ids) $ do
                scheme <- sourceStyleSchemeManagerGetScheme styleManager str
                sourceBufferSetStyleScheme buffer scheme

    -- put it in a scrolled window
    sw <- scrolledWindowNew Nothing Nothing
    containerAdd sw sv
    scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
    scrolledWindowSetShadowType sw ShadowIn
    modTimeRef <- newIORef modTime
    let buf = IDEBuffer mbfn bn ind sv sw modTimeRef mbLanguage
    -- events
    cid <- sv `afterFocusIn`
        (\_ -> do reflectIDE (makeActive buf) ideR  ; return False)
    buffer `afterBufferInsertText`
        (\iter text -> do
            case text of
                [c] | ((isAlphaNum c) || (c == '.') || (c == '_')) -> do
                    reflectIDE (Completion.complete sv False) ideR
                _ -> return ()
        )
    sv `onMoveCursor`
        (\step n select -> do reflectIDE Completion.cancel ideR)
    sv `onButtonPress`
        \event -> do
            let click = eventClick event
            liftIO $ do
                reflectIDE Completion.cancel ideR
                case click of
                    DoubleClick -> do
                        let isSelectChar a = (isAlphaNum a) || (a == '_')
                        (start, end) <- textBufferGetSelectionBounds buffer
                        mbStartChar <- textIterGetChar start
                        mbEndChar <- textIterGetChar end
                        case mbStartChar of
                            Just startChar | isSelectChar startChar -> do
                                found <- textIterBackwardFindChar start (not.isSelectChar) Nothing
                                when found $ do
                                    textIterForwardChar start
                                    return ()
                            _ -> return ()
                        case mbEndChar of
                            Just endChar | isSelectChar endChar -> do
                                textIterForwardFindChar end (not.isSelectChar) Nothing
                                return ()
                            _ -> return ()
                        textBufferSelectRange buffer start end
                        return True
                    _ -> return False
    (GetTextPopup mbTpm) <- reflectIDE (triggerEvent ideR (GetTextPopup Nothing)) ideR
    case mbTpm of
        Just tpm    -> sv `onPopulatePopup` (tpm ideR) >> return ()
        Nothing     -> sysMessage Normal "SourceBuffer>> no text popup" >> return ()
    return (buf,[ConnectC cid])


checkModTime :: IDEBuffer -> IDEM Bool
checkModTime buf = do
    currentState' <- readIDE currentState
    case  currentState' of
        IsShuttingDown -> return False
        _              -> reifyIDE (\ideR -> do
            let name = paneName buf
            case fileName buf of
                Just fn -> do
                    exists <- doesFileExist fn
                    if exists
                        then do
                            nmt <- getModificationTime fn
                            modTime' <- readIORef (modTime buf)
                            case modTime' of
                                Nothing ->  error $"checkModTime: time not set " ++ show (fileName buf)
                                Just mt ->
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
                                    if False
#else
                                    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
#endif
                                    then do
                                                    md <- messageDialogNew
                                                            Nothing []
                                                            MessageQuestion
                                                            ButtonsYesNo
                                                            ("File \"" ++ name ++ "\" has changed on disk. Load file from disk?")
                                                    resp <- dialogRun md
                                                    case resp of
                                                        ResponseYes ->  do
                                                            reflectIDE (revert buf) ideR
                                                            liftIO $ widgetHide md
                                                            return False
                                                        ResponseNo  -> do
                                                            writeIORef (modTime buf) (Just nmt)
                                                            widgetHide md
                                                            return True
                                                        _           ->  do return False
                                                else return False
                        else return False
                Nothing -> return False)

setModTime :: IDEBuffer -> IDEAction
setModTime buf = do
    let name = paneName buf
    case fileName buf of
        Nothing -> return ()
        Just fn -> liftIO $ do
            nmt <- getModificationTime fn
            writeIORef (modTime buf) (Just nmt)

fileRevert :: IDEAction
fileRevert = inActiveBufContext' () $ \ _ _ currentBuffer _ -> do
    revert currentBuffer

revert :: IDEBuffer -> IDEAction
revert buf = do
    useCandy    <-  getCandyState
    ct          <-  readIDE candy
    let name    =   paneName buf
    case fileName buf of
        Nothing -> return ()
        Just fn -> liftIO $do
            buffer' <- textViewGetBuffer (sourceView buf)
            let buffer = castToSourceBuffer buffer'
            fc <- UTF8.readFile fn
            mt <- getModificationTime fn
            sourceBufferBeginNotUndoableAction buffer
            textBufferSetText buffer fc
            if useCandy
                then transformToCandy ct (castToTextBuffer buffer)
                else return ()
            sourceBufferEndNotUndoableAction buffer
            textBufferSetModified buffer False
            return mt
            writeIORef (modTime buf) (Just mt)

writeCursorPositionInStatusbar :: SourceView -> Statusbar -> IO()
writeCursorPositionInStatusbar sv sb = do
    buf  <- textViewGetBuffer sv
    mark <- textBufferGetInsert buf
    iter <- textBufferGetIterAtMark buf mark
    line <- textIterGetLine iter
    col  <- textIterGetLineOffset iter
    statusbarPop sb 1
    statusbarPush sb 1 $printf "Ln %4d, Col %3d" (line + 1) (col + 1)
    return ()

writeOverwriteInStatusbar :: SourceView -> Statusbar -> IO()
writeOverwriteInStatusbar sv sb = do
    modi <- textViewGetOverwrite sv
    statusbarPop sb 1
    statusbarPush sb 1 $ if modi then "OVR" else "INS"
    return ()


showInfo :: SourceView -> IDERef -> IO ()
showInfo sv ideR = do
    buf     <-  textViewGetBuffer sv
    (l,r)   <- textBufferGetSelectionBounds buf
    symbol  <- textBufferGetText buf l r True
    reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR
    return ()

markActiveLabelAsChanged :: IDEAction
markActiveLabelAsChanged = do
    mbPath <- getActivePanePath
    case mbPath of
        Nothing -> return ()
        Just path -> do
          nb <- getNotebook path
          mbBS <- maybeActiveBuf
          case mbBS of
              Nothing -> return ()
              Just buf -> liftIO $ markLabelAsChanged nb buf

markLabelAsChanged :: Notebook -> IDEBuffer -> IO ()
markLabelAsChanged nb buf = do
    gtkbuf   <- textViewGetBuffer (sourceView buf)
    modified <- textBufferGetModified gtkbuf
    markLabel nb (getTopWidget buf) modified

inBufContext' :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha
inBufContext' def ideBuf f = do
    (pane,_)       <-  guiPropertiesFromName (paneName ideBuf)
    nb             <-  getNotebook pane
    mbI            <-  liftIO $notebookPageNum nb (scrolledWindow ideBuf)
    case mbI of
        Nothing ->  liftIO $ do
            sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected"
            return def
        Just i  ->  do
            gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf)
            f nb gtkbuf ideBuf i

inBufContext :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha) -> IDEM alpha
inBufContext def ideBuff f = inBufContext' def ideBuff (\ a b c d -> liftIO $ f a b c d)

inActiveBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha
inActiveBufContext' def f = do
    mbBuf                  <- maybeActiveBuf
    case mbBuf of
        Nothing         -> return def
        Just ideBuf -> do
            inBufContext' def ideBuf f

inActiveBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha) -> IDEM alpha
inActiveBufContext def f = inActiveBufContext' def (\ a b c d -> liftIO $ f a b c d)

fileSaveBuffer :: Bool -> Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool
fileSaveBuffer query nb gtkbuf ideBuf i = do
    ideR    <- ask
    window  <- getMainWindow
    prefs   <- readIDE prefs
    bs      <- getCandyState
    candy   <- readIDE candy
    (panePath,connects) <- guiPropertiesFromName (paneName ideBuf)
    let mbfn = fileName ideBuf
    mbpage <- liftIO $ notebookGetNthPage nb i
    case mbpage of
        Nothing     -> throwIDE "fileSave: Page not found"
        Just page   ->
            if isJust mbfn && query == False
                then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload
                        modifiedInBuffer <- liftIO $ textBufferGetModified gtkbuf
                        if (modifiedOnDisk || modifiedInBuffer)
                            then do
                                liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy $fromJust mbfn
                                setModTime ideBuf
                                return True
                            else return False
                else reifyIDE $ \ideR   ->  do
                    dialog <- fileChooserDialogNew
                                    (Just $ "Save File")
                                    (Just window)
                                FileChooserActionSave
                                [("gtk-cancel"     --buttons to display
                                ,ResponseCancel)  --you can use stock buttons
                                ,("gtk-save"
                                , ResponseAccept)]
                    widgetShow dialog
                    response <- dialogRun dialog
                    mbFileName <- case response of
                            ResponseAccept ->       fileChooserGetFilename dialog
                            ResponseCancel ->       return Nothing
                            ResponseDeleteEvent->   return Nothing
                            _               ->      return Nothing
                    widgetDestroy dialog
                    case mbFileName of
                        Nothing -> return False
                        Just fn -> do
                            dfe <- doesFileExist fn
                            resp <- if dfe
                                then do md <- messageDialogNew (Just window) []
                                                MessageQuestion
                                                ButtonsYesNo
                                                "File already exist. Overwrite?"
                                        resp <- dialogRun md
                                        widgetHide md
                                        return resp
                                else return ResponseYes
                            case resp of
                                ResponseYes -> do
                                    cfn <- canonicalizePath fn
                                    fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy cfn

                                    reflectIDE (do
                                        close ideBuf
                                        newTextBuffer panePath (takeFileName fn) (Just cfn)
                                        )   ideR
                                    return True
                                ResponseNo -> return False
                                _          -> return False
    where
        fileSave' :: Bool -> Bool -> Notebook -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO()
        fileSave' forceLineEnds removeTBlanks nb ideBuf bs ct fn = do
            buf     <-   textViewGetBuffer $ sourceView ideBuf
            text    <-   getCandylessText ct buf
            let text' = if removeTBlanks
                            then unlines $ map removeTrailingBlanks $lines text
                            else text
            succ <- catch (do UTF8.writeFile fn text'; return True)
                (\e -> do
                    sysMessage Normal (show e)
                    return False)
            textBufferSetModified buf (not succ)
            markLabelAsChanged nb ideBuf
        removeTrailingBlanks :: String -> String
        removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse

fileSave :: Bool -> IDEM Bool
fileSave query = inActiveBufContext' False $ fileSaveBuffer query

fileSaveAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool
fileSaveAll filterFunc = do
    bufs     <- allBuffers
    filtered <- filterM filterFunc bufs
    results  <- forM filtered (\buf -> inBufContext' False buf (fileSaveBuffer False))
    return $ True `elem` results

fileCheckBuffer :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool
fileCheckBuffer nb gtkbuf ideBuf i = do
    ideR    <- ask
    window  <- getMainWindow
    prefs   <- readIDE prefs
    bs      <- getCandyState
    candy   <- readIDE candy
    (panePath,connects) <- guiPropertiesFromName (paneName ideBuf)
    let mbfn = fileName ideBuf
    mbpage <- liftIO $ notebookGetNthPage nb i
    case mbpage of
        Nothing     -> throwIDE "fileCheck: Page not found"
        Just page   ->
            if isJust mbfn
                then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload
                        modifiedInBuffer <- liftIO $ textBufferGetModified gtkbuf
                        return (modifiedOnDisk || modifiedInBuffer)
                else return False

fileCheckAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool
fileCheckAll filterFunc = do
    bufs    <- allBuffers
    filtered <- filterM filterFunc bufs
    results <- forM filtered (\buf -> inBufContext' False buf fileCheckBuffer)
    return $ True `elem` results

fileNew :: IDEAction
fileNew = do
    prefs   <- readIDE prefs
    pp      <- getBestPathForId  "*Buffer"
    newTextBuffer pp "Unnamed" Nothing
    return ()

fileClose :: IDEM Bool
fileClose = inActiveBufContext' True $ fileClose'

fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int  -> IDEM Bool
fileClose' nb gtkbuf currentBuffer i = do
    window  <- getMainWindow
    cancel <- reifyIDE $ \ideR   ->  do
        modified <- textBufferGetModified gtkbuf
        if modified
            then do
                md <- messageDialogNew (Just window) []
                                            MessageQuestion
                                            ButtonsNone
                                            ("Save changes to document: "
                                                ++ paneName currentBuffer
                                                ++ "?")
                dialogAddButton md "_Save" ResponseYes
                dialogAddButton md "_Don't Save" ResponseNo
                dialogAddButton md "_Cancel" ResponseCancel
                resp <- dialogRun md
                widgetDestroy md
                case resp of
                    ResponseYes ->   do
                        reflectIDE (fileSave False) ideR
                        return False
                    ResponseCancel  ->   return True
                    ResponseNo      ->   return False
                    _               ->   return False
            else return False
    if cancel
        then return False
        else do
            closePane currentBuffer
            when (isJust $ fileName currentBuffer)
                (addRecentlyUsedFile (fromJust $ fileName currentBuffer))
            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
    mbActivePack    <-  readIDE activePack
    bufs            <-  allBuffers
    when (not (null bufs) && isJust mbActivePack) $ do
        mapM_ (close' (fromJust mbActivePack)) bufs
    where
        close' activePack buf = do
            (pane,_)    <-  guiPropertiesFromName (paneName buf)
            nb          <-  getNotebook pane
            mbI         <-  liftIO $notebookPageNum nb (scrolledWindow buf)
            case mbI of
                Nothing ->  throwIDE "notebook page not found: unexpected"
                Just i  ->  do
                    gtkbuf <- liftIO $ textViewGetBuffer (sourceView buf)
                    let dir = dropFileName $ cabalFile activePack
                    when (isJust (fileName buf)) $ do
                        modified <- liftIO $ textBufferGetModified gtkbuf
                        when (not modified && not (isSubPath dir (fromJust (fileName buf))))
                            $ do fileClose' nb gtkbuf buf i; return ()

fileOpen :: IDEAction
fileOpen = do
    window <- getMainWindow
    prefs <- readIDE prefs
    mbFileName <- liftIO $ do
        dialog <- fileChooserDialogNew
                        (Just $ "Open File")
                        (Just window)
                    FileChooserActionOpen
                    [("gtk-cancel"
                    ,ResponseCancel)
                    ,("gtk-open"
                    ,ResponseAccept)]
        widgetShow dialog
        response <- dialogRun dialog
        case response of
            ResponseAccept -> do
                f <- fileChooserGetFilename dialog
                widgetDestroy dialog
                return f
            ResponseCancel -> do
                widgetDestroy dialog
                return Nothing
            ResponseDeleteEvent-> do
                widgetDestroy dialog
                return Nothing
            _ -> return Nothing
    case mbFileName of
        Nothing -> return ()
        Just fp -> fileOpenThis fp


fileOpenThis :: FilePath -> IDEAction
fileOpenThis fp =  do
    prefs <- readIDE prefs
    fpc <-  liftIO $canonicalizePath 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
            md <- liftIO $messageDialogNew
                    Nothing []
                    MessageQuestion
                    ButtonsYesNo
                    ("Buffer already open. " ++
                     "Make active instead of opening a second time?")
            resp <- liftIO $dialogRun md
            liftIO $ widgetDestroy md
            case resp of
                ResponseNo  ->  reallyOpen prefs fpc
                _           ->  makeActive hdb
        [] -> reallyOpen prefs fpc
    where
        reallyOpen prefs fpc =   do
            pp <-  getBestPathForId "*Buffer"
            newTextBuffer pp (takeFileName fpc) (Just fpc)
            return ()

editUndo :: IDEAction
editUndo = inActiveBufContext () $ \_ gtkbuf _ _ ->
    let sb = castToSourceBuffer gtkbuf in
    do  canUndo <- sourceBufferGetCanUndo sb
        if canUndo
            then sourceBufferUndo sb
            else return ()

editRedo :: IDEAction
editRedo = inActiveBufContext () $ \_ gtkbuf _ _ ->
    let sb = castToSourceBuffer gtkbuf in
    do  canRedo <- sourceBufferGetCanRedo sb
        if canRedo
            then sourceBufferRedo sb
            else return ()

editDelete :: IDEAction
editDelete = inActiveBufContext ()  $ \_ gtkbuf _ _ ->  do
    textBufferDeleteSelection gtkbuf True True
    return ()

editSelectAll :: IDEAction
editSelectAll = inActiveBufContext () $ \_ gtkbuf _ _ -> do
    start <- textBufferGetStartIter gtkbuf
    end   <- textBufferGetEndIter gtkbuf
    textBufferSelectRange gtkbuf start end

editCut :: IDEAction
editCut = inActiveBufContext () $ \_ gtkbuf _ _ -> do
    cb   <- atomNew "GDK_SELECTION_CLIPBOARD"
    clip <- clipboardGet cb
    textBufferCutClipboard gtkbuf clip True

editCopy :: IDEAction
editCopy = inActiveBufContext () $ \_ gtkbuf _ _ -> do
    cb   <- atomNew "GDK_SELECTION_CLIPBOARD"
    clip <- clipboardGet cb
    textBufferCopyClipboard gtkbuf clip

editPaste :: IDEAction
editPaste = inActiveBufContext () $ \_ gtkbuf _ _ -> do
    cb   <- atomNew "GDK_SELECTION_CLIPBOARD"
    mark <- textBufferGetInsert gtkbuf
    iter <- textBufferGetIterAtMark gtkbuf mark
    clip <- clipboardGet cb
    textBufferPasteClipboard gtkbuf clip iter True

getStartAndEndLineOfSelection :: TextBuffer -> IO (Int,Int)
getStartAndEndLineOfSelection gtkbuf = do
    startMark   <- textBufferGetInsert gtkbuf
    endMark     <- textBufferGetSelectionBound gtkbuf
    startIter   <- textBufferGetIterAtMark gtkbuf startMark
    endIter     <- textBufferGetIterAtMark gtkbuf endMark
    startLine   <- textIterGetLine startIter
    endLine     <- textIterGetLine endIter
    let (startLine',endLine',endIter') = if endLine >=  startLine
            then (startLine,endLine,endIter)
            else (endLine,startLine,startIter)
    b           <- textIterStartsLine endIter'
    let endLineReal = if b then endLine' - 1 else endLine'
    return (startLine',endLineReal)

doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a]
doForSelectedLines d f = inActiveBufContext' d $ \_ gtkbuf currentBuffer _ -> liftIO $do
    (start,end) <- getStartAndEndLineOfSelection gtkbuf
    iter        <- textBufferGetStartIter gtkbuf
    mapM (f gtkbuf iter) [start .. end]

editComment :: IDEAction
editComment = do
    doForSelectedLines [] $ \gtkbuf iter lineNr -> do
        textIterSetLine iter lineNr
        textBufferInsert gtkbuf iter "--"
    return ()

editUncomment :: IDEAction
editUncomment = do
    doForSelectedLines [] $ \gtkbuf iter lineNr -> do
        textIterSetLine iter lineNr
        iter2 <- textIterCopy iter
        textIterForwardChars iter 2
        str   <- textIterGetText iter iter2
        if str == "--"
            then do textBufferDelete gtkbuf iter iter2
            else return ()
    return ()

editShiftLeft :: IDEAction
editShiftLeft = do
    prefs <- readIDE prefs
    let str = map (\_->' ') [1 .. (tabWidth prefs)]
    b <- canShiftLeft str prefs
    if b
        then do
            doForSelectedLines [] $ \gtkbuf iter lineNr -> do
                textIterSetLine iter lineNr
                iter2 <- textIterCopy iter
                textIterForwardChars iter (tabWidth prefs)
                textBufferDelete gtkbuf iter iter2
            return ()
        else return ()
    where
    canShiftLeft str prefs = do
        boolList <- doForSelectedLines [] $ \gtkbuf iter lineNr -> do
            textIterSetLine iter lineNr
            iter2 <- textIterCopy iter
            textIterForwardChars iter (tabWidth prefs)
            str1 <- textIterGetText iter iter2
            return (str1 == str)
        return (foldl' (&&) True boolList)


editShiftRight :: IDEAction
editShiftRight = do
    prefs <- readIDE prefs
    let str = map (\_->' ') [1 .. (tabWidth prefs)]
    doForSelectedLines [] $ \gtkbuf iter lineNr -> do
        textIterSetLine iter lineNr
        textBufferInsert gtkbuf iter str
    return ()

editToCandy :: IDEAction
editToCandy = do
    ct <- readIDE candy
    inActiveBufContext () $ \_ gtkbuf _ _ -> do
        transformToCandy ct gtkbuf

editFromCandy :: IDEAction
editFromCandy = do
    ct      <-  readIDE candy
    inActiveBufContext () $ \_ gtkbuf _ _ -> do
        transformFromCandy ct gtkbuf

editKeystrokeCandy :: Maybe Char -> IDEAction
editKeystrokeCandy c = do
    ct <- readIDE candy
    inActiveBufContext () $ \_ gtkbuf _ _ -> do
        keystrokeCandy ct c gtkbuf

editCandy :: IDEAction
editCandy = do
    ct      <- readIDE candy
    buffers <- allBuffers
    gtkbufs <- liftIO $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers
    bs <- getCandyState
    if bs
        then liftIO $mapM_ (transformToCandy ct) gtkbufs
        else liftIO $mapM_ (transformFromCandy ct) gtkbufs

alignChar :: Char -> IDEAction
alignChar char = do
    positions     <- positionsOfChar
    let alignTo = foldl' max 0 (catMaybes (map snd positions))
    if (alignTo > 0)
        then alignChar (Map.fromList positions) alignTo
        else return ()
    where
    positionsOfChar :: IDEM ([(Int, Maybe Int)])
    positionsOfChar = doForSelectedLines [] $ \gtkbuf iter lineNr -> do
            textIterSetLine iter lineNr
            iter2 <- textIterCopy iter
            textIterForwardToLineEnd iter2
            line  <- textIterGetText iter iter2
            return (lineNr, elemIndex char line)
    alignChar :: Map Int (Maybe Int) -> Int -> IDEM ()
    alignChar positions alignTo = do
            doForSelectedLines [] $ \gtkbuf iter lineNr -> do
                case lineNr `Map.lookup` positions of
                    Just (Just n)  ->  do
                        textIterSetLine iter lineNr
                        textIterForwardChars iter n
                        textBufferInsert gtkbuf iter (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

sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage)
sourceLanguageForFilename lm Nothing         = do
    mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")
    case mbLang of
        Nothing -> return (Nothing,Nothing)
        Just lang -> do
            name <- sourceLanguageGetName lang
            return (Just name, Just lang)

sourceLanguageForFilename lm (Just filename) = do
    mbLang <- sourceLanguageManagerGuessLanguage lm (Just filename) Nothing
    case mbLang of
        Nothing -> return (Nothing,Nothing)
        Just lang -> do
            name <- sourceLanguageGetName lang
            return (Just name, Just lang)

addRecentlyUsedFile :: FilePath -> IDEAction
addRecentlyUsedFile fp = do
    state <- readIDE currentState
    when (not $ isStartingOrClosing state) $ do
        recentFiles' <- readIDE recentFiles
        unless (elem fp recentFiles') $
            modifyIDE_ (\ide -> ide{recentFiles = take 12 (fp : recentFiles')})
        triggerEventIDE UpdateRecent
        return ()

removeRecentlyUsedFile :: FilePath -> IDEAction
removeRecentlyUsedFile fp = do
    state <- readIDE currentState
    when (not $ isStartingOrClosing state) $ do
        recentFiles' <- readIDE recentFiles
        when (elem fp recentFiles') $
            modifyIDE_ (\ide -> ide{recentFiles = filter (\e -> e /= fp) recentFiles'})
        triggerEventIDE UpdateRecent
        return ()

selectedText :: IDEM (Maybe String)
selectedText = do
    candy' <- readIDE candy
    inActiveBufContext Nothing $ \_ gtkbuf currentBuffer _ -> do
        hasSelection <- liftIO $ textBufferHasSelection gtkbuf
        if hasSelection
            then do
                (i1,i2)   <- liftIO $ textBufferGetSelectionBounds gtkbuf
                text      <- getCandylessPart candy' gtkbuf i1 i2
                return $ Just text
            else return Nothing

selectedLocation :: IDEM (Maybe (Int, Int))
selectedLocation = do
    useCandy    <- getCandyState
    candy'      <- readIDE candy
    inActiveBufContext Nothing $ \_ gtkbuf currentBuffer _ -> do
        (start, _) <- liftIO $ textBufferGetSelectionBounds gtkbuf
        line       <- textIterGetLine start
        lineOffset <- textIterGetLineOffset start
        res <- if useCandy
            then positionFromCandy candy' gtkbuf (line, lineOffset)
            else return (line, lineOffset)
        return $ Just res

-- " ++ ++ ++ alpha

insertTextAfterSelection :: String -> IDEAction
insertTextAfterSelection str = do
        candy'       <- readIDE candy
        useCandy     <- getCandyState
        inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do
        hasSelection <- liftIO $ textBufferHasSelection gtkbuf
        when hasSelection $ liftIO $ do
            realString <-  if useCandy then stringToCandy candy' str else return str
            (_,i)      <- textBufferGetSelectionBounds gtkbuf
            mark       <- textBufferCreateMark gtkbuf Nothing i True
            textBufferInsert gtkbuf i realString
            i1         <- textBufferGetIterAtMark gtkbuf mark
            i2         <- textIterCopy i1
            textIterForwardChars i2 (length str)
            textBufferSelectRange gtkbuf i1 i2

selectedModuleName :: IDEM (Maybe String)
selectedModuleName = do
    candy' <- readIDE candy
    inActiveBufContext' Nothing $ \_ gtkbuf currentBuffer _ -> do
        case fileName currentBuffer of
            Just filePath -> do
                text <- liftIO $ getCandylessText candy' gtkbuf
                parseResult <- parseHeader filePath text
                case parseResult of
                     Just HsModule{ hsmodName = Just name }
                        -> return $ Just $ moduleNameString (unLoc name)
                     _  -> return Nothing
            Nothing -> return Nothing