diff --git a/Readme.md b/Readme.md
--- a/Readme.md
+++ b/Readme.md
@@ -3,7 +3,7 @@
[](http://travis-ci.org/leksah/leksah)
[Leksah](http://leksah.org/) aims to integrate various Haskell development
-tools to provide a practical and plesant development environment.
+tools to provide a practical and pleasant development environment.
The user interface is a mix of GTK+ and WebKit based components.
Documentation can be found on [leksah.org](http://leksah.org/).
diff --git a/data/leksah-welcome/src/Main.hs b/data/leksah-welcome/src/Main.hs
--- a/data/leksah-welcome/src/Main.hs
+++ b/data/leksah-welcome/src/Main.hs
@@ -18,8 +18,14 @@
-- Next we are importing some things from other modules.
-- Leksah can normally addd these imports for you, just
-- press Ctrl+R (OS X Command+R)
-import Data.List (stripPrefix)
+import Data.Monoid ((<>))
+
+-- This strang looking comment adds code only needed when running the
+-- doctest tests embedded in the comments
+-- $setup
+-- >>> import Data.List (stripPrefix)
+
-- | Simple function to create a hello message.
--
-- The following tells doctest & QuickCheck that if you strip "Hello "
@@ -35,7 +41,8 @@
-- The code that runs the tests is in the file test/Main.hs.
--
-- prop> stripPrefix "Hello " (hello s) == Just s
-hello s = "Hello " ++ s
+hello :: String -> String
+hello s = "Hello " <> s
-- | Executable Entry Point
--
@@ -45,6 +52,6 @@
-- * Select Leksah menu item Package -> Run (or the cogs on the toolbar)
-- * Select "exeMain" and press Ctrl+Enter to run them in ghci
-- * Run "leksah-wellcome" from the command line
-main = do
- putStrLn (hello "World")
+main :: IO ()
+main = putStrLn (hello "World")
diff --git a/data/leksah-welcome/test/Main.hs b/data/leksah-welcome/test/Main.hs
--- a/data/leksah-welcome/test/Main.hs
+++ b/data/leksah-welcome/test/Main.hs
@@ -7,4 +7,5 @@
-- To run these tests
-- * Select Leksah menu item Package -> Test
-- * Select the tick icon on the Leksah toolbar (to enable "cabal test" during builds)
+main :: IO ()
main = doctest ["-isrc", "src/Main.hs"]
diff --git a/data/styles/leksah-dark.xml b/data/styles/leksah-dark.xml
--- a/data/styles/leksah-dark.xml
+++ b/data/styles/leksah-dark.xml
@@ -41,6 +41,9 @@
+
+
+
diff --git a/data/styles/leksah.xml b/data/styles/leksah.xml
--- a/data/styles/leksah.xml
+++ b/data/styles/leksah.xml
@@ -43,8 +43,8 @@
-
-
+
+
diff --git a/leksah.cabal b/leksah.cabal
--- a/leksah.cabal
+++ b/leksah.cabal
@@ -1,5 +1,5 @@
name: leksah
-version: 0.15.0.5
+version: 0.15.0.6
cabal-version: >=1.18
build-type: Simple
license: GPL
@@ -246,13 +246,14 @@
parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2,
regex-tdfa >=1.1 && <1.3, regex-tdfa-text, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <1.1, array >=0.2.0.0 && <0.6,
time >=0.1 && <1.6, ltk >= 0.15.0.1 && <0.16, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.5,
- hslogger >= 1.0.7 && <1.3, leksah-server >=0.15.0.3 && <0.16,
+ hslogger >= 1.0.7 && <1.3, leksah-server >=0.15.0.4 && <0.16,
ghc >=6.10.1 && <7.11, strict >= 0.3.2 && <0.4, conduit >= 1.0.8 && <1.3, text >= 0.11.1.5 && < 1.3,
gio >=0.13.0.0 && <0.14, transformers >=0.2.2.0 && <0.5,
executable-path >=0.0.3 && <0.1,
vcsgui >=0.1.0 && < 0.2, vcswrapper >=0.1.0 && < 0.2,
QuickCheck >=2.4.2 && <2.9, haskell-src-exts >=1.13.5 && <1.17,
- hlint >=1.8.59 && <1.10, vado >=0.0.1 && <0.1, shakespeare >=2.0.0.1 && <2.1
+ hlint >=1.9.21 && <1.10, vado >=0.0.1 && <0.1, shakespeare >=2.0.0.1 && <2.1,
+ cpphs >=1.19 && <1.20
exposed-modules: IDE.Leksah IDE.Completion IDE.ImportTool IDE.Find
IDE.Sandbox IDE.Session IDE.Command IDE.Keymap IDE.Utils.GUIUtils
IDE.SymbolNavigation IDE.Package IDE.YiConfig IDE.OSX
@@ -296,7 +297,7 @@
ghc-options: -threaded
hs-source-dirs: main
- build-depends: leksah == 0.15.0.5,
+ build-depends: leksah == 0.15.0.6,
base >= 4.0.0.0 && <=4.9,
gtk3 >=0.13.2 && <0.14
if os(linux) && flag(loc)
@@ -312,7 +313,7 @@
ghc-options: -rtsopts -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans
executable bewleksah
- build-depends: leksah ==0.15.0.5,
+ build-depends: leksah ==0.15.0.6,
base >=4.0.0.0 && <=4.9,
jsaddle -any,
ghcjs-dom -any,
@@ -331,7 +332,7 @@
build-depends: base >=4.0.0.0 && <4.9,
Cabal >=1.10.2.0 && <1.23,
QuickCheck >=2.4.2 && <2.9,
- leksah ==0.15.0.5,
+ leksah ==0.15.0.6,
containers,
ltk,
leksah-server,
diff --git a/src/IDE/BufferMode.hs b/src/IDE/BufferMode.hs
--- a/src/IDE/BufferMode.hs
+++ b/src/IDE/BufferMode.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -39,14 +38,12 @@
transformToCandy)
import IDE.Utils.GUIUtils (getCandyState)
import Control.Monad (when)
-import Data.Maybe (catMaybes)
+import Data.Maybe (mapMaybe, catMaybes)
import IDE.Utils.FileUtils
import Graphics.UI.Gtk
(Notebook, castToWidget, notebookPageNum, ScrolledWindow)
import Control.Monad.IO.Class (MonadIO(..))
-#if MIN_VERSION_directory(1,2,0)
import Data.Time (UTCTime)
-#endif
import Data.Text (Text)
import Data.Monoid ((<>))
import qualified Data.Text as T
@@ -63,11 +60,7 @@
, addedIndex :: Int
, sourceView :: EditorView editor
, scrolledWindow :: ScrolledWindow
-#if MIN_VERSION_directory(1,2,0)
-, modTime :: IORef (Maybe (UTCTime))
-#else
-, modTime :: IORef (Maybe (ClockTime))
-#endif
+, modTime :: IORef (Maybe UTCTime)
, mode :: Mode
} deriving (Typeable)
@@ -104,7 +97,7 @@
recentSourceBuffers = do
recentPanes' <- readIDE recentPanes
mbBufs <- mapM mbPaneFromName recentPanes'
- return $ map paneName ((catMaybes $ map (\ (PaneC p) -> cast p) $ catMaybes mbBufs) :: [IDEBuffer])
+ return $ map paneName (mapMaybe (\ (PaneC p) -> cast p) (catMaybes mbBufs) :: [IDEBuffer])
getStartAndEndLineOfSelection :: TextEditor editor => EditorBuffer editor -> IDEM (Int,Int)
getStartAndEndLineOfSelection ebuf = do
@@ -139,7 +132,7 @@
mbBuf <- maybeActiveBuf
case mbBuf of
Nothing -> return def
- Just ideBuf -> do
+ Just ideBuf ->
inBufContext def ideBuf f
doForSelectedLines :: [a] -> (forall editor. TextEditor editor => EditorBuffer editor -> Int -> IDEM a) -> IDEM [a]
@@ -166,10 +159,10 @@
-- | Assumes
modFromFileName :: Maybe FilePath -> Mode
modFromFileName Nothing = haskellMode
-modFromFileName (Just fn) | isSuffixOf ".hs" fn = haskellMode
- | isSuffixOf ".lhs" fn = literalHaskellMode
- | isSuffixOf ".cabal" fn = cabalMode
- | otherwise = otherMode
+modFromFileName (Just fn) | ".hs" `isSuffixOf` fn = haskellMode
+ | ".lhs" `isSuffixOf` fn = literalHaskellMode
+ | ".cabal" `isSuffixOf` fn = cabalMode
+ | otherwise = otherMode
haskellMode = Mode {
modeName = "Haskell",
@@ -183,12 +176,10 @@
sol <- getIterAtLine ebuf lineNr
sol2 <- forwardCharsC sol 2
str <- getText ebuf sol sol2 True
- if str == "--"
- then do delete ebuf sol sol2
- else return ()
+ when (str == "--") $ delete ebuf sol sol2
return (),
- modeSelectedModuleName = do
- inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do
+ modeSelectedModuleName =
+ inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ ->
case fileName currentBuffer of
Just filePath -> liftIO $ moduleNameFromFilePath filePath
Nothing -> return Nothing,
@@ -197,20 +188,20 @@
transformToCandy ct ebuf inCommentOrString,
modeEditToCandy = \ inCommentOrString -> do
ct <- readIDE candy
- inActiveBufContext () $ \_ _ ebuf _ _ -> do
+ inActiveBufContext () $ \_ _ ebuf _ _ ->
transformToCandy ct ebuf inCommentOrString,
modeEditFromCandy = do
ct <- readIDE candy
- inActiveBufContext () $ \_ _ ebuf _ _ -> do
+ inActiveBufContext () $ \_ _ ebuf _ _ ->
transformFromCandy ct ebuf,
modeEditKeystrokeCandy = \c inCommentOrString -> do
ct <- readIDE candy
- inActiveBufContext () $ \_ _ ebuf _ _ -> do
+ inActiveBufContext () $ \_ _ ebuf _ _ ->
keystrokeCandy ct c ebuf inCommentOrString,
modeEditInsertCode = \ str iter buf ->
insert buf iter str,
modeEditInCommentOrString = \ line -> ("--" `T.isInfixOf` line)
- || not (even $ T.count "\"" line)
+ || odd (T.count "\"" line)
}
literalHaskellMode = Mode {
@@ -232,8 +223,8 @@
when (str /= ">")
(insert ebuf sol ">")
return (),
- modeSelectedModuleName = do
- inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do
+ modeSelectedModuleName =
+ inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ ->
case fileName currentBuffer of
Just filePath -> liftIO $ moduleNameFromFilePath filePath
Nothing -> return Nothing,
@@ -242,20 +233,20 @@
transformToCandy ct ebuf inCommentOrString,
modeEditToCandy = \ inCommentOrString -> do
ct <- readIDE candy
- inActiveBufContext () $ \_ _ ebuf _ _ -> do
+ inActiveBufContext () $ \_ _ ebuf _ _ ->
transformToCandy ct ebuf inCommentOrString,
modeEditFromCandy = do
ct <- readIDE candy
- inActiveBufContext () $ \_ _ ebuf _ _ -> do
+ inActiveBufContext () $ \_ _ ebuf _ _ ->
transformFromCandy ct ebuf,
modeEditKeystrokeCandy = \c inCommentOrString -> do
ct <- readIDE candy
- inActiveBufContext () $ \_ _ ebuf _ _ -> do
+ inActiveBufContext () $ \_ _ ebuf _ _ ->
keystrokeCandy ct c ebuf inCommentOrString,
modeEditInsertCode = \ str iter buf ->
insert buf iter (T.unlines $ map (\ s -> "> " <> s) $ T.lines str),
modeEditInCommentOrString = \ line -> not (T.isPrefixOf ">" line)
- || not (even $ T.count "\"" line)
+ || odd (T.count "\"" line)
}
cabalMode = Mode {
@@ -270,9 +261,7 @@
sol <- getIterAtLine ebuf lineNr
sol2 <- forwardCharsC sol 2
str <- getText ebuf sol sol2 True
- if str == "--"
- then do delete ebuf sol sol2
- else return ()
+ when (str == "--") $ delete ebuf sol sol2
return (),
modeSelectedModuleName = return Nothing,
modeTransformToCandy = \ _ _ -> return (),
@@ -280,7 +269,7 @@
modeEditFromCandy = return (),
modeEditKeystrokeCandy = \ _ _ -> return (),
modeEditInsertCode = \ str iter buf -> insert buf iter str,
- modeEditInCommentOrString = \ str -> T.isPrefixOf "--" str
+ modeEditInCommentOrString = T.isPrefixOf "--"
}
@@ -294,7 +283,7 @@
modeEditFromCandy = return (),
modeEditKeystrokeCandy = \_ _ -> return (),
modeEditInsertCode = \str iter buf -> insert buf iter str,
- modeEditInCommentOrString = \ _ -> False
+ modeEditInCommentOrString = const False
}
isHaskellMode mode = modeName mode == "Haskell" || modeName mode == "Literal Haskell"
diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs
--- a/src/IDE/Completion.hs
+++ b/src/IDE/Completion.hs
@@ -55,7 +55,7 @@
currentState' <- readIDE currentState
(_, completion') <- readIDE completion
case (currentState',completion') of
- (IsCompleting conn , Just (CompletionWindow window tv st)) -> do
+ (IsCompleting conn , Just (CompletionWindow window tv st)) ->
cancelCompletion window tv st conn
_ -> return ()
@@ -110,17 +110,17 @@
windowDefaultHeight := height,
windowTransientFor := head windows]
liftIO $ containerSetBorderWidth window 3
- paned <- liftIO $ hPanedNew
+ paned <- liftIO hPanedNew
liftIO $ containerAdd window paned
nameScrolledWindow <- liftIO $ scrolledWindowNew Nothing Nothing
liftIO $ widgetSetSizeRequest nameScrolledWindow 250 40
- tree <- liftIO $ treeViewNew
+ tree <- liftIO treeViewNew
liftIO $ containerAdd nameScrolledWindow tree
store <- liftIO $ listStoreNew []
liftIO $ treeViewSetModel tree store
font <- liftIO $ case textviewFont prefs of
- Just str -> do
+ Just str ->
fontDescriptionFromString str
Nothing -> do
f <- fontDescriptionNew
@@ -128,12 +128,12 @@
return f
liftIO $ widgetModifyFont tree (Just font)
- column <- liftIO $ treeViewColumnNew
+ column <- liftIO treeViewColumnNew
liftIO $ set column [
treeViewColumnSizing := TreeViewColumnFixed,
treeViewColumnMinWidth := 800] -- OSX does not like it if there is no hscroll
liftIO $ treeViewAppendColumn tree column
- renderer <- liftIO $ cellRendererTextNew
+ renderer <- liftIO cellRendererTextNew
liftIO $ treeViewColumnPackStart column renderer True
liftIO $ cellLayoutSetAttributes column renderer store (\name -> [ cellText := name ])
@@ -141,10 +141,7 @@
descriptionBuffer <- newDefaultBuffer Nothing ""
descriptionView <- newView descriptionBuffer (textviewFont prefs)
- preferDark <- getDarkState
- setStyle preferDark descriptionBuffer $ case sourceStyle prefs of
- (False,_) -> Nothing
- (True,v) -> Just v
+ updateStyle descriptionBuffer
descriptionScrolledWindow <- getScrolledWindow descriptionView
visible <- liftIO $ newIORef False
@@ -152,7 +149,7 @@
treeSelection <- liftIO $ treeViewGetSelection tree
- liftIO $ on treeSelection treeSelectionSelectionChanged $ do
+ liftIO $ on treeSelection treeSelectionSelectionChanged $
treeSelectionSelectedForeach treeSelection $ \treePath -> do
rows <- treeSelectionGetSelectedRows treeSelection
case rows of
@@ -185,67 +182,48 @@
count <- liftIO $ treeModelIterNChildren model Nothing
Just column <- liftIO $ treeViewGetColumn tree 0
case (name, modifier, char) of
- ("Tab", _, _) -> (do
- visible <- liftIO $ get tree widgetVisible
- if visible then (do
- liftIDE $ tryToUpdateOptions window tree store sourceView True isWordChar always
- return True
- )
- else return False
- )
- ("Return", _, _) -> (do
- visible <- liftIO $ get tree widgetVisible
- if visible then (do
- maybeRow <- liftIO $ getRow tree
- case maybeRow of
- Just row -> (do
- liftIO $ treeViewRowActivated tree [row] column
- return True
- )
- Nothing -> (do
- liftIDE cancel
+ ("Tab", _, _) -> do visible <- liftIO $ get tree widgetVisible
+ if visible then
+ (do liftIDE $
+ tryToUpdateOptions window tree store sourceView True isWordChar
+ always
+ return True)
+ else return False
+ ("Return", _, _) -> do visible <- liftIO $ get tree widgetVisible
+ if visible then
+ (do maybeRow <- liftIO $ getRow tree
+ case maybeRow of
+ Just row -> do liftIO $ treeViewRowActivated tree [row] column
+ return True
+ Nothing -> do liftIDE cancel
+ return False)
+ else return False
+ ("Down", _, _) -> do visible <- liftIO $ get tree widgetVisible
+ if visible then
+ (do maybeRow <- liftIO $ getRow tree
+ let newRow = maybe 0 (+ 1) maybeRow
+ when (newRow < count) $
+ liftIO $
+ do treeSelectionSelectPath selection [newRow]
+ treeViewScrollToCell tree (Just [newRow]) Nothing Nothing
+ return True)
+ else return False
+ ("Up", _, _) -> do visible <- liftIO $ get tree widgetVisible
+ if visible then
+ (do maybeRow <- liftIO $ getRow tree
+ let newRow = maybe 0 (\ row -> row - 1) maybeRow
+ when (newRow >= 0) $
+ liftIO $
+ do treeSelectionSelectPath selection [newRow]
+ treeViewScrollToCell tree (Just [newRow]) Nothing Nothing
+ return True)
+ else return False
+ (_, _, Just c) | isWordChar c -> return False
+ ("BackSpace", _, _) -> return False
+ (shift, _, _) | (shift == "Shift_L") || (shift == "Shift_R") ->
return False
- )
- )
- else return False
- )
- ("Down", _, _) -> (do
- visible <- liftIO $ get tree widgetVisible
- if visible then (do
- maybeRow <- liftIO $ getRow tree
- let newRow = maybe 0 (\row -> row + 1) maybeRow
- when (newRow < count) $ liftIO $ do
- treeSelectionSelectPath selection [newRow]
- treeViewScrollToCell tree (Just [newRow]) Nothing Nothing
- return True
- )
- else return False
- )
- ("Up", _, _) -> (do
- visible <- liftIO $ get tree widgetVisible
- if visible then (do
- maybeRow <- liftIO $ getRow tree
- let newRow = maybe 0 (\row -> row - 1) maybeRow
- when (newRow >= 0) $ liftIO $ do
- treeSelectionSelectPath selection [newRow]
- treeViewScrollToCell tree (Just [newRow]) Nothing Nothing
- return True
- )
- else return False
- )
- (_, _, Just c) | isWordChar c -> (do
- return False
- )
- ("BackSpace", _, _) -> (do
- return False
- )
- (shift, _, _) | (shift == "Shift_L") || (shift == "Shift_R") -> (do
- return False
- )
- _ -> (do
- liftIDE cancel
- return False
- )
+ _ -> do liftIDE cancel
+ return False
cidsRelease <- TE.onKeyRelease sourceView $ do
name <- lift eventKeyName
@@ -256,67 +234,66 @@
return False
_ -> return False
- resizeHandler <- liftIO $ newIORef Nothing
+ liftIO $ do
+ resizeHandler <- newIORef Nothing
- idButtonPress <- liftIO $ window `on` buttonPressEvent $ do
- button <- eventButton
- (x, y) <- eventCoordinates
- time <- eventTime
+ idButtonPress <- window `on` buttonPressEvent $ do
+ button <- eventButton
+ (x, y) <- eventCoordinates
+ time <- eventTime
#ifdef MIN_VERSION_gtk3
- mbDrawWindow <- Gtk.liftIO $ widgetGetWindow window
+ mbDrawWindow <- Gtk.liftIO $ widgetGetWindow window
#else
- mbDrawWindow <- Gtk.liftIO $ Just <$> widgetGetDrawWindow window
+ mbDrawWindow <- Gtk.liftIO $ Just <$> widgetGetDrawWindow window
#endif
- case mbDrawWindow of
- Just drawWindow -> do
- status <- Gtk.liftIO $ pointerGrab
- drawWindow
- False
- [PointerMotionMask, ButtonReleaseMask]
- (Nothing:: Maybe DrawWindow)
- Nothing
- time
- when (status == GrabSuccess) $ Gtk.liftIO $ do
- (width, height) <- windowGetSize window
- writeIORef resizeHandler $ Just $ \(newX, newY) -> do
- reflectIDE (
- setCompletionSize ((width + (floor (newX - x))), (height + (floor (newY - y))))) ideR
- Nothing -> return ()
+ case mbDrawWindow of
+ Just drawWindow -> do
+ status <- Gtk.liftIO $ pointerGrab
+ drawWindow
+ False
+ [PointerMotionMask, ButtonReleaseMask]
+ (Nothing:: Maybe DrawWindow)
+ Nothing
+ time
+ when (status == GrabSuccess) $ Gtk.liftIO $ do
+ (width, height) <- windowGetSize window
+ writeIORef resizeHandler $ Just $ \(newX, newY) ->
+ reflectIDE (
+ setCompletionSize (width + floor (newX - x), height + floor (newY - y))) ideR
+ Nothing -> return ()
- return True
+ return True
- idMotion <- liftIO $ window `on` motionNotifyEvent $ do
- mbResize <- Gtk.liftIO $ readIORef resizeHandler
- case mbResize of
- Just resize -> eventCoordinates >>= (Gtk.liftIO . resize) >> return True
- Nothing -> return False
+ idMotion <- window `on` motionNotifyEvent $ do
+ mbResize <- Gtk.liftIO $ readIORef resizeHandler
+ case mbResize of
+ Just resize -> eventCoordinates >>= (Gtk.liftIO . resize) >> return True
+ Nothing -> return False
- idButtonRelease <- liftIO $ window `on` buttonReleaseEvent $ do
- mbResize <- Gtk.liftIO $ readIORef resizeHandler
- case mbResize of
- Just resize -> do
- eventCoordinates >>= (Gtk.liftIO . resize)
- eventTime >>= (Gtk.liftIO . pointerUngrab)
- Gtk.liftIO $ writeIORef resizeHandler Nothing
- return True
- Nothing -> return False
+ idButtonRelease <- window `on` buttonReleaseEvent $ do
+ mbResize <- Gtk.liftIO $ readIORef resizeHandler
+ case mbResize of
+ Just resize -> do
+ eventCoordinates >>= (Gtk.liftIO . resize)
+ eventTime >>= (Gtk.liftIO . pointerUngrab)
+ Gtk.liftIO $ writeIORef resizeHandler Nothing
+ return True
+ Nothing -> return False
- idSelected <- liftIO $ on tree rowActivated $ \treePath column -> do
- reflectIDE (withWord store treePath (replaceWordStart sourceView isWordChar)) ideR
- liftIO $ postGUIAsync $ reflectIDE cancel ideR
+ idSelected <- on tree rowActivated $ \treePath column -> do
+ reflectIDE (withWord store treePath (replaceWordStart sourceView isWordChar)) ideR
+ liftIO $ postGUIAsync $ reflectIDE cancel ideR
- return $ concat [cidsPress, cidsRelease, [ConnectC idButtonPress, ConnectC idMotion, ConnectC idButtonRelease, ConnectC idSelected]]
+ return $ concat [cidsPress, cidsRelease, [ConnectC idButtonPress, ConnectC idMotion, ConnectC idButtonRelease, ConnectC idSelected]]
withWord :: ListStore Text -> TreePath -> (Text -> IDEM ()) -> IDEM ()
-withWord store treePath f = (do
+withWord store treePath f =
case treePath of
- [row] -> (do
+ [row] -> do
value <- liftIO $ listStoreGetValue store row
f value
- )
_ -> return ()
- )
replaceWordStart :: TextEditor editor => EditorView editor -> (Char -> Bool) -> Text -> IDEM ()
replaceWordStart sourceView isWordChar name = do
@@ -347,7 +324,7 @@
updateOptions :: forall editor. TextEditor editor => Window -> TreeView -> ListStore Text -> EditorView editor -> Connections -> (Char -> Bool) -> Bool -> IDEAction
updateOptions window tree store sourceView connections isWordChar always = do
result <- tryToUpdateOptions window tree store sourceView False isWordChar always
- when (not result) $ cancelCompletion window tree store connections
+ unless result $ cancelCompletion window tree store connections
tryToUpdateOptions :: TextEditor editor => Window -> TreeView -> ListStore Text -> EditorView editor -> Bool -> (Char -> Bool) -> Bool -> IDEM Bool
tryToUpdateOptions window tree store sourceView selectLCP isWordChar always = do
@@ -388,7 +365,7 @@
processResults :: TextEditor editor => Window -> TreeView -> ListStore Text -> EditorView editor -> Text -> [Text]
-> Bool -> (Char -> Bool) -> Bool -> IDEAction
-processResults window tree store sourceView wordStart options selectLCP isWordChar always = do
+processResults window tree store sourceView wordStart options selectLCP isWordChar always =
case options of
[] -> cancel
_ | not always && (not . null $ drop 200 options) -> cancel
@@ -397,12 +374,9 @@
(selStart, end) <- getSelectionBounds buffer
start <- findWordStart selStart isWordChar
currentWordStart <- getText buffer start end True
- newWordStart <- do
- if selectLCP && currentWordStart == wordStart && (not $ null options)
- then do
- return $ foldl1 longestCommonPrefix options
- else
- return currentWordStart
+ let newWordStart = if selectLCP && currentWordStart == wordStart && not (null options)
+ then foldl1 longestCommonPrefix options
+ else currentWordStart
when (T.isPrefixOf wordStart newWordStart) $ do
liftIO $ listStoreClear store
@@ -450,7 +424,7 @@
panedAdd1 (castToPaned paned) second
panedAdd2 (castToPaned paned) first
panedSetPosition (castToPaned paned) (wWindow-pos)
- when (not $ null newOptions) $ liftIO $ treeViewSetCursor tree [0] Nothing
+ unless (null newOptions) $ liftIO $ treeViewSetCursor tree [0] Nothing
liftIO $ widgetShowAll window
when (newWordStart /= currentWordStart) $
@@ -461,8 +435,6 @@
selection <- treeViewGetSelection tree
maybeIter <- treeSelectionGetSelected selection
case maybeIter of
- Just iter -> (do
- [row] <- treeModelGetPath model iter
- return $ Just row
- )
- Nothing -> return Nothing
+ Just iter -> do [row] <- treeModelGetPath model iter
+ return $ Just row
+ Nothing -> return Nothing
diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs
--- a/src/IDE/Core/State.hs
+++ b/src/IDE/Core/State.hs
@@ -255,7 +255,7 @@
window = head . windows
errorRefs :: IDE -> [LogRef]
-errorRefs = filter ((\ t -> t == ErrorRef || t == WarningRef) . logRefType) .
+errorRefs = filter ((\ t -> t == ErrorRef || t == WarningRef || t == LintRef || t == TestFailureRef) . logRefType) .
allLogRefs
breakpointRefs :: IDE -> [LogRef]
diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs
--- a/src/IDE/Core/Types.hs
+++ b/src/IDE/Core/Types.hs
@@ -57,9 +57,12 @@
, Prefs(..)
, cabalCommand
+, EditorStyle(..)
+, editorStyle
, LogRefType(..)
, LogRef(..)
+, logRefRootPath
, logRefFilePath
, logRefFullFilePath
, isError
@@ -121,9 +124,7 @@
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Trans.Reader (ReaderT(..))
-#if MIN_VERSION_directory(1,2,0)
import Data.Time (UTCTime(..))
-#endif
import qualified VCSWrapper.Common as VCS
import qualified VCSGui.Common as VCSGUI
@@ -133,6 +134,8 @@
import Control.Monad.Reader.Class (MonadReader(..))
import Data.Text (Text)
import qualified Data.Text as T (unpack)
+import Language.Haskell.HLint3 (Idea(..))
+import Data.Function (on)
-- ---------------------------------------------------------------------
-- IDE State
@@ -155,9 +158,9 @@
, allLogRefs :: [LogRef]
, currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef)
, currentHist :: Int
-, systemInfo :: (Maybe GenScope) -- ^ the system scope
-, packageInfo :: (Maybe (GenScope, GenScope)) -- ^ the second are the imports
-, workspaceInfo :: (Maybe (GenScope, GenScope)) -- ^ the second are the imports
+, systemInfo :: Maybe GenScope -- ^ the system scope
+, packageInfo :: Maybe (GenScope, GenScope) -- ^ the second are the imports
+, workspaceInfo :: Maybe (GenScope, GenScope) -- ^ the second are the imports
, workspInfoCache :: PackageDescrCache
, handlers :: Map Text [(Unique, IDEEvent -> IDEM IDEEvent)] -- ^ event handling table
, currentState :: IDEState
@@ -170,7 +173,7 @@
, debugState :: Maybe (IDEPackage, ToolState)
, completion :: ((Int, Int), Maybe CompletionWindow)
, yiControl :: Yi.Control
-, serverQueue :: Maybe (MVar (ServerCommand, (ServerAnswer -> IDEM ())))
+, serverQueue :: Maybe (MVar (ServerCommand, ServerAnswer -> IDEM ()))
, server :: Maybe Handle
, vcsData :: (Map FilePath MenuItem, Maybe (Maybe Text)) -- menus for packages, password
, logLaunches :: Map.Map Text LogLaunchData
@@ -217,7 +220,7 @@
instance MonadIDE WorkspaceM where
liftIDE = lift
-(?>>=) :: Monad m => (m (Maybe a)) -> (a -> m ()) -> m ()
+(?>>=) :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
a ?>>= b = do
mA <- a
case mA of
@@ -348,8 +351,8 @@
setHandlers ideRef nh = do
ide <- liftIO $ readIORef ideRef
liftIO $ writeIORef ideRef (ide {handlers= nh})
- myUnique _ = do
- liftIO $ newUnique
+ myUnique _ =
+ liftIO newUnique
instance EventSelector Text
@@ -412,7 +415,7 @@
-- | Includes sandbox sources
wsAllPackages :: Workspace -> [IDEPackage]
-wsAllPackages w = nubBy (\ a b -> ipdCabalFile a == ipdCabalFile b) $ wsPackages w ++ (wsPackages w >>= ipdSandboxSources)
+wsAllPackages w = nubBy ((==) `on` ipdCabalFile) $ wsPackages w ++ (wsPackages w >>= ipdSandboxSources)
-- ---------------------------------------------------------------------
-- Other data structures which are used in the state
@@ -495,6 +498,21 @@
cabalCommand :: Prefs -> FilePath
cabalCommand p = if useCabalDev p then "cabal-dev" else "cabal"
+data EditorStyle = EditorStyle { styleName :: Maybe Text
+ , preferDark :: Bool
+ , breakpointBG :: Color
+ , contextBG :: Color
+ }
+
+editorStyle :: Bool -> Prefs -> EditorStyle
+editorStyle preferDark prefs = EditorStyle { styleName = case sourceStyle prefs of
+ (False,_) -> Nothing
+ (True,v) -> Just v
+ , preferDark = preferDark
+ , breakpointBG = breakpointBackground prefs
+ , contextBG = contextBackground prefs
+ }
+
data SearchHint = Forward | Backward | Insert | Delete | Initial
deriving (Eq)
@@ -519,18 +537,21 @@
logBuffer :: TextBuffer
} deriving Typeable
-data LogRefType = WarningRef | ErrorRef | BreakpointRef | ContextRef deriving (Eq, Show)
+-- Order determines priority of the icons in the gutter
+data LogRefType = ContextRef | BreakpointRef | ErrorRef | TestFailureRef | WarningRef | LintRef
+ deriving (Eq, Show, Enum, Bounded)
data LogRef = LogRef {
logRefSrcSpan :: SrcSpan
, logRefPackage :: IDEPackage
, refDescription :: Text
+, logRefIdea :: Maybe (Text, Idea)
, logLines :: (Int,Int)
, logRefType :: LogRefType
} deriving (Eq)
instance Show LogRef where
- show lr = (T.unpack $ refDescription lr) ++ displaySrcSpan (logRefSrcSpan lr)
+ show lr = T.unpack (refDescription lr) ++ displaySrcSpan (logRefSrcSpan lr)
displaySrcSpan s = srcSpanFilename s ++ ":" ++
if srcSpanStartLine s == srcSpanEndLine s
@@ -561,9 +582,9 @@
isContext = (== ContextRef) . logRefType
-- This should probably be in Gtk2Hs allong with a suitable parser
-colorHexString (Color r g b) = '#' : (pad $ showHex r "")
- ++ (pad $ showHex g "")
- ++ (pad $ showHex b "")
+colorHexString (Color r g b) = '#' : pad (showHex r "")
+ ++ pad (showHex g "")
+ ++ pad (showHex b "")
where pad s = replicate (4 - length s) '0' ++ s
@@ -578,7 +599,7 @@
type SpecialKeyTable alpha = Map (KeyVal,[Modifier]) (Map (KeyVal,[Modifier]) (ActionDescr alpha))
-type SpecialKeyCons alpha = Maybe ((Map (KeyVal,[Modifier]) (ActionDescr alpha)),Text)
+type SpecialKeyCons alpha = Maybe (Map (KeyVal, [Modifier]) (ActionDescr alpha), Text)
data LogTag = LogTag | ErrorTag | FrameTag | InputTag | InfoTag
@@ -595,7 +616,7 @@
| InfoElementSelected {
mbInfo :: Maybe Descr}
| PaneSelected {
- paneN :: Maybe (Text)}
+ paneN :: Maybe Text}
deriving (Eq, Ord, Show)
data SensitivityMask =
@@ -629,8 +650,4 @@
| CompartmentCollect Bool
type PackageDescrCache = Map PackageIdentifier ModuleDescrCache
-#if MIN_VERSION_directory(1,2,0)
type ModuleDescrCache = Map ModuleName (UTCTime, Maybe FilePath, ModuleDescr)
-#else
-type ModuleDescrCache = Map ModuleName (ClockTime, Maybe FilePath, ModuleDescr)
-#endif
diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs
--- a/src/IDE/Debug.hs
+++ b/src/IDE/Debug.hs
@@ -332,7 +332,7 @@
debugShowModules :: IDEAction
debugShowModules = packageTry $ tryDebug $ debugCommand ":show modules" $
- logOutputLines_Default $ \log logLaunch output -> liftIO $ do
+ logOutputLinesDefault_ $ \log logLaunch output -> liftIO $ do
case output of
ToolInput line -> appendLog log logLaunch (line <> "\n") InputTag
ToolOutput line | ", interpreted )" `T.isSuffixOf` line
diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs
--- a/src/IDE/Find.hs
+++ b/src/IDE/Find.hs
@@ -624,8 +624,10 @@
mbText <- liftIO $ replacementText regex text matchIndex matches $ T.unpack replace
case mbText of
Just text -> do
+ beginUserAction ebuf
delete ebuf iterStart iterEnd
insert ebuf iterStart (T.pack text)
+ endUserAction ebuf
Nothing -> do
sysMessage Normal
"Should never happen. findMatch worked but repleacementText failed"
diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs
--- a/src/IDE/ImportTool.hs
+++ b/src/IDE/ImportTool.hs
@@ -23,7 +23,8 @@
) where
import IDE.Core.State
-import Data.Maybe (isNothing,isJust)
+import Data.Maybe
+ (mapMaybe, fromMaybe, catMaybes, fromJust, isNothing, isJust)
import IDE.Metainfo.Provider
(getWorkspaceInfo, getPackageImportInfo, getIdentifierDescr)
import Text.PrettyPrint (render)
@@ -37,11 +38,10 @@
import Graphics.UI.Editor.Parameters
((<<<-), paraMinSize, emptyParams, Parameter(..), paraMultiSel,
paraName)
-import Data.Maybe (catMaybes, fromJust)
import Text.ParserCombinators.Parsec hiding (parse)
import qualified Text.ParserCombinators.Parsec as Parsec (parse)
import Graphics.UI.Editor.Simple (staticListEditor)
-import Control.Monad (forM, when)
+import Control.Monad (void, MonadPlus(..), unless, forM, when)
import Control.Applicative ((<$>))
import Data.List (stripPrefix, sort, nub, nubBy)
import IDE.Utils.ServerConnection
@@ -92,13 +92,15 @@
addPackageResults <- forM errors addPackage
let notInScopes = [ y | (x,y) <-
nubBy (\ (p1,_) (p2,_) -> p1 == p2)
- $ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]],
+ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]],
isJust x]
let extensions = [ y | (x,y) <-
nubBy (\ (p1,_) (p2,_) -> p1 == p2)
- $ [(x,y) | (x,y) <- [((parsePerhapsYouIntendedToUse . refDescription) e, e) | e <- errors]],
+ [(x,y) | (x,y) <- [((parsePerhapsYouIntendedToUse . refDescription) e, e) | e <- errors]],
length x == 1]
- when (not (or addPackageResults) && null notInScopes && null extensions) $ ideMessage Normal $ "No errors that can be auto resolved"
+ when (not (or addPackageResults) && null notInScopes && null extensions) $ do
+ hlintResolved <- resolveActiveHLint
+ unless hlintResolved $ ideMessage Normal "No errors, warnings or selected hlints that can be auto resolved"
addAll buildInBackground notInScopes extensions
where
addAll buildInBackground notInScopes extensions = addAllImports notInScopes (True,[])
@@ -122,7 +124,7 @@
currentErr' <- readIDE currentError
case currentErr' of
Nothing -> do
- ideMessage Normal $ "No error selected"
+ ideMessage Normal "No error selected"
return ()
Just ref -> addImport ref [] (\ _ -> return ())
@@ -146,7 +148,7 @@
wslist = getIdentifierDescr (id' nis) symbolTable3 symbolTable4
in case (list, wslist) of
([], []) -> do
- ideMessage Normal $ "Identifier " <> (id' nis) <> " not found"
+ ideMessage Normal $ "Identifier " <> id' nis <> " not found"
continuation (True, descrList)
([], list) -> do
window' <- getMainWindow
@@ -156,11 +158,11 @@
else Just (head descrList))
case mbDescr of
Nothing -> continuation (False, [])
- Just descr -> if elem descr descrList
+ Just descr -> if descr `elem` descrList
then continuation (True,descrList)
else addImport' nis (logRefFullFilePath error)
descr descrList continuation
- (descr : [], _) -> addImport' nis (logRefFullFilePath error) descr descrList continuation
+ ([descr], _) -> addImport' nis (logRefFullFilePath error) descr descrList continuation
_ -> do
let fullList = list ++ wslist
window' <- getMainWindow
@@ -170,20 +172,20 @@
else Just (head descrList))
case mbDescr of
Nothing -> continuation (False, [])
- Just descr -> if elem descr descrList
+ Just descr -> if descr `elem` descrList
then continuation (True,descrList)
else addImport' nis (logRefFullFilePath error)
descr descrList continuation
addPackage :: LogRef -> IDEM Bool
-addPackage error = do
+addPackage error =
case parseHiddenModule $ refDescription error of
Nothing -> return False
Just (HiddenModuleResult mod pack) -> do
let idePackage = logRefPackage error
- gpd <- liftIO $ readPackageDescription normal (ipdCabalFile $ idePackage)
+ gpd <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage)
ideMessage Normal $ "addPackage " <> (T.pack . display $ pkgName pack)
- liftIO $ writeGenericPackageDescription (ipdCabalFile $ idePackage)
+ liftIO $ writeGenericPackageDescription (ipdCabalFile idePackage)
gpd { condLibrary = addDepToLib pack (condLibrary gpd),
condExecutables = map (addDepToExe pack)
(condExecutables gpd),
@@ -215,7 +217,7 @@
condTreeConstraints = deps <> [dep p],
condTreeData = bm { benchmarkBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}})
-- Empty version is probably only going to happen for ghc-prim
- dep p | null . versionBranch $ packageVersion p = Dependency (packageName p) (anyVersion)
+ dep p | null . versionBranch $ packageVersion p = Dependency (packageName p) anyVersion
dep p = Dependency (packageName p) (
intersectVersionRanges (orLaterVersion (packageVersion p))
(earlierVersion (majorAndMinor (packageVersion p))))
@@ -243,7 +245,7 @@
Nothing -> Nothing
Just pm -> Just (modu pm)
case (mbBuf,mbMod) of
- (Just buf,Just mod) -> do
+ (Just buf,Just mod) ->
inActiveBufContext () $ \ nb _ gtkbuf idebuf n -> do
ideMessage Normal $ "addImport " <> T.pack (show $ dscName descr) <> " from "
<> T.pack (render $ disp mod)
@@ -252,13 +254,13 @@
ServerHeader (Left imports) ->
case filter (qualifyAsImportStatement mod) imports of
[] -> let newLine = prettyPrint (newImpDecl mod) <> "\n"
- lastLine = foldr max 0 (map (locationELine . importLoc) imports)
+ lastLine = foldr (max . locationELine . importLoc) 0 imports
in do
i1 <- getIterAtLine gtkbuf lastLine
editInsertCode gtkbuf i1 newLine
fileSave False
setModified gtkbuf True
- continuation (True,(descr : descrList))
+ continuation (True, descr : descrList)
l@(impDecl:_) ->
let newDecl = addToDecl impDecl
newLine = prettyPrint newDecl <> "\n"
@@ -267,12 +269,12 @@
lineEnd = locationELine myLoc
in do
i1 <- getIterAtLine gtkbuf (lineStart - 1)
- i2 <- getIterAtLine gtkbuf (lineEnd)
+ i2 <- getIterAtLine gtkbuf lineEnd
delete gtkbuf i1 i2
editInsertCode gtkbuf i1 newLine
fileSave False
setModified gtkbuf True
- continuation (True,(descr : descrList))
+ continuation (True, descr : descrList)
ServerHeader (Right lastLine) ->
let newLine = prettyPrint (newImpDecl mod) <> "\n"
in do
@@ -280,13 +282,13 @@
editInsertCode gtkbuf i1 newLine
fileSave False
setModified gtkbuf True
- continuation (True,(descr : descrList))
+ continuation (True, descr : descrList)
ServerFailed string -> do
ideMessage Normal ("Can't parse module header " <> T.pack filePath <>
" failed with: " <> string)
continuation (False,[])
_ -> do
- ideMessage Normal ("ImportTool>>addImport: Impossible server answer")
+ ideMessage Normal "ImportTool>>addImport: Impossible server answer"
continuation (False,[])
_ -> return ()
where
@@ -306,10 +308,8 @@
importQualified = isJust (mbQual' nis),
importSrc = False,
importPkg = Nothing,
- importAs = if isJust (mbQual' nis)
- then Just (fromJust (mbQual' nis))
- else Nothing,
- importSpecs = (Just (ImportSpecList False [newImportSpec]))}
+ importAs = mplus (mbQual' nis) Nothing,
+ importSpecs = Just (ImportSpecList False [newImportSpec])}
newImportSpec :: ImportSpec
newImportSpec = getRealId descr (id' nis)
addToDecl :: ImportDecl -> ImportDecl
@@ -331,9 +331,7 @@
getReal _ = IVar id
qualString :: ImportDecl -> Text
-qualString impDecl = case importAs impDecl of
- Nothing -> ""
- Just modName -> modName
+qualString impDecl = fromMaybe "" (importAs impDecl)
-- | The import data
@@ -354,47 +352,49 @@
dot = P.dot lexer
operator = T.pack <$> P.operator lexer
-parseNotInScope :: Text -> (Maybe NotInScopeParseResult)
+parseNotInScope :: Text -> Maybe NotInScopeParseResult
parseNotInScope str =
case Parsec.parse scopeParser "" $ T.unpack str of
Left e -> Nothing
Right r -> Just r
scopeParser :: CharParser () NotInScopeParseResult
-scopeParser = do
- whiteSpace
- symbol "Not in scope:"
- isSub <- optionMaybe (try (choice [symbol "type constructor or class"
- , symbol "data constructor"]))
- ( (do
- char '`'
- mbQual <- optionMaybe (try (do
- q <- lexeme conid
- dot
- return q))
- id <- optionMaybe (try identifier)
- case id of
- Just id -> return (NotInScopeParseResult mbQual
- (T.take (T.length id - 1) id) (isJust isSub) False)
- Nothing -> do
- op <- operator
- char '\''
- return (NotInScopeParseResult mbQual op (isJust isSub) True))
- <|> (do
- choice [char '‛', char '‘']
- mbQual <- optionMaybe (try (do
- q <- lexeme conid
- dot
- return q))
- id <- optionMaybe (try identifier)
- result <- case id of
- Just id -> return (NotInScopeParseResult mbQual
- id (isJust isSub) False)
- Nothing -> do
- op <- operator
- return (NotInScopeParseResult mbQual op (isJust isSub) True)
- char '’'
- return result))
+scopeParser = do whiteSpace
+ symbol "Not in scope:"
+ isSub <- optionMaybe
+ (try
+ (choice
+ [symbol "type constructor or class", symbol "data constructor"]))
+ (do char '`'
+ mbQual <- optionMaybe
+ (try
+ (do q <- lexeme conid
+ dot
+ return q))
+ id <- optionMaybe (try identifier)
+ case id of
+ Just id -> return
+ (NotInScopeParseResult mbQual (T.take (T.length id - 1) id)
+ (isJust isSub)
+ False)
+ Nothing -> do op <- operator
+ char '\''
+ return (NotInScopeParseResult mbQual op (isJust isSub) True))
+ <|>
+ (do choice [char '\8219', char '\8216']
+ mbQual <- optionMaybe
+ (try
+ (do q <- lexeme conid
+ dot
+ return q))
+ id <- optionMaybe (try identifier)
+ result <- case id of
+ Just id -> return
+ (NotInScopeParseResult mbQual id (isJust isSub) False)
+ Nothing -> do op <- operator
+ return (NotInScopeParseResult mbQual op (isJust isSub) True)
+ char '\8217'
+ return result)
"scopeParser"
conid = do
@@ -413,9 +413,9 @@
$ paraMultiSel <<<- ParaMultiSel False
$ paraMinSize <<<- ParaMinSize (300,400)
$ emptyParams)
- (\ a -> a)
- (\ a b -> a)
- (staticListEditor ( list) id)
+ id
+ const
+ (staticListEditor list id)
selectModuleDialog :: Window -> [Descr] -> Text -> Maybe Text -> Maybe Descr -> IO (Maybe Descr)
selectModuleDialog parentWindow list id mbQual mbDescr =
@@ -430,7 +430,7 @@
Just pm -> Just ((T.pack . render . disp . modu) pm)
let realSelectionString = case mbSelectedString of
Nothing -> head selectionList
- Just str -> if elem str selectionList
+ Just str -> if str `elem` selectionList
then str
else head selectionList
let qualId = case mbQual of
@@ -453,7 +453,7 @@
set okButton [widgetCanDefault := True]
widgetGrabDefault okButton
resp <- dialogRun dia
- value <- ext (T.empty)
+ value <- ext T.empty
widgetHide dia
widgetDestroy dia
--find
@@ -469,7 +469,7 @@
, missingPackage :: PackageId}
deriving (Eq, Show)
-parseHiddenModule :: Text -> (Maybe HiddenModuleResult)
+parseHiddenModule :: Text -> Maybe HiddenModuleResult
parseHiddenModule str =
case Parsec.parse hiddenModuleParser "" $ T.unpack str of
Left e -> Nothing
@@ -482,16 +482,16 @@
hiddenModuleParser = do
whiteSpace
symbol "Could not find module "
- (char '`' <|> char '‛' <|> char '‘')
+ char '`' <|> char '‛' <|> char '‘'
mod <- T.pack <$> many (noneOf "'’")
many (noneOf "\n")
symbol "\n"
whiteSpace
symbol "It is a member of the hidden package "
- (char '`' <|> char '‛' <|> char '‘')
+ char '`' <|> char '‛' <|> char '‘'
pack <- T.pack <$> many (noneOf "'’@")
many (noneOf "'’")
- (char '\'' <|> char '’')
+ char '\'' <|> char '’'
symbol ".\n"
many anyChar
return (mod, pack)
@@ -510,7 +510,7 @@
concatMap (parseLine . T.dropWhile (==' ')) . T.lines
where
parseLine :: Text -> [KnownExtension]
- parseLine line = take 1 . catMaybes . map readMaybe $ catMaybes [
+ parseLine line = take 1 . mapMaybe readMaybe $ catMaybes [
T.stripPrefix "Perhaps you intended to use -X" line
, T.stripPrefix "Perhaps you intended to use " line
, T.takeWhile (/=' ') <$> T.stripPrefix "Use -X" line
@@ -547,12 +547,11 @@
addFixMenuItem (__"Add Import") $ addImport logRef [] (\ _ -> return ())
when (isJust $ parseHiddenModule msg) $
addFixMenuItem (__"Add Package") $ addPackage logRef
- when ((length $ parsePerhapsYouIntendedToUse msg) == 1) $
+ when (length (parsePerhapsYouIntendedToUse msg) == 1) $
addFixMenuItem (__"Add Extension") $ addExtension logRef (\ _ -> return ())
where
addFixMenuItem name fix = do
item <- menuItemNewWithLabel name
- item `on` menuItemActivate $ do
- reflectIDE (fix >> return ()) ideR
+ item `on` menuItemActivate $ reflectIDE (void fix) ideR
menuShellAppend theMenu item
diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs
--- a/src/IDE/Leksah.hs
+++ b/src/IDE/Leksah.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Leksah
@@ -75,7 +75,7 @@
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Conduit (($$))
-import Control.Monad (when, unless, liftM)
+import Control.Monad (void, when, unless, liftM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Applicative ((<$>))
import qualified Data.Text as T (pack, unpack, stripPrefix, unlines)
@@ -94,19 +94,19 @@
deriving (Show,Eq)
options :: [OptDescr Flag]
-options = [Option ['e'] ["emptySession"] (NoArg EmptySession)
+options = [Option "e" ["emptySession"] (NoArg EmptySession)
"Start with empty session"
- , Option ['d'] ["defaultSession"] (NoArg DefaultSession)
+ , Option "d" ["defaultSession"] (NoArg DefaultSession)
"Start with default session (can be used together with a source file)"
- , Option ['l'] ["loadSession"] (ReqArg (SessionN . T.pack) "NAME")
+ , Option "l" ["loadSession"] (ReqArg (SessionN . T.pack) "NAME")
"Load session"
- , Option ['h'] ["help"] (NoArg Help)
+ , Option "h" ["help"] (NoArg Help)
"Display command line options"
- , Option ['v'] ["version"] (NoArg VersionF)
+ , Option "v" ["version"] (NoArg VersionF)
"Show the version number of ide"
- , Option ['e'] ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity")
+ , Option "e" ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity")
"One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"]
@@ -142,14 +142,14 @@
leksah = realMain
#endif
-realMain yiConfig = do
+realMain yiConfig =
withSocketsDo $ handleExceptions $ do
dataDir <- getDataDir
args <- getArgs
(o,files) <- ideOpts $ map T.pack args
isFirstStart <- liftM not $ hasSavedConfigFile standardPreferencesFilename
- let sessions = catMaybes $ map (\x -> case x of
+ let sessions = mapMaybe (\case
SessionN s -> Just s
_ -> Nothing) o
@@ -175,32 +175,31 @@
then standardSessionFilename
else emptySessionFilename
- sessionFP <- if elem EmptySession o
+ sessionFP <- if EmptySession `elem` o
then getConfigFilePathForLoad
emptySessionFilename Nothing dataDir
- else if elem DefaultSession o
+ else if DefaultSession `elem` o
then getConfigFilePathForLoad
standardSessionFilename Nothing dataDir
else case mbWSessionFP of
Just fp -> return fp
Nothing -> getConfigFilePathForLoad
ssession Nothing dataDir
- let verbosity' = catMaybes $
- map (\x -> case x of
- Verbosity s -> Just s
- _ -> Nothing) o
+ let verbosity' = mapMaybe (\case
+ Verbosity s -> Just s
+ _ -> Nothing) o
let verbosity = case verbosity' of
[] -> INFO
h:_ -> read $ T.unpack h
- updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l)
- when (elem VersionF o)
+ updateGlobalLogger rootLoggerName (setLevel verbosity)
+ when (VersionF `elem` o)
(sysMessage Normal $ "Leksah the Haskell IDE, version " <> T.pack (showVersion version))
- when (elem Help o)
+ when (Help `elem` o)
(sysMessage Normal $ "Leksah the Haskell IDE " <> T.pack (usageInfo header options))
prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir
prefs <- readPrefs prefsPath
- when (not (elem VersionF o) && not (elem Help o))
+ when (notElem VersionF o && notElem Help o)
(startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs prefs isFirstStart)
handleExceptions inner =
@@ -213,7 +212,7 @@
-- | Start the GUI
startGUI :: Yi.Config -> FilePath -> Maybe FilePath -> [FilePath] -> Prefs -> Bool -> IO ()
-startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs iprefs isFirstStart = do
+startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs iprefs isFirstStart =
Yi.start yiConfig $ \yiControl -> do
st <- unsafeInitGUIForThreadedRTS
when rtsSupportsBoundThreads
@@ -251,7 +250,7 @@
prefs <- readPrefs prefsPath
return $ Just prefs
timeoutRemove timeout
- postGUIAsync $ do
+ postGUIAsync $
case mbStartupPrefs of
Nothing -> return ()
Just startupPrefs -> startMainWindow yiControl sessionFP mbWorkspaceFP sourceFPs
@@ -268,9 +267,7 @@
where
loop = do
quit <- loopTillIdle
- if quit
- then return ()
- else do
+ unless quit $ do
active <- newEmptyMVar
mvarSentIdleMessage <- newEmptyMVar
idleThread <- forkIO $ do
@@ -281,17 +278,13 @@
postGUIAsync onIdle
quit <- mainIteration
putMVar active ()
- if quit
- then return ()
- else do
+ unless quit $ do
-- If an idle message was sent then wait again
sentIdleMessage <- isJust <$> tryTakeMVar mvarSentIdleMessage
quit <- if sentIdleMessage
then mainIteration
else return False
- if quit
- then return ()
- else loop
+ unless quit loop
loopTillIdle = do
pending <- eventsPending
if pending == 0
@@ -316,14 +309,11 @@
return quit
else
loopn (n+2)
- if quit
- then return ()
- else do
+ unless quit $ do
yield
pending <- eventsPending
if pending > 0
- then do
- loop False 50 pending
+ then loop False 50 pending
else do
threadDelay delay
eventsPending >>= loop isIdle (if n > 0
@@ -365,7 +355,7 @@
, panes = Map.empty
, activePane = Nothing
, paneMap = Map.empty
- , layout = (TerminalP Map.empty Nothing (-1) Nothing Nothing)
+ , layout = TerminalP Map.empty Nothing (-1) Nothing Nothing
, panePathFromNB = Map.empty
}
@@ -424,7 +414,7 @@
registerLeksahEvents
pair <- recoverSession sessionFP
workspaceOpenThis False mbWorkspaceFP
- mapM fileOpenThis sourceFPs
+ mapM_ fileOpenThis sourceFPs
wins <- getWindows
mapM_ instrumentSecWindow (tail wins)
return pair
@@ -455,9 +445,9 @@
createDirectoryIfMissing True $ welcomePath"src"
createDirectoryIfMissing True $ welcomePath"test"
copyFile (welcomeSource"Setup.lhs") (welcomePath"Setup.lhs")
- copyFile (welcomeSource"leksah-welcome.cabal") (welcomeCabal)
+ copyFile (welcomeSource"leksah-welcome.cabal") welcomeCabal
copyFile (welcomeSource"LICENSE") (welcomePath"LICENSE")
- copyFile (welcomeSource"src""Main.hs") (welcomeMain)
+ copyFile (welcomeSource"src""Main.hs") welcomeMain
copyFile (welcomeSource"test""Main.hs") (welcomePath"test""Main.hs")
defaultWorkspace <- liftIO $ ( "leksah.lkshw") <$> getHomeDirectory
defaultExists <- liftIO $ doesFileExist defaultWorkspace
@@ -465,14 +455,14 @@
if defaultExists
then workspaceOpenThis False (Just defaultWorkspace)
else workspaceNewHere defaultWorkspace
- workspaceTryQuiet $ workspaceAddPackage' welcomeCabal >> return ()
+ workspaceTryQuiet $ void (workspaceAddPackage' welcomeCabal)
fileOpenThis welcomeMain) ideR
reflectIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning}))) ideR
timeoutRemove timeout
postGUIAsync . mainLoop $
reflectIDE (do
currentPrefs <- readIDE prefs
- when (backgroundBuild currentPrefs) $ backgroundMake) ideR
+ when (backgroundBuild currentPrefs) backgroundMake) ideR
-- timeoutAddFull (do
-- reflectIDE (do
-- currentPrefs <- readIDE prefs
@@ -501,7 +491,7 @@
(paraName <<<- ParaName "URL from which to download prebuilt metadata" $ emptyParams)
retrieveURL
(\b a -> a{retrieveURL = b})
- (textEditor (\ _ -> True) True)
+ (textEditor (const True) True)
, mkField
(paraName <<<- ParaName "Strategy for downloading prebuilt metadata" $ emptyParams)
retrieveStrategy
@@ -555,12 +545,12 @@
writePrefs fp newPrefs
fp2 <- getConfigFilePathForSave strippedPreferencesFilename
SP.writeStrippedPrefs fp2
- (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,
+ SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,
SP.unpackDirectory = unpackDirectory newPrefs,
SP.retrieveURL = retrieveURL newPrefs,
SP.retrieveStrategy = retrieveStrategy newPrefs,
SP.serverPort = serverPort newPrefs,
- SP.endWithLastConn = endWithLastConn newPrefs})
+ SP.endWithLastConn = endWithLastConn newPrefs}
firstBuild newPrefs
return True
_ -> do
diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs
--- a/src/IDE/LogRef.hs
+++ b/src/IDE/LogRef.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.LogRef
@@ -26,7 +26,7 @@
, defaultLineLogger'
, logOutputLines
, logOutputLines_
-, logOutputLines_Default
+, logOutputLinesDefault_
, logOutput
, logOutputDefault
, logOutputPane
@@ -56,7 +56,7 @@
import qualified IDE.Pane.Log as Log
import IDE.Utils.Tool
import System.FilePath (equalFilePath)
-import Data.List (stripPrefix, elemIndex, isPrefixOf)
+import Data.List (partition, stripPrefix, elemIndex, isPrefixOf)
import Data.Maybe (catMaybes, isJust)
import System.Exit (ExitCode(..))
import System.Log.Logger (debugM)
@@ -72,6 +72,9 @@
import qualified Data.Text as T
(length, stripPrefix, isPrefixOf, unpack, unlines, pack, null)
import Data.Monoid ((<>))
+import qualified Data.Set as S (member, insert, empty)
+import Data.Set (Set)
+import System.FilePath.Windows (())
showSourceSpan :: LogRef -> Text
showSourceSpan = T.pack . displaySrcSpan . logRefSrcSpan
@@ -80,37 +83,36 @@
selectRef (Just ref) = do
logRefs <- readIDE allLogRefs
case elemIndex ref logRefs of
- Nothing -> liftIO $ debugM "leksah" "no index" >> return ()
+ Nothing -> liftIO . void $ debugM "leksah" "no index"
Just index -> do
mbBuf <- selectSourceBuf (logRefFullFilePath ref)
case mbBuf of
- Just buf -> markRefInSourceBuf index buf ref True
- Nothing -> liftIO $ debugM "leksah" "no buf" >> return ()
+ Just buf -> markRefInSourceBuf buf ref True
+ Nothing -> liftIO . void $ debugM "leksah" "no buf"
log :: Log.IDELog <- Log.getLog
Log.markErrorInLog log (logLines ref)
selectRef Nothing = return ()
-forOpenLogRefs :: (Int -> LogRef -> IDEBuffer -> IDEAction) -> IDEAction
+forOpenLogRefs :: (LogRef -> IDEBuffer -> IDEAction) -> IDEAction
forOpenLogRefs f = do
logRefs <- readIDE allLogRefs
allBufs <- allBuffers
- forM_ [0 .. ((length logRefs)-1)] (\index -> do
- let ref = logRefs !! index
- fp = logRefFullFilePath ref
+ forM_ logRefs $ \ref -> do
+ let fp = logRefFullFilePath ref
fpc <- liftIO $ myCanonicalizePath fp
- forM_ (filter (\buf -> case (fileName buf) of
+ forM_ (filter (\buf -> case fileName buf of
Just fn -> equalFilePath fpc fn
- Nothing -> False) allBufs) (f index ref))
+ Nothing -> False) allBufs) (f ref)
markLogRefs :: IDEAction
-markLogRefs = do
- forOpenLogRefs $ \index logRef buf -> markRefInSourceBuf index buf logRef False
+markLogRefs =
+ forOpenLogRefs $ \logRef buf -> markRefInSourceBuf buf logRef False
unmarkLogRefs :: IDEAction
-unmarkLogRefs = do
- forOpenLogRefs $ \index logRef (IDEBuffer {sourceView = sv}) -> do
+unmarkLogRefs =
+ forOpenLogRefs $ \logRef (IDEBuffer {sourceView = sv}) -> do
buf <- getBuffer sv
- removeTagByName buf (T.pack $ show (logRefType logRef) ++ show index)
+ removeTagByName buf (T.pack $ show (logRefType logRef))
setErrorList :: [LogRef] -> IDEAction
setErrorList errs = do
@@ -139,7 +141,7 @@
addLogRefs refs = do
ideR <- ask
unmarkLogRefs
- modifyIDE_ (\ide -> ide{allLogRefs = (allLogRefs ide) ++ refs})
+ modifyIDE_ (\ide -> ide{allLogRefs = allLogRefs ide ++ refs})
setCurrentError Nothing
markLogRefs
triggerEventIDE ErrorChanged
@@ -151,120 +153,102 @@
nextError = do
errs <- readIDE errorRefs
currentError <- readIDE currentError
- if null errs
- then return ()
- else do
- let new = case currentError of
- Nothing -> 0
- Just ref ->
- case elemIndex ref errs of
- Nothing -> 0
- Just n | (n + 1) < length errs -> (n + 1)
- Just n -> n
- setCurrentError (Just $ errs!!new)
- selectRef $ Just (errs!!new)
+ unless (null errs) $
+ do let new
+ = case currentError of
+ Nothing -> 0
+ Just ref -> case elemIndex ref errs of
+ Nothing -> 0
+ Just n | (n + 1) < length errs -> n + 1
+ Just n -> n
+ setCurrentError (Just $ errs !! new)
+ selectRef $ Just (errs !! new)
previousError :: IDEAction
previousError = do
errs <- readIDE errorRefs
currentError <- readIDE currentError
- if null errs
- then return ()
- else do
- let new = case currentError of
- Nothing -> (length errs - 1)
- Just ref ->
- case elemIndex ref errs of
- Nothing -> (length errs - 1)
- Just n | n > 0 -> (n - 1)
- Just n -> 0
- setCurrentError (Just $ errs!!new)
- selectRef $ Just (errs!!new)
+ unless (null errs) $
+ do let new
+ = case currentError of
+ Nothing -> length errs - 1
+ Just ref -> case elemIndex ref errs of
+ Nothing -> length errs - 1
+ Just n | n > 0 -> n - 1
+ Just n -> 0
+ setCurrentError (Just $ errs !! new)
+ selectRef $ Just (errs !! new)
nextBreakpoint :: IDEAction
nextBreakpoint = do
breaks <- readIDE breakpointRefs
currentBreak <- readIDE currentBreak
- if null breaks
- then return ()
- else do
- let new = case currentBreak of
- Nothing -> 0
- Just ref ->
- case elemIndex ref breaks of
- Nothing -> 0
- Just n | (n + 1) < length breaks -> (n + 1)
- Just n -> n
- setCurrentBreak (Just $ breaks!!new)
- selectRef $ Just (breaks!!new)
+ unless (null breaks) $
+ do let new
+ = case currentBreak of
+ Nothing -> 0
+ Just ref -> case elemIndex ref breaks of
+ Nothing -> 0
+ Just n | (n + 1) < length breaks -> n + 1
+ Just n -> n
+ setCurrentBreak (Just $ breaks !! new)
+ selectRef $ Just (breaks !! new)
previousBreakpoint :: IDEAction
previousBreakpoint = do
breaks <- readIDE breakpointRefs
currentBreak <- readIDE currentBreak
- if null breaks
- then return ()
- else do
- let new = case currentBreak of
- Nothing -> (length breaks - 1)
- Just ref ->
- case elemIndex ref breaks of
- Nothing -> (length breaks - 1)
- Just n | n > 0 -> (n - 1)
- Just n -> 0
- setCurrentBreak (Just $ breaks!!new)
- selectRef $ Just (breaks!!new)
+ unless (null breaks) $
+ do let new
+ = case currentBreak of
+ Nothing -> length breaks - 1
+ Just ref -> case elemIndex ref breaks of
+ Nothing -> length breaks - 1
+ Just n | n > 0 -> n - 1
+ Just n -> 0
+ setCurrentBreak (Just $ breaks !! new)
+ selectRef $ Just (breaks !! new)
nextContext :: IDEAction
nextContext = do
contexts <- readIDE contextRefs
currentContext <- readIDE currentContext
- if null contexts
- then return ()
- else do
- let new = case currentContext of
- Nothing -> 0
- Just ref ->
- case elemIndex ref contexts of
- Nothing -> 0
- Just n | (n + 1) < length contexts -> (n + 1)
- Just n -> n
- setCurrentContext (Just $ contexts!!new)
- selectRef $ Just (contexts!!new)
+ unless (null contexts) $
+ do let new
+ = case currentContext of
+ Nothing -> 0
+ Just ref -> case elemIndex ref contexts of
+ Nothing -> 0
+ Just n | (n + 1) < length contexts -> n + 1
+ Just n -> n
+ setCurrentContext (Just $ contexts !! new)
+ selectRef $ Just (contexts !! new)
previousContext :: IDEAction
previousContext = do
contexts <- readIDE contextRefs
currentContext <- readIDE currentContext
- if null contexts
- then return ()
- else do
- let new = case currentContext of
- Nothing -> (length contexts - 1)
- Just ref ->
- case elemIndex ref contexts of
- Nothing -> (length contexts - 1)
- Just n | n > 0 -> (n - 1)
- Just n -> 0
- setCurrentContext (Just $ contexts!!new)
- selectRef $ Just (contexts!!new)
+ unless (null contexts) $
+ do let new
+ = case currentContext of
+ Nothing -> length contexts - 1
+ Just ref -> case elemIndex ref contexts of
+ Nothing -> length contexts - 1
+ Just n | n > 0 -> n - 1
+ Just n -> 0
+ setCurrentContext (Just $ contexts !! new)
+ selectRef $ Just (contexts !! new)
lastContext :: IDEAction
lastContext = do
contexts <- readIDE contextRefs
currentContext <- readIDE currentContext
- if null contexts
- then return ()
- else do
- let new = (last contexts)
- setCurrentContext (Just new)
- selectRef $ Just new
+ unless (null contexts) $ do
+ let new = last contexts
+ setCurrentContext (Just new)
+ selectRef $ Just new
-#if MIN_VERSION_ghc(7,0,1)
fixColumn c = max 0 (c - 1)
-#else
-fixColumn = id
-#endif
srcPathParser :: CharParser () FilePath
srcPathParser = try (do
@@ -308,8 +292,28 @@
return $ SrcSpan filePath line (fixColumn col) line (fixColumn col))
"srcSpanParser"
-docTestParser :: CharParser () (SrcSpan, Text)
-docTestParser = try (do
+data BuildOutput = BuildProgress Int Int FilePath
+ | DocTestFailure SrcSpan Text
+
+buildOutputParser :: CharParser () BuildOutput
+buildOutputParser = try (do
+ char '['
+ n <- int
+ whiteSpace
+ symbol "of"
+ whiteSpace
+ total <- int
+ char ']'
+ whiteSpace
+ symbol "Compiling"
+ many (noneOf "(")
+ char '('
+ whiteSpace
+ file <- many (noneOf ",")
+ char ','
+ many anyChar
+ return $ BuildProgress n total file)
+ <|> try (do
symbol "###"
whiteSpace
symbol "Failure"
@@ -322,8 +326,8 @@
char ':'
whiteSpace
text <- T.pack <$> many anyChar
- return ((SrcSpan file line 7 line (T.length text - 7)), "Failure in " <> text))
- "docTestParser"
+ return $ DocTestFailure (SrcSpan file line 7 line (T.length text - 7)) $ "Failure in " <> text)
+ "buildOutputParser"
data BuildError = BuildLine
| EmptyLine
@@ -331,14 +335,14 @@
| WarningLine Text
| OtherLine Text
-buildLineParser :: CharParser () BuildError
-buildLineParser = try (do
+buildErrorParser :: CharParser () BuildError
+buildErrorParser = try (do
char '['
int
symbol "of"
int
char ']'
- many (anyChar)
+ many anyChar
return BuildLine)
<|> try (do
whiteSpace
@@ -378,7 +382,7 @@
whiteSpace
span <- srcSpanParser
return (BreakpointDescription n span))
- "buildLineParser"
+ "breaksLineParser"
setBreakpointLineParser :: CharParser () BreakpointDescription
setBreakpointLineParser = try (do
@@ -401,22 +405,22 @@
symbol = P.symbol lexer
identifier = P.identifier lexer
colon = P.colon lexer
-int = fmap fromInteger $ P.integer lexer
+int = fromInteger <$> P.integer lexer
defaultLineLogger :: IDELog -> LogLaunch -> ToolOutput -> IDEM Int
defaultLineLogger log logLaunch out = liftIO $ defaultLineLogger' log logLaunch out
defaultLineLogger' :: IDELog -> LogLaunch -> ToolOutput -> IO Int
-defaultLineLogger' log logLaunch out = do
+defaultLineLogger' log logLaunch out =
case out of
ToolInput line -> appendLog' (line <> "\n") InputTag
ToolOutput line -> appendLog' (line <> "\n") LogTag
ToolError line -> appendLog' (line <> "\n") ErrorTag
ToolPrompt line -> do
- unless (T.null line) $ appendLog' (line <> "\n") LogTag >> return ()
- appendLog' (T.pack (concat (take 20 (repeat "- "))) <> "-\n") FrameTag
- ToolExit ExitSuccess -> appendLog' (T.pack (take 41 (repeat '-')) <> "\n") FrameTag
- ToolExit (ExitFailure 1) -> appendLog' (T.pack (take 41 (repeat '=')) <> "\n") FrameTag
+ unless (T.null line) $ void (appendLog' (line <> "\n") LogTag)
+ appendLog' (T.pack (concat (replicate 20 "- ")) <> "-\n") FrameTag
+ ToolExit ExitSuccess -> appendLog' (T.pack (replicate 41 '-') <> "\n") FrameTag
+ ToolExit (ExitFailure 1) -> appendLog' (T.pack (replicate 41 '=') <> "\n") FrameTag
ToolExit (ExitFailure n) -> appendLog' (T.pack (take 41 ("========== " ++ show n <> " " ++ repeat '=')) <> "\n") FrameTag
where
appendLog' = Log.appendLog log logLaunch
@@ -425,17 +429,17 @@
paneLineLogger log logLaunch out = liftIO $ paneLineLogger' log logLaunch out
paneLineLogger' :: IDELog -> LogLaunch -> ToolOutput -> IO (Maybe Text)
-paneLineLogger' log logLaunch out = do
+paneLineLogger' log logLaunch out =
case out of
ToolInput line -> appendLog' (line <> "\n") InputTag >> return Nothing
ToolOutput line -> appendLog' (line <> "\n") LogTag >> return (Just line)
ToolError line -> appendLog' (line <> "\n") ErrorTag >> return Nothing
ToolPrompt line -> do
- unless (T.null line) $ appendLog' (line <> "\n") LogTag >> return ()
- appendLog' (T.pack (concat (take 20 (repeat "- "))) <> "-\n") FrameTag
+ unless (T.null line) $ void (appendLog' (line <> "\n") LogTag)
+ appendLog' (T.pack (concat (replicate 20 "- ")) <> "-\n") FrameTag
return Nothing
- ToolExit ExitSuccess -> appendLog' (T.pack (take 41 (repeat '-')) <> "\n") FrameTag >> return Nothing
- ToolExit (ExitFailure 1) -> appendLog' (T.pack (take 41 (repeat '=')) <> "\n") FrameTag >> return Nothing
+ ToolExit ExitSuccess -> appendLog' (T.pack (replicate 41 '-') <> "\n") FrameTag >> return Nothing
+ ToolExit (ExitFailure 1) -> appendLog' (T.pack (replicate 41 '=') <> "\n") FrameTag >> return Nothing
ToolExit (ExitFailure n) -> appendLog' (T.pack (take 41 ("========== " ++ show n ++ " " ++ repeat '=')) <> "\n") FrameTag >> return Nothing
where
appendLog' = Log.appendLog log logLaunch
@@ -445,7 +449,7 @@
-> C.Sink ToolOutput IDEM [a]
logOutputLines logLaunch lineLogger = do
log :: Log.IDELog <- lift $ postSyncIDE Log.getLog
- results <- (CL.mapM $ postSyncIDE . lineLogger log logLaunch) =$ CL.consume
+ results <- CL.mapM (postSyncIDE . lineLogger log logLaunch) =$ CL.consume
lift $ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])
return results
@@ -456,10 +460,10 @@
logOutputLines logLaunch lineLogger
return ()
-logOutputLines_Default :: (IDELog -> LogLaunch -> ToolOutput -> IDEM a)
+logOutputLinesDefault_ :: (IDELog -> LogLaunch -> ToolOutput -> IDEM a)
-> C.Sink ToolOutput IDEM ()
-logOutputLines_Default lineLogger = do
- defaultLogLaunch <- lift $ getDefaultLogLaunch
+logOutputLinesDefault_ lineLogger = do
+ defaultLogLaunch <- lift getDefaultLogLaunch
logOutputLines_ defaultLogLaunch lineLogger
logOutput :: LogLaunch
@@ -470,30 +474,41 @@
logOutputDefault :: C.Sink ToolOutput IDEM ()
logOutputDefault = do
- defaultLogLaunch <- lift $ getDefaultLogLaunch
+ defaultLogLaunch <- lift getDefaultLogLaunch
logOutput defaultLogLaunch
logOutputPane :: Text -> IORef [Text] -> C.Sink ToolOutput IDEM ()
logOutputPane command buffer = do
- defaultLogLaunch <- lift $ getDefaultLogLaunch
+ defaultLogLaunch <- lift getDefaultLogLaunch
result <- catMaybes <$> logOutputLines defaultLogLaunch paneLineLogger
- when (not $ null result) $ do
+ unless (null result) $ do
new <- liftIO . atomicModifyIORef buffer $ \x -> let new = x ++ result in (new, new)
mbURI <- lift $ readIDE autoURI
unless (isJust mbURI) . lift . postSyncIDE . setOutput command $ T.unlines new
+data BuildOutputState = BuildOutputState { log :: IDELog
+ , inError :: Bool
+ , inDocTest :: Bool
+ , errs :: [LogRef]
+ , testFails :: [LogRef]
+ , filesCompiled :: Set FilePath
+ }
+
+-- Not quite a Monoid
+initialState :: IDELog -> BuildOutputState
+initialState log = BuildOutputState log False False [] [] S.empty
+
logOutputForBuild :: IDEPackage
-> Bool
-> Bool
-> C.Sink ToolOutput IDEM [LogRef]
logOutputForBuild package backgroundBuild jumpToWarnings = do
- liftIO $ putStrLn $ "logOutputForBuild"
+ liftIO $ putStrLn "logOutputForBuild"
log <- lift getLog
- logLaunch <- lift $ Log.getDefaultLogLaunch
- (_, _, _, errs) <- CL.foldM (readAndShow logLaunch) (log, False, False, [])
+ logLaunch <- lift Log.getDefaultLogLaunch
+ BuildOutputState {..} <- CL.foldM (readAndShow logLaunch) $ initialState log
ideR <- lift ask
liftIO $ postGUISync $ reflectIDE (do
- setErrorList $ reverse errs
triggerEventIDE (Sensitivity [(SensitivityError,not (null errs))])
let errorNum = length (filter isError errs)
let warnNum = length errs - errorNum
@@ -502,88 +517,121 @@
unless (backgroundBuild || (not jumpToWarnings && errorNum == 0)) nextError
return errs) ideR
where
- readAndShow :: LogLaunch -> (IDELog, Bool, Bool, [LogRef]) -> ToolOutput -> IDEM (IDELog, Bool, Bool, [LogRef])
- readAndShow logLaunch (log, inError, inDocTest, errs) output = do
+ readAndShow :: LogLaunch -> BuildOutputState -> ToolOutput -> IDEM BuildOutputState
+ readAndShow logLaunch state@BuildOutputState {..} output = do
ideR <- ask
+ let logPrevious (previous:_) = reflectIDE (addLogRef previous) ideR
+ logPrevious _ = return ()
+
liftIO $ postGUISync $ case output of
ToolError line -> do
- let parsed = parse buildLineParser "" $ T.unpack line
+ let parsed = parse buildErrorParser "" $ T.unpack line
let nonErrorPrefixes = ["Linking ", "ar:", "ld:", "ld warning:"]
tag <- case parsed of
Right BuildLine -> return InfoTag
- Right (OtherLine text) | "Linking " `T.isPrefixOf` text -> do
+ Right (OtherLine text) | "Linking " `T.isPrefixOf` text ->
-- when backgroundBuild $ lift interruptProcess
- reflectIDE (do
- setErrorList $ reverse errs
- ) ideR
return InfoTag
- Right (OtherLine text) | any (`T.isPrefixOf` text) nonErrorPrefixes -> do
+ Right (OtherLine text) | any (`T.isPrefixOf` text) nonErrorPrefixes ->
return InfoTag
_ -> return ErrorTag
lineNr <- Log.appendLog log logLaunch (line <> "\n") tag
case (parsed, errs) of
(Left e,_) -> do
sysMessage Normal . T.pack $ show e
- return (log, False, False, errs)
- (Right ne@(ErrorLine span refType str),_) ->
- return (log, True, False, ((LogRef span package str (lineNr,lineNr) refType):errs))
- (Right (OtherLine str1),(LogRef span rootPath str (l1,l2) refType):tl) ->
+ return state { inError = False }
+ (Right ne@(ErrorLine span refType str),_) -> do
+ let ref = LogRef span package str Nothing (lineNr,lineNr) refType
+ root = logRefRootPath ref
+ file = logRefFilePath ref
+ fullFilePath = logRefFullFilePath ref
+ unless (fullFilePath `S.member` filesCompiled) $
+ reflectIDE (removeBuildLogRefs root file) ideR
+ when inError $ logPrevious errs
+ return state { inError = True
+ , errs = ref:errs
+ , filesCompiled = S.insert fullFilePath filesCompiled
+ }
+ (Right (OtherLine str1), ref@(LogRef span rootPath str Nothing (l1,l2) refType):tl) ->
if inError
- then return (log, True, False, ((LogRef span
- rootPath
- (if T.null str
- then line
- else str <> "\n" <> line)
- (l1,lineNr) refType) : tl))
- else return (log, False, False, errs)
- (Right (WarningLine str1),(LogRef span rootPath str (l1,l2) isError):tl) ->
+ then return state { errs = LogRef span rootPath
+ (if T.null str then line else str <> "\n" <> line)
+ Nothing
+ (l1, lineNr)
+ refType
+ : tl
+ }
+ else return state
+ (Right (WarningLine str1),LogRef span rootPath str Nothing (l1, l2) isError : tl) ->
if inError
- then return (log, True, False, ((LogRef span
- rootPath
- (if T.null str
- then line
- else str <> "\n" <> line)
- (l1,lineNr) WarningRef) : tl))
- else return (log, False, False, errs)
- otherwise -> return (log, False, False, errs)
- ToolOutput line -> do
- case (parse docTestParser "" $ T.unpack line, inDocTest, errs) of
- (Right (span, exp), _, _) -> do
+ then return state { errs = LogRef span rootPath
+ (if T.null str then line else str <> "\n" <> line)
+ Nothing
+ (l1, lineNr)
+ WarningRef
+ : tl
+ }
+ else return state
+ _ -> do
+ when inError $ logPrevious errs
+ return state { inError = False }
+ ToolOutput line ->
+ case (parse buildOutputParser "" $ T.unpack line, inDocTest, testFails) of
+ (Right (BuildProgress n total file), _, _) -> do
+ logLn <- Log.appendLog log logLaunch (line <> "\n") LogTag
+ reflectIDE (triggerEventIDE (StatusbarChanged [CompartmentState
+ (T.pack $ "Compiling " ++ show n ++ " of " ++ show total), CompartmentBuild False])) ideR
+ let root = ipdBuildDir package
+ fullFilePath = root file
+ unless (fullFilePath `S.member` filesCompiled) $
+ reflectIDE (removeBuildLogRefs root file) ideR
+ when inDocTest $ logPrevious testFails
+ return state { inDocTest = False }
+ (Right (DocTestFailure span exp), _, _) -> do
logLn <- Log.appendLog log logLaunch (line <> "\n") ErrorTag
- return (log, inError, True, LogRef span
+ when inDocTest $ logPrevious testFails
+ return state { inDocTest = True
+ , testFails = LogRef span
package
exp
- (logLn,logLn) ErrorRef : errs)
- (_, True, (LogRef span rootPath str (l1,l2) refType):tl) -> do
+ Nothing (logLn,logLn) TestFailureRef : testFails
+ }
+ (_, True, LogRef span rootPath str Nothing (l1, l2) refType : tl) -> do
logLn <- Log.appendLog log logLaunch (line <> "\n") ErrorTag
- return (log, inError, inDocTest, LogRef span
+ return state { testFails = LogRef span
rootPath
(str <> "\n" <> line)
- (l1,logLn) ErrorRef : tl)
+ Nothing (l1,logLn) TestFailureRef : tl
+ }
_ -> do
Log.appendLog log logLaunch (line <> "\n") LogTag
- return (log, inError, False, errs)
+ when inDocTest $ logPrevious testFails
+ return state { inDocTest = False }
ToolInput line -> do
Log.appendLog log logLaunch (line <> "\n") InputTag
- return (log, inError, inDocTest, errs)
+ return state
ToolPrompt line -> do
- unless (T.null line) $ Log.appendLog log logLaunch (line <> "\n") LogTag >> return ()
+ unless (T.null line) . void $ Log.appendLog log logLaunch (line <> "\n") LogTag
+ when inError $ logPrevious errs
+ when inDocTest $ logPrevious testFails
let errorNum = length (filter isError errs)
let warnNum = length errs - errorNum
case errs of
[] -> defaultLineLogger' log logLaunch output
_ -> Log.appendLog log logLaunch (T.pack $ "- - - " ++ show errorNum ++ " errors - "
++ show warnNum ++ " warnings - - -\n") FrameTag
- return (log, inError, inDocTest, errs)
+ return state { inError = False, inDocTest = False }
ToolExit _ -> do
let errorNum = length (filter isError errs)
- let warnNum = length errs - errorNum
- case errs of
- [] -> defaultLineLogger' log logLaunch output
+ warnNum = length errs - errorNum
+ when inError $ logPrevious errs
+ when inDocTest $ logPrevious testFails
+ case (errs, testFails) of
+ ([], []) -> defaultLineLogger' log logLaunch output
_ -> Log.appendLog log logLaunch (T.pack $ "----- " ++ show errorNum ++ " errors -- "
- ++ show warnNum ++ " warnings -----\n") FrameTag
- return (log, inError, inDocTest, errs)
-
+ ++ show warnNum ++ " warnings -- "
+ ++ show (length testFails) ++ " doctest failures -----\n") FrameTag
+ return state { inError = False, inDocTest = False }
--logOutputLines :: Text -- ^ logLaunch
-- -> (LogLaunch -> ToolOutput -> IDEM a)
@@ -594,13 +642,13 @@
-> LogLaunch -- ^ loglaunch
-> C.Sink ToolOutput IDEM ()
logOutputForBreakpoints package logLaunch = do
- breaks <- logOutputLines logLaunch (\log logLaunch out -> do
+ breaks <- logOutputLines logLaunch (\log logLaunch out ->
case out of
ToolOutput line -> do
logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag
case parse breaksLineParser "" $ T.unpack line of
Right (BreakpointDescription n span) ->
- return $ Just $ LogRef span package line (logLineNumber, logLineNumber) BreakpointRef
+ return $ Just $ LogRef span package line Nothing (logLineNumber, logLineNumber) BreakpointRef
_ -> return Nothing
_ -> do
defaultLineLogger log logLaunch out
@@ -611,13 +659,13 @@
-> LogLaunch -- ^ loglaunch
-> C.Sink ToolOutput IDEM ()
logOutputForSetBreakpoint package logLaunch = do
- breaks <- logOutputLines logLaunch (\log logLaunch out -> do
+ breaks <- logOutputLines logLaunch (\log logLaunch out ->
case out of
ToolOutput line -> do
logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag
case parse setBreakpointLineParser "" $ T.unpack line of
Right (BreakpointDescription n span) ->
- return $ Just $ LogRef span package line (logLineNumber, logLineNumber) BreakpointRef
+ return $ Just $ LogRef span package line Nothing (logLineNumber, logLineNumber) BreakpointRef
_ -> return Nothing
_ -> do
defaultLineLogger log logLaunch out
@@ -627,7 +675,7 @@
logOutputForSetBreakpointDefault :: IDEPackage
-> C.Sink ToolOutput IDEM ()
logOutputForSetBreakpointDefault package = do
- defaultLogLaunch <- lift $ getDefaultLogLaunch
+ defaultLogLaunch <- lift getDefaultLogLaunch
logOutputForSetBreakpoint package defaultLogLaunch
logOutputForContext :: IDEPackage
@@ -635,14 +683,14 @@
-> (Text -> [SrcSpan])
-> C.Sink ToolOutput IDEM ()
logOutputForContext package loglaunch getContexts = do
- refs <- fmap catMaybes $ logOutputLines loglaunch (\log logLaunch out -> do
+ refs <- catMaybes <$> logOutputLines loglaunch (\log logLaunch out ->
case out of
ToolOutput line -> do
logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag
let contexts = getContexts line
if null contexts
then return Nothing
- else return $ Just $ LogRef (last contexts) package line (logLineNumber, logLineNumber) ContextRef
+ else return $ Just $ LogRef (last contexts) package line Nothing (logLineNumber, logLineNumber) ContextRef
_ -> do
defaultLineLogger log logLaunch out
return Nothing)
@@ -653,7 +701,7 @@
contextParser :: CharParser () SrcSpan
contextParser = try (do
whiteSpace
- (symbol "Logged breakpoint at" <|> symbol "Stopped at")
+ symbol "Logged breakpoint at" <|> symbol "Stopped at"
whiteSpace
srcSpanParser)
"historicContextParser"
@@ -671,7 +719,7 @@
logOutputForLiveContextDefault :: IDEPackage
-> C.Sink ToolOutput IDEM ()
logOutputForLiveContextDefault package = do
- defaultLogLaunch <- lift $ getDefaultLogLaunch
+ defaultLogLaunch <- lift getDefaultLogLaunch
logOutputForLiveContext package defaultLogLaunch
@@ -687,5 +735,5 @@
logOutputForHistoricContextDefault :: IDEPackage
-> C.Sink ToolOutput IDEM ()
logOutputForHistoricContextDefault package = do
- defaultLogLaunch <- lift $ getDefaultLogLaunch
+ defaultLogLaunch <- lift getDefaultLogLaunch
logOutputForHistoricContext package defaultLogLaunch
diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs
--- a/src/IDE/Metainfo/Provider.hs
+++ b/src/IDE/Metainfo/Provider.hs
@@ -90,18 +90,15 @@
then do
ideMessage Normal "Now updating system metadata ..."
callCollector False True True $ \ _ -> do
- ideMessage Normal "Now loading metadata ..."
- loadSystemInfo
- updateWorkspaceInfo' False $ \ _ -> do
- void (triggerEventIDE (InfoChanged True))
-
- liftIO $ infoM "leksah" "initInfo continuing"
- continuation
- else do
+ ideMessage Normal "Finished updating system metadata"
+ doLoad
+ else doLoad
+ where
+ doLoad = do
ideMessage Normal "Now loading metadata ..."
loadSystemInfo
+ ideMessage Normal "Finished loading metadata"
updateWorkspaceInfo' False $ \ _ -> do
- ideMessage Normal "Finished"
void (triggerEventIDE (InfoChanged True))
continuation
@@ -834,17 +831,30 @@
Nothing
Nothing
Nothing
- (Just (BS.pack " Haskell keyword"))
+ (Just (BS.pack "Haskell keyword"))
KeywordDescr
True) keywords
+misc :: [(Text, String)]
+misc = [("--", "Haskell comment"), ("=", "Haskell definition")]
+
+miscDescrs :: [Descr]
+miscDescrs = map (\(s, d) -> Real $ RealDescr
+ s
+ Nothing
+ Nothing
+ Nothing
+ (Just (BS.pack d))
+ KeywordDescr
+ True) misc
+
extensionDescrs :: [Descr]
extensionDescrs = map (\ext -> Real $ RealDescr
(T.pack $ "X" ++ show ext)
Nothing
Nothing
Nothing
- (Just (BS.pack " Haskell language extension"))
+ (Just (BS.pack "Haskell language extension"))
ExtensionDescr
True)
([minBound..maxBound]::[KnownExtension])
@@ -855,7 +865,7 @@
Nothing
(Just (mdModuleId md))
Nothing
- (Just (BS.pack " Module name"))
+ (Just (BS.pack "Module name"))
ModNameDescr
True) (pdModules pd)
@@ -863,7 +873,7 @@
addOtherToScope (PackScope packageMap symbolTable) addAll = PackScope packageMap newSymbolTable
where newSymbolTable = foldl' (\ map descr -> symInsert (dscName descr) [descr] map)
symbolTable (if addAll
- then keywordDescrs ++ extensionDescrs ++ modNameDescrs
+ then keywordDescrs ++ extensionDescrs ++ modNameDescrs ++ miscDescrs
else modNameDescrs)
modNameDescrs = concatMap moduleNameDescrs (Map.elems packageMap)
diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs
--- a/src/IDE/Package.hs
+++ b/src/IDE/Package.hs
@@ -94,20 +94,18 @@
import IDE.LogRef
import Distribution.ModuleName (ModuleName(..))
import Data.List (isInfixOf, nub, foldl', delete)
-import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..), toolline)
+import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..), toolline, ProcessHandle, executeGhciCommand)
import qualified Data.Set as Set (fromList)
import qualified Data.Map as Map (empty, fromList)
import System.Exit (ExitCode(..))
import Control.Applicative ((<$>), (<*>))
-import IDE.Utils.Tool (executeGhciCommand, getProcessExitCode, interruptProcessGroupOf,
- ProcessHandle)
import qualified Data.Conduit as C (Sink, ZipSink(..), getZipSink)
import qualified Data.Conduit.List as CL (foldM, fold, consume)
import Data.Conduit (($$))
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
-import Control.Monad (when, unless, liftM, forM, forM_)
+import Control.Monad (void, when, unless, liftM, forM, forM_)
import Distribution.PackageDescription.PrettyPrint
(writeGenericPackageDescription)
import Debug.Trace (trace)
@@ -182,7 +180,7 @@
runExternalTool' (__ "Configuring")
(cabalCommand prefs)
- (["configure"] ++ (ipdConfigFlags package))
+ ("configure" : ipdConfigFlags package)
dir $ do
mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink (logOutput logLaunch)
lift $ do
@@ -202,11 +200,9 @@
runCabalBuild backgroundBuild jumpToWarnings withoutLinking package shallConfigure continuation = do
prefs <- readIDE prefs
let dir = ipdBuildDir package
- let args = (["build"]
- ++ (if backgroundBuild && withoutLinking
- then ["--with-ld=false"]
- else [])
- ++ ipdBuildFlags package)
+ let args = ["build"]
+ ++ ["--with-ld=false" | backgroundBuild && withoutLinking]
+ ++ ipdBuildFlags package
runExternalTool' (__ "Building") (cabalCommand prefs) args dir $ do
(mbLastOutput, isConfigErr, _) <- C.getZipSink $ (,,)
<$> C.ZipSink sinkLast
@@ -242,7 +238,7 @@
if alreadyRunning
then do
interruptBuild
- when (not backgroundBuild) $ liftIO $ do
+ unless backgroundBuild . liftIO $ do
timeoutAddFull (do
reflectIDE (do
buildPackage backgroundBuild jumpToWarnings withoutLinking
@@ -265,7 +261,7 @@
when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ())
(`runDebug` debug) . executeDebugCommand ":reload" $ do
errs <- logOutputForBuild package backgroundBuild jumpToWarnings
- unless (any isError $ errs) $ do
+ unless (any isError errs) $ do
cmd <- lift $ readIDE autoCommand
liftIO . postGUISync $ reflectIDE cmd ideR
lift $ continuation True
@@ -282,13 +278,12 @@
prefs <- readIDE prefs
catchIDE (do
let dir = ipdBuildDir package
- runExternalTool' (__ "Documenting") (cabalCommand prefs) (["haddock"]
- ++ (ipdHaddockFlags package)) dir $ do
+ runExternalTool' (__ "Documenting") (cabalCommand prefs) ("haddock" : ipdHaddockFlags package) dir $ do
mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> (C.ZipSink $
logOutputForBuild package backgroundBuild jumpToWarnings)
- lift $ reloadDoc
+ lift reloadDoc
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
packageClean :: PackageAction
packageClean = do
@@ -326,10 +321,10 @@
let dir = ipdBuildDir package
runExternalTool' (__ "Copying")
(cabalCommand prefs)
- (["copy"] ++ ["--destdir=" <> T.pack fp])
+ ("copy" : ["--destdir=" <> T.pack fp])
dir
(logOutput logLaunch))
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
packageInstallDependencies :: PackageAction
packageInstallDependencies = do
@@ -345,9 +340,9 @@
(if useCabalDev prefs
then ["install-deps"]
else ["install","--only-dependencies"])
- ++ (ipdConfigFlags package)
- ++ (ipdInstallFlags package)) dir (logOutput logLaunch))
- (\(e :: SomeException) -> putStrLn (show e))
+ ++ ipdConfigFlags package
+ ++ ipdInstallFlags package) dir (logOutput logLaunch))
+ (\(e :: SomeException) -> print e)
packageCopy' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction
packageCopy' package continuation = do
@@ -357,20 +352,19 @@
catchIDE (do
let dir = ipdBuildDir package
- runExternalTool' (__ "Copying") (cabalCommand prefs) (["copy"]
- ++ (ipdInstallFlags package)) dir $ do
+ runExternalTool' (__ "Copying") (cabalCommand prefs) ("copy" : ipdInstallFlags package) dir $ do
mbLastOutput <- C.getZipSink $ (const <$> C.ZipSink sinkLast) <*> C.ZipSink (logOutput logLaunch)
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
packageRun :: PackageAction
packageRun = ask >>= (liftIDE . packageRun' True)
packageRun' :: Bool -> IDEPackage -> IDEAction
-packageRun' removeGhcjsFlagIfPresent package = do
+packageRun' removeGhcjsFlagIfPresent package =
if removeGhcjsFlagIfPresent && "--ghcjs" `elem` ipdConfigFlags package
then do
- window <- liftIDE $ getMainWindow
+ window <- liftIDE getMainWindow
resp <- liftIO $ do
md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel
(__ "Package is configured to use GHCJS. Would you like to remove --ghcjs from the configure flags and rebuild?")
@@ -385,13 +379,14 @@
let packWithNewFlags = package { ipdConfigFlags = filter (/="--ghcjs") $ ipdConfigFlags package }
changePackage packWithNewFlags
liftIO $ writeFlags (dropExtension (ipdCabalFile packWithNewFlags) ++ leksahFlagFileExtension) packWithNewFlags
- packageConfig' packWithNewFlags $ \ ok -> when ok $ do
+ packageConfig' packWithNewFlags $ \ ok -> when ok $
packageRun' False packWithNewFlags
_ -> return ()
else liftIDE $ catchIDE (do
ideR <- ask
maybeDebug <- readIDE debugState
- pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription
+ pd <- liftIO $ liftM flattenPackageDescription
+ (readPackageDescription normal (ipdCabalFile package))
mbExe <- readIDE activeExe
let exe = take 1 . filter (isActiveExe mbExe) $ executables pd
let defaultLogName = T.pack . display . pkgName $ ipdPackageId package
@@ -410,17 +405,17 @@
, ipdExeFlags package])
dir
(logOutput logLaunch)
- Just debug -> do
+ Just debug ->
-- TODO check debug package matches active package
runDebug (do
case exe of
- [Executable name mainFilePath _] -> do
+ [Executable name mainFilePath _] ->
executeDebugCommand (":module *" <> T.pack (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath)))
(logOutput logLaunch)
_ -> return ()
executeDebugCommand (":main " <> T.unwords (ipdExeFlags package)) (logOutput logLaunch))
debug)
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
where
isActiveExe selected (Executable name _ _) = selected == Just (T.pack name)
@@ -428,10 +423,10 @@
packageRunJavaScript = ask >>= (liftIDE . packageRunJavaScript' True)
packageRunJavaScript' :: Bool -> IDEPackage -> IDEAction
-packageRunJavaScript' addFlagIfMissing package = do
- if addFlagIfMissing && not ("--ghcjs" `elem` ipdConfigFlags package)
+packageRunJavaScript' addFlagIfMissing package =
+ if addFlagIfMissing && ("--ghcjs" `notElem` ipdConfigFlags package)
then do
- window <- liftIDE $ getMainWindow
+ window <- liftIDE getMainWindow
resp <- liftIO $ do
md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel
(__ "Package is not configured to use GHCJS. Would you like to add --ghcjs to the configure flags and rebuild?")
@@ -443,16 +438,17 @@
return resp
case resp of
ResponseUser 1 -> do
- let packWithNewFlags = package { ipdConfigFlags = ["--ghcjs"] ++ ipdConfigFlags package }
+ let packWithNewFlags = package { ipdConfigFlags = "--ghcjs" : ipdConfigFlags package }
changePackage packWithNewFlags
liftIO $ writeFlags (dropExtension (ipdCabalFile packWithNewFlags) ++ leksahFlagFileExtension) packWithNewFlags
- packageConfig' packWithNewFlags $ \ ok -> when ok $ do
+ packageConfig' packWithNewFlags $ \ ok -> when ok $
packageRunJavaScript' False packWithNewFlags
_ -> return ()
else liftIDE $ buildPackage False False True package $ \ ok -> when ok $ liftIDE $ catchIDE (do
ideR <- ask
maybeDebug <- readIDE debugState
- pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription
+ pd <- liftIO $ liftM flattenPackageDescription
+ (readPackageDescription normal (ipdCabalFile package))
mbExe <- readIDE activeExe
let exe = take 1 . filter (isActiveExe mbExe) $ executables pd
let defaultLogName = T.pack . display . pkgName $ ipdPackageId package
@@ -472,10 +468,10 @@
openBrowser path
#endif
`catchIDE`
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
_ -> return ())
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
where
isActiveExe selected (Executable name _ _) = selected == Just (T.pack name)
@@ -493,11 +489,10 @@
catchIDE (do
prefs <- readIDE prefs
let dir = ipdBuildDir package
- runExternalTool' (__ "Registering") (cabalCommand prefs) (["register"]
- ++ (ipdRegisterFlags package)) dir $ do
+ runExternalTool' (__ "Registering") (cabalCommand prefs) ("register" : ipdRegisterFlags package) dir $ do
mbLastOutput <- C.getZipSink $ (const <$> C.ZipSink sinkLast) <*> C.ZipSink (logOutput logLaunch)
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
else continuation True
packageTest :: PackageAction
@@ -529,7 +524,7 @@
else do
continuation (mbLastOutput == Just (ToolExit ExitSuccess))
return ())
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
else continuation True
packageSdist :: PackageAction
@@ -542,9 +537,8 @@
catchIDE (do
prefs <- readIDE prefs
let dir = ipdBuildDir package
- runExternalTool' (__ "Source Dist") (cabalCommand prefs) (["sdist"]
- ++ (ipdSdistFlags package)) dir (logOutput logLaunch))
- (\(e :: SomeException) -> putStrLn (show e))
+ runExternalTool' (__ "Source Dist") (cabalCommand prefs) ("sdist" : ipdSdistFlags package) dir (logOutput logLaunch))
+ (\(e :: SomeException) -> print e)
packageOpenDoc :: PackageAction
@@ -565,7 +559,7 @@
openBrowser $ T.pack path
#endif
`catchIDE`
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
runPackage :: (ProcessHandle -> IDEAction)
@@ -595,7 +589,7 @@
pd <- readPackageDescription normal (ipdCabalFile p)
return (Just (flattenPackageDescription pd,ipdCabalFile p)))
(\(e :: SomeException) -> do
- reflectIDE (ideMessage Normal ((__ "Can't load package ") <> T.pack (show e))) ideR
+ reflectIDE (ideMessage Normal (__ "Can't load package " <> T.pack (show e))) ideR
return Nothing))
getEmptyModuleTemplate :: PackageDescription -> Text -> IO Text
@@ -629,7 +623,7 @@
let npd = trace (show gpd) foldr addModule gpd locations
writeGenericPackageDescription (ipdCabalFile p) npd)
(\(e :: SomeException) -> do
- reflectIDE (ideMessage Normal ((__ "Can't update package ") <> T.pack (show e))) ideR
+ reflectIDE (ideMessage Normal (__ "Can't update package " <> T.pack (show e))) ideR
return ()))
where
addModule LibExposedMod gpd@GenericPackageDescription{condLibrary = Just lib} =
@@ -692,7 +686,7 @@
(condExecutables gpd)}
writeGenericPackageDescription (ipdCabalFile p) npd)
(\(e :: SomeException) -> do
- reflectIDE (ideMessage Normal ((__ "Can't update package ") <> T.pack (show e))) ideR
+ reflectIDE (ideMessage Normal (__ "Can't update package " <> T.pack (show e))) ideR
return ()))
delModFromLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->
@@ -714,7 +708,7 @@
isExposedModule :: ModuleName -> Maybe (CondTree ConfVar [Dependency] Library) -> Bool
isExposedModule mn Nothing = False
-isExposedModule mn (Just CondNode{condTreeData = lib}) = elem mn (exposedModules lib)
+isExposedModule mn (Just CondNode{condTreeData = lib}) = mn `elem` exposedModules lib
backgroundBuildToggled :: IDEAction
backgroundBuildToggled = do
@@ -752,10 +746,10 @@
interactiveFlags :: Prefs -> [Text]
interactiveFlags prefs =
- (printEvldWithShowFlag $ printEvldWithShow prefs)
- : (breakOnExceptionFlag $ breakOnException prefs)
- : (breakOnErrorFlag $ breakOnError prefs)
- : [printBindResultFlag $ printBindResult prefs]
+ printEvldWithShowFlag (printEvldWithShow prefs)
+ : breakOnExceptionFlag (breakOnException prefs)
+ : breakOnErrorFlag (breakOnError prefs)
+ : [printBindResultFlag $ printBindResult prefs]
debugStart :: PackageAction
debugStart = do
@@ -769,7 +763,7 @@
let dir = ipdBuildDir package
mbExe <- readIDE activeExe
ghci <- reifyIDE $ \ideR -> newGhci dir mbExe (interactiveFlags prefs')
- $ reflectIDEI (logOutputForBuild package True False >> return ()) ideR
+ $ reflectIDEI (void (logOutputForBuild package True False)) ideR
modifyIDE_ (\ide -> ide {debugState = Just (package, ghci)})
triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)])
setDebugToggled True
@@ -784,7 +778,7 @@
modifiedPacks <- fileCheckAll belongsToPackages
let modified = not (null modifiedPacks)
prefs <- readIDE prefs
- when ((not modified) && (backgroundBuild prefs)) $ do
+ when (not modified && backgroundBuild prefs) $ do
-- So although none of the pakages are modified,
-- they may have been modified in ghci mode.
-- Lets build to make sure the binaries are up to date
@@ -796,17 +790,17 @@
_ -> do
sysMessage Normal (__ "Debugger already running")
return ())
- (\(e :: SomeException) -> putStrLn (show e))
+ (\(e :: SomeException) -> print e)
tryDebug :: DebugAction -> PackageAction
tryDebug f = do
maybeDebug <- liftIDE $ readIDE debugState
case maybeDebug of
- Just debug -> do
+ Just debug ->
-- TODO check debug package matches active package
liftIDE $ runDebug f debug
_ -> do
- window <- liftIDE $ getMainWindow
+ window <- liftIDE getMainWindow
resp <- liftIO $ do
md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel
(__ "GHCi debugger is not running.")
@@ -829,16 +823,16 @@
tryDebugQuiet f = do
maybeDebug <- liftIDE $ readIDE debugState
case maybeDebug of
- Just debug -> do
+ Just debug ->
-- TODO check debug package matches active package
liftIDE $ runDebug f debug
- _ -> do
+ _ ->
return ()
-executeDebugCommand :: Text -> (C.Sink ToolOutput IDEM ()) -> DebugAction
+executeDebugCommand :: Text -> C.Sink ToolOutput IDEM () -> DebugAction
executeDebugCommand command handler = do
(_, ghci) <- ask
- lift $ do
+ lift $
reifyIDE $ \ideR -> do
liftIO $ postGUIAsync $ reflectIDE (do
triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True])
@@ -865,7 +859,7 @@
pd <- readPackageDescription normal ipdCabalFile
return (Just (flattenPackageDescription pd)))
(\ (e :: SomeException) -> do
- reflectIDE (ideMessage Normal ((__ "Can't activate package ") <> T.pack (show e))) ideR
+ reflectIDE (ideMessage Normal (__ "Can't activate package " <> T.pack (show e))) ideR
return Nothing))
case mbPackageD of
Nothing -> return Nothing
@@ -877,7 +871,7 @@
++ [ (f, bi, True) | TestSuite _ (TestSuiteExeV10 _ f) bi _ <- testSuites packageD ]
++ [ (f, bi, True) | Benchmark _ (BenchmarkExeV10 _ f) bi _ <- benchmarks packageD ]
ipdExtraSrcs = Set.fromList $ extraSrcFiles packageD
- ipdSrcDirs = case (nub $ concatMap hsSourceDirs (allBuildInfo' packageD)) of
+ ipdSrcDirs = case nub $ concatMap hsSourceDirs (allBuildInfo' packageD) of
[] -> [".","src"]
l -> l
ipdExes = [ T.pack $ exeName e | e <- executables packageD
@@ -902,11 +896,11 @@
ipdSandboxSources = []
packp = IDEPackage {..}
pfile = dropExtension ipdCabalFile
- pack <- (do
+ pack <- do
flagFileExists <- liftIO $ doesFileExist (pfile ++ leksahFlagFileExtension)
if flagFileExists
then liftIO $ readFlags (pfile ++ leksahFlagFileExtension) packp
- else return packp)
+ else return packp
return (Just pack)
idePackageFromPath :: C.Sink ToolOutput IDEM () -> FilePath -> IDEM (Maybe IDEPackage)
@@ -923,7 +917,7 @@
map (T.unpack . toolline) . takeWhile (/= ToolOutput "") . drop 1 $ dropWhile (/= ToolOutput "") output
_ -> []
paths <- liftIO $ takeMVar mvar
- sandboxSources <- concat <$> (forM paths $ \ path -> do
+ sandboxSources <- concat <$> forM paths (\ path -> do
contents <- liftIO $ getDirectoryContents path
return . take 1 . map (path ) $ filter ((== ".cabal") . takeExtension) contents)
s <- liftM catMaybes . mapM idePackageFromPath' $ nub sandboxSources
diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs
--- a/src/IDE/Pane/Errors.hs
+++ b/src/IDE/Pane/Errors.hs
@@ -86,9 +86,10 @@
cellLayoutPackStart colA rendererA False
cellLayoutSetAttributes colA rendererA errorStore
$ \row -> [cellText := if index row == 0 then showSourceSpan (logRef row) else "",
- cellTextForeground := if logRefType (logRef row) == WarningRef
- then "green"
- else "red"::Text ]
+ cellTextForeground := case logRefType (logRef row) of
+ WarningRef -> "orange" :: Text
+ LintRef -> "green"
+ _ -> "red" ]
rendererB <- cellRendererTextNew
colB <- treeViewColumnNew
treeViewColumnSetTitle colB (__ "Description")
diff --git a/src/IDE/Pane/Files.hs b/src/IDE/Pane/Files.hs
--- a/src/IDE/Pane/Files.hs
+++ b/src/IDE/Pane/Files.hs
@@ -74,8 +74,9 @@
import Data.List (sortBy, sort)
import Data.Ord (comparing)
import Data.Char (toLower)
-import IDE.Core.Types (IDE(..), Prefs (..))
+import IDE.Core.Types (IDEPackage(..), IDE(..), Prefs(..))
import Data.Tree (Tree(..))
+import System.Log.Logger (debugM)
data FileRecord =
FileRecord FilePath
@@ -208,7 +209,7 @@
let packages = maybe [] wsPackages mbWS
setDirectories store Nothing $ map PackageRecord packages
- forM_ (zip [0..] packages) $ \(n, package) -> do
+ forM_ (zip [0..] packages) $ \(n, package) ->
refreshRecursively store [n] view
-- | Returns the 'FileRecord's at the given 'FilePath'.
@@ -234,7 +235,7 @@
isExpanded <- liftIO $ treeViewRowExpanded view path
record <- liftIO $ treeStoreGetValue store path
- when isExpanded $ do
+ when isExpanded $
case record of
DirRecord dir -> do
refreshDir store path dir
@@ -252,6 +253,7 @@
-- add-source dependencies as a 'PackageRecord'.
refreshPackage :: TreeStore FileRecord -> TreePath -> IDEPackage -> IDEAction
refreshPackage store path p = do
+ liftIO $ debugM "leksah" $ "refreshPackage " <> ipdCabalFile p
let dir = ipdBuildDir p
mbIter <- liftIO $ treeModelGetIter store path
when (isJust mbIter) $ do
@@ -262,6 +264,7 @@
-- | Refreshes the child nodes of the node at the given 'TreePath'.
refreshDir :: TreeStore FileRecord -> TreePath -> FilePath -> IDEAction
refreshDir store path dir = do
+ liftIO $ debugM "leksah" $ "refreshPackage " <> dir
mbIter <- liftIO $ treeModelGetIter store path
when (isJust mbIter) $ do
contents <- dirContents dir
diff --git a/src/IDE/Pane/HLint.hs b/src/IDE/Pane/HLint.hs
--- a/src/IDE/Pane/HLint.hs
+++ b/src/IDE/Pane/HLint.hs
@@ -1,349 +1,332 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------
---
--- Module : IDE.Pane.HLint
--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
--- License : GNU-GPL
---
--- Maintainer :
--- Stability : provisional
--- Portability : portable
---
--- | The pane of ide where HLint results are displayed
---
------------------------------------------------------------------------------
-
-module IDE.Pane.HLint (
- IDEHLint(..)
-, refreshHLint
-, HLintState(..)
-, getHLint
-) where
-
-
-import Graphics.UI.Gtk hiding (get)
-import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
-import Text.ParserCombinators.Parsec.Language
-import Text.ParserCombinators.Parsec hiding(Parser)
-import qualified Text.ParserCombinators.Parsec.Token as P
-import Data.Maybe
-import Data.Typeable
-import IDE.Core.State hiding (SrcSpan(..))
-import IDE.BufferMode
-import IDE.LogRef (logOutput, defaultLineLogger)
-import IDE.Pane.SourceBuffer
- (goToSourceDefinition', maybeActiveBuf, IDEBuffer(..), replaceHLintSource)
-import IDE.TextEditor (grabFocus)
-import Control.Applicative ((<$>))
-import System.FilePath ((), dropFileName)
-import System.Exit (ExitCode(..))
-import IDE.Pane.Log (getLog)
-import Control.Monad (void, forM_, foldM, when)
-import Control.Monad.Trans.Reader (ask)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Language.Haskell.HLint (Suggestion(..), suggestionLocation)
-import Language.Haskell.Exts (SrcLoc(..))
-import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
-
-import qualified Language.Haskell.HLint2 as H
-import IDE.Utils.GUIUtils (__, treeViewContextMenu)
-import Data.List (isPrefixOf, findIndex)
-import Debug.Trace (trace)
-import Control.Exception (SomeException, catch)
-import Distribution.ModuleName (ModuleName)
-import IDE.Metainfo.Provider (getWorkspaceInfo)
-import qualified Data.Map as Map (keys, lookup)
-import Distribution.Package (PackageIdentifier(..))
-import Data.Text (Text)
-import qualified Data.Text as T
- (replicate, unlines, init, lines, pack, unpack)
-import Data.Monoid ((<>))
-import qualified System.IO.Strict as S (readFile)
-
-data HLintRecord = HLintRecord {
- condPackage :: Maybe IDEPackage
- , context :: Text
- , condIdea :: Maybe H.Idea
- , parDir :: Maybe FilePath
- } deriving (Eq)
-
-isDir HLintRecord{parDir = Nothing} = True
-isDir otherwies = False
-
--- | A HLint pane description
---
-
-data IDEHLint = IDEHLint {
- scrolledView :: ScrolledWindow
-, treeView :: TreeView
-, hlintStore :: TreeStore HLintRecord
-} deriving Typeable
-
-data HLintState = HLintState
- deriving(Eq,Ord,Read,Show,Typeable)
-
-instance Pane IDEHLint IDEM
- where
- primPaneName _ = "HLint"
- getAddedIndex _ = 0
- getTopWidget = castToWidget . scrolledView
- paneId b = "*HLint"
-
-instance RecoverablePane IDEHLint HLintState IDEM where
- saveState p = return (Just HLintState)
- recoverState pp HLintState = do
- nb <- getNotebook pp
- buildPane pp nb builder
- builder pp nb windows = reifyIDE $ \ ideR -> do
- hlintStore <- treeStoreNew []
- treeView <- treeViewNew
- treeViewSetModel treeView hlintStore
-
- renderer1 <- cellRendererTextNew
- renderer10 <- cellRendererPixbufNew
- col1 <- treeViewColumnNew
- treeViewColumnSetTitle col1 (__ "Context")
- treeViewColumnSetSizing col1 TreeViewColumnAutosize
- treeViewColumnSetResizable col1 True
- treeViewColumnSetReorderable col1 True
- treeViewAppendColumn treeView col1
- cellLayoutPackStart col1 renderer10 False
- cellLayoutPackStart col1 renderer1 True
- cellLayoutSetAttributes col1 renderer1 hlintStore
- $ \row -> [ cellText := context row ]
-
- treeViewSetHeadersVisible treeView False
- sel <- treeViewGetSelection treeView
- treeSelectionSetMode sel SelectionSingle
-
- scrolledView <- scrolledWindowNew Nothing Nothing
- scrolledWindowSetShadowType scrolledView ShadowIn
- containerAdd scrolledView treeView
- scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
-
- let hlint = IDEHLint {..}
- cid1 <- after treeView focusInEvent $ do
- liftIO $ reflectIDE (makeActive hlint) ideR
- return True
- cid2 <- on treeView rowExpanded $ \ iter path -> do
- record <- treeStoreGetValue hlintStore path
- case record of
- HLintRecord { condPackage = Just p, parDir = Nothing } ->
- reflectIDE (refreshDir hlintStore iter p) ideR
- _ -> reflectIDE (ideMessage Normal (__ "Unexpected Expansion in HLint Pane")) ideR
- cid3 <- on treeView rowActivated $ \ path col -> do
- record <- treeStoreGetValue hlintStore path
- mbIter <- treeModelGetIter hlintStore path
- case (mbIter, record) of
- (Just iter, HLintRecord { condPackage = Just p, parDir = Nothing }) ->
- reflectIDE (refreshDir hlintStore iter p) ideR
- _ -> return ()
- cid4 <- on treeView keyPressEvent $ do
- name <- eventKeyName
- liftIO $ case name of
- "Return" -> reflectIDE (gotoSource True treeView hlintStore) ideR
- "Escape" -> do
- reflectIDE (do
- lastActiveBufferPane ?>>= \paneName -> do
- (PaneC pane) <- paneFromName paneName
- makeActive pane
- return ()
- triggerEventIDE StartFindInitial) ideR
- return True
- -- gotoSource True
- _ -> return False
- treeViewContextMenu treeView
- $ hlintContextMenu ideR hlintStore treeView
- on sel treeSelectionSelectionChanged (reflectIDE (void $ gotoSource False treeView hlintStore) ideR)
-
- return (Just hlint,map ConnectC [cid1])
-
-getHLint :: Maybe PanePath -> IDEM IDEHLint
-getHLint Nothing = forceGetPane (Right "*HLint")
-getHLint (Just pp) = forceGetPane (Left pp)
-
-data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound
-
-find :: Eq a => a -> TreeStore a -> Maybe TreeIter -> IO FindResult
-find _ _ Nothing = return NotFound
-find a store (Just iter) = do
- row <- treeModelGetRow store iter
- if row == a
- then return $ WhereExpected iter
- else treeModelIterNext store iter >>= find'
- where
- find' :: Maybe TreeIter -> IO FindResult
- find' Nothing = return NotFound
- find' (Just iter) = do
- row <- treeModelGetRow store iter
- if row == a
- then return $ Found iter
- else treeModelIterNext store iter >>= find'
-
-removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()
-removeUntil a store path = do
- row <- treeStoreGetValue store path
- when (row /= a) $ do
- found <- treeStoreRemove store path
- when found $ removeUntil a store path
-
-removeRemaining :: TreeStore a -> TreePath -> IO ()
-removeRemaining store path = do
- found <- treeStoreRemove store path
- when found $ removeRemaining store path
-
-
-getSelectionHLintRecord :: TreeView
- -> TreeStore HLintRecord
- -> IO (Maybe HLintRecord)
-getSelectionHLintRecord treeView hlintStore = do
- treeSelection <- treeViewGetSelection treeView
- paths <- treeSelectionGetSelectedRows treeSelection
- case paths of
- p:_ -> Just <$> treeStoreGetValue hlintStore p
- _ -> return Nothing
-
-refreshHLint :: WorkspaceAction
-refreshHLint = do
- ws <- ask
- maybeActive <- lift $ readIDE activePack
- let packages = case maybeActive of
- Just active -> active : filter (/= active) (wsAllPackages ws)
- Nothing -> wsAllPackages ws
- lift $ hlintDirectories2 packages
-
-
---gotoSource :: Bool -> IDEM Bool
-gotoSource focus treeView hlintStore = do
- sel <- liftIO $ getSelectionHLintRecord treeView hlintStore
- case sel of
- Just record ->
- case record of
- HLintRecord {condIdea = Just idea} ->
- goToSourceDefinition' (srcSpanFilename (H.ideaSpan idea))
- (Location "" (srcSpanStartLine (H.ideaSpan idea))
- (srcSpanStartColumn (H.ideaSpan idea))
- (srcSpanEndLine (H.ideaSpan idea))
- (srcSpanEndColumn (H.ideaSpan idea)))
- ?>>= (\(IDEBuffer {sourceView = sv}) -> when focus $ grabFocus sv)
- _ -> return ()
- Nothing -> return ()
- return True
-
-
-hlintDirectories2 :: [IDEPackage] -> IDEAction
-hlintDirectories2 packages = do
- hlint <- getHLint Nothing
- let store = hlintStore hlint
- liftIO $ do
- treeStoreClear store
- forM_ packages $ \ p -> do
- nDir <- treeModelIterNChildren store Nothing
- treeStoreInsert store [] nDir $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
- treeStoreInsert store [nDir] 0 $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
-
-refreshDir :: TreeStore HLintRecord -> TreeIter -> IDEPackage -> IDEM ()
-refreshDir store iter package = do
- mbHlintDir <- liftIO $ leksahSubDir "hlint"
- (flags, classify, hint) <- liftIO $ case mbHlintDir of
- Just d ->
-#if MIN_VERSION_hlint(1, 9, 13)
- H.autoSettings' d
-#else
- H.autoSettings
-#endif
- Nothing -> H.autoSettings
- let modules = Map.keys (ipdModules package)
- paths <- getSourcePaths (ipdPackageId package) modules
- resL <- liftIO $ mapM (\ file -> do
- str <- S.readFile file
- H.parseModuleEx flags file (Just str)) paths
- let resOk = mapMaybe (\ pr -> case pr of
- Left e -> trace ("can't parse: " ++ H.parseErrorContents e ++
- " location " ++ show H.parseErrorLocation) Nothing
- Right r -> Just r) resL
- let ideas = H.applyHints classify hint resOk
- liftIO $ setHLint2Results store iter (T.unpack $ packageIdentifierToString (ipdPackageId package)) ideas
- return ()
-
-
-getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath]
-getSourcePaths packId names = do
- mbWorkspaceInfo <- getWorkspaceInfo
- case mbWorkspaceInfo of
- Nothing -> return []
- Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names)
- where
- sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath
- sourcePathFromScope (GenScopeC (PackScope l _)) mn =
- case packId `Map.lookup` l of
- Just pack ->
- case filter (\md -> modu (mdModuleId md) == mn)
- (pdModules pack) of
- (mod : tl) -> mdMbSourcePath mod
- [] -> Nothing
- Nothing -> Nothing
-
-
-hlint2Record dir idea = HLintRecord {
- condPackage = Nothing,
- context = T.pack $ show idea,
- condIdea = Just idea,
- parDir = Just dir}
-
-setHLint2Results :: TreeStore HLintRecord -> TreeIter -> FilePath -> [H.Idea] -> IO Int
-setHLint2Results store parent dir ideas = do
- parentPath <- treeModelGetPath store parent
- forM_ (zip [0..] records) $ \(n, record) -> do
- mbChild <- treeModelIterNthChild store (Just parent) n
- findResult <- find record store mbChild
- case (mbChild, findResult) of
- (_, WhereExpected _) -> return ()
- (Just iter, Found _) -> do
- path <- treeModelGetPath store iter
- removeUntil record store path
- _ -> treeStoreInsert store parentPath n record
- removeRemaining store (parentPath++[nRecords])
- return nRecords
- where
- records = map (hlint2Record dir) ideas
- nRecords = length records
-
-hlintContextMenu :: IDERef
- -> TreeStore HLintRecord
- -> TreeView
- -> Menu
- -> IO ()
-hlintContextMenu ideR store treeView theMenu = do
- mbSel <- getSelectionHLintRecord treeView store
- item0 <- menuItemNewWithLabel (__ "Replace")
- item0 `on` menuItemActivate $ reflectIDE (replaceHlint store treeView mbSel) ideR
- menuShellAppend theMenu item0
- where
- replaceableSelection Nothing = False
- replaceableSelection (Just s) | isNothing (parDir s) = True
- | otherwise = False
-
-replaceHlint store treeView (Just sel) =
- case condIdea sel of
- Just idea | isJust (H.ideaTo idea) ->
- let lined = T.lines (T.pack $ fromJust (H.ideaTo idea))
- startColumn = srcSpanStartColumn (H.ideaSpan idea)
- source = T.init $ T.unlines (head lined :
- map (\ s -> T.replicate startColumn " " <> s) (tail lined))
- in
- replaceHLintSource (srcSpanFilename (H.ideaSpan idea))
- (srcSpanStartLine (H.ideaSpan idea))
- startColumn
- (srcSpanEndLine (H.ideaSpan idea))
- (srcSpanEndColumn (H.ideaSpan idea))
- source
- otherwise -> return ()
-replaceHlint _ _ Nothing = return ()
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Pane.HLint
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- Stability : provisional
+-- Portability : portable
+--
+-- | The pane of ide where HLint results are displayed
+--
+-----------------------------------------------------------------------------
+
+module IDE.Pane.HLint (
+ IDEHLint(..)
+, refreshHLint
+, HLintState(..)
+, getHLint
+) where
+
+
+import Graphics.UI.Gtk hiding (get)
+import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
+import Text.ParserCombinators.Parsec.Language
+import Text.ParserCombinators.Parsec hiding(Parser)
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Data.Maybe
+import Data.Typeable
+import IDE.Core.State hiding (SrcSpan(..))
+import IDE.BufferMode
+import IDE.LogRef (logOutput, defaultLineLogger)
+import IDE.Pane.SourceBuffer
+ (hlintSettings, hlintBuffer, fileSave, goToSourceDefinition',
+ maybeActiveBuf, IDEBuffer(..), replaceHLintSource)
+import IDE.TextEditor (TextEditor(..), grabFocus)
+import Control.Applicative ((<$>))
+import System.FilePath ((), dropFileName)
+import System.Exit (ExitCode(..))
+import IDE.Pane.Log (getLog)
+import Control.Monad (forM, unless, void, forM_, foldM, when)
+import Control.Monad.Trans.Reader (ask)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Language.Haskell.Exts (SrcLoc(..))
+import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
+
+import qualified Language.Haskell.HLint3 as H
+import IDE.Utils.GUIUtils (__, treeViewContextMenu)
+import Data.List (isPrefixOf, findIndex)
+import Debug.Trace (trace)
+import Control.Exception (SomeException, catch)
+import Distribution.ModuleName (ModuleName)
+import IDE.Metainfo.Provider (getWorkspaceInfo)
+import qualified Data.Map as Map (keys, lookup)
+import Distribution.Package (PackageIdentifier(..))
+import Data.Text (Text)
+import qualified Data.Text as T
+ (replicate, unlines, init, lines, pack, unpack)
+import Data.Monoid ((<>))
+import qualified System.IO.Strict as S (readFile)
+import Language.Haskell.HLint3
+ (CppFlags(..), defaultParseFlags, parseFlagsAddFixities,
+ resolveHints, readSettingsFile, findSettings, ParseFlags(..))
+import Language.Preprocessor.Cpphs
+ (runCpphsReturningSymTab, defaultCpphsOptions, CpphsOptions(..))
+import System.Log.Logger (debugM)
+import System.Directory (doesFileExist)
+import qualified System.IO as S (writeFile)
+import System.Glib.GTypeConstants (flags)
+
+data HLintRecord = HLintRecord {
+ condPackage :: Maybe IDEPackage
+ , context :: Text
+ , condIdea :: Maybe H.Idea
+ , parDir :: Maybe FilePath
+ } deriving (Eq)
+
+isDir HLintRecord{parDir = Nothing} = True
+isDir otherwies = False
+
+-- | A HLint pane description
+--
+
+data IDEHLint = IDEHLint {
+ scrolledView :: ScrolledWindow
+, treeView :: TreeView
+, hlintStore :: TreeStore HLintRecord
+} deriving Typeable
+
+data HLintState = HLintState
+ deriving(Eq,Ord,Read,Show,Typeable)
+
+instance Pane IDEHLint IDEM
+ where
+ primPaneName _ = "HLint"
+ getAddedIndex _ = 0
+ getTopWidget = castToWidget . scrolledView
+ paneId b = "*HLint"
+
+instance RecoverablePane IDEHLint HLintState IDEM where
+ saveState p = return (Just HLintState)
+ recoverState pp HLintState = do
+ nb <- getNotebook pp
+ buildPane pp nb builder
+ builder pp nb windows = reifyIDE $ \ ideR -> do
+ hlintStore <- treeStoreNew []
+ treeView <- treeViewNew
+ treeViewSetModel treeView hlintStore
+
+ renderer1 <- cellRendererTextNew
+ renderer10 <- cellRendererPixbufNew
+ col1 <- treeViewColumnNew
+ treeViewColumnSetTitle col1 (__ "Context")
+ treeViewColumnSetSizing col1 TreeViewColumnAutosize
+ treeViewColumnSetResizable col1 True
+ treeViewColumnSetReorderable col1 True
+ treeViewAppendColumn treeView col1
+ cellLayoutPackStart col1 renderer10 False
+ cellLayoutPackStart col1 renderer1 True
+ cellLayoutSetAttributes col1 renderer1 hlintStore
+ $ \row -> [ cellText := context row ]
+
+ treeViewSetHeadersVisible treeView False
+ sel <- treeViewGetSelection treeView
+ treeSelectionSetMode sel SelectionSingle
+
+ scrolledView <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetShadowType scrolledView ShadowIn
+ containerAdd scrolledView treeView
+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
+
+ let hlint = IDEHLint {..}
+ cid1 <- after treeView focusInEvent $ do
+ liftIO $ reflectIDE (makeActive hlint) ideR
+ return True
+ cid2 <- on treeView rowExpanded $ \ iter path -> do
+ record <- treeStoreGetValue hlintStore path
+ case record of
+ HLintRecord { condPackage = Just p, parDir = Nothing } ->
+ reflectIDE (refreshDir hlintStore iter p) ideR
+ _ -> reflectIDE (ideMessage Normal (__ "Unexpected Expansion in HLint Pane")) ideR
+ cid3 <- on treeView rowActivated $ \ path col -> do
+ record <- treeStoreGetValue hlintStore path
+ mbIter <- treeModelGetIter hlintStore path
+ case (mbIter, record) of
+ (Just iter, HLintRecord { condPackage = Just p, parDir = Nothing }) ->
+ reflectIDE (refreshDir hlintStore iter p) ideR
+ _ -> return ()
+ cid4 <- on treeView keyPressEvent $ do
+ name <- eventKeyName
+ liftIO $ case name of
+ "Return" -> reflectIDE (gotoSource True treeView hlintStore) ideR
+ "Escape" -> do
+ reflectIDE (do
+ lastActiveBufferPane ?>>= \paneName -> do
+ (PaneC pane) <- paneFromName paneName
+ makeActive pane
+ return ()
+ triggerEventIDE StartFindInitial) ideR
+ return True
+ -- gotoSource True
+ _ -> return False
+ on sel treeSelectionSelectionChanged (reflectIDE (void $ gotoSource False treeView hlintStore) ideR)
+
+ return (Just hlint,map ConnectC [cid1])
+
+getHLint :: Maybe PanePath -> IDEM IDEHLint
+getHLint Nothing = forceGetPane (Right "*HLint")
+getHLint (Just pp) = forceGetPane (Left pp)
+
+data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound
+
+find :: Eq a => a -> TreeStore a -> Maybe TreeIter -> IO FindResult
+find _ _ Nothing = return NotFound
+find a store (Just iter) = do
+ row <- treeModelGetRow store iter
+ if row == a
+ then return $ WhereExpected iter
+ else treeModelIterNext store iter >>= find'
+ where
+ find' :: Maybe TreeIter -> IO FindResult
+ find' Nothing = return NotFound
+ find' (Just iter) = do
+ row <- treeModelGetRow store iter
+ if row == a
+ then return $ Found iter
+ else treeModelIterNext store iter >>= find'
+
+removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()
+removeUntil a store path = do
+ row <- treeStoreGetValue store path
+ when (row /= a) $ do
+ found <- treeStoreRemove store path
+ when found $ removeUntil a store path
+
+removeRemaining :: TreeStore a -> TreePath -> IO ()
+removeRemaining store path = do
+ found <- treeStoreRemove store path
+ when found $ removeRemaining store path
+
+
+getSelectionHLintRecord :: TreeView
+ -> TreeStore HLintRecord
+ -> IO (Maybe HLintRecord)
+getSelectionHLintRecord treeView hlintStore = do
+ treeSelection <- treeViewGetSelection treeView
+ paths <- treeSelectionGetSelectedRows treeSelection
+ case paths of
+ p:_ -> Just <$> treeStoreGetValue hlintStore p
+ _ -> return Nothing
+
+refreshHLint :: WorkspaceAction
+refreshHLint = do
+ ws <- ask
+ maybeActive <- lift $ readIDE activePack
+ let packages = case maybeActive of
+ Just active -> active : filter (/= active) (wsAllPackages ws)
+ Nothing -> wsAllPackages ws
+ lift $ hlintDirectories2 packages
+
+
+--gotoSource :: Bool -> IDEM Bool
+gotoSource focus treeView hlintStore = do
+ sel <- liftIO $ getSelectionHLintRecord treeView hlintStore
+ case sel of
+ Just record ->
+ case record of
+ HLintRecord {condIdea = Just idea} ->
+ goToSourceDefinition' (srcSpanFilename (H.ideaSpan idea))
+ (Location "" (srcSpanStartLine (H.ideaSpan idea))
+ (srcSpanStartColumn (H.ideaSpan idea))
+ (srcSpanEndLine (H.ideaSpan idea))
+ (srcSpanEndColumn (H.ideaSpan idea)))
+ ?>>= (\buf@IDEBuffer {sourceView = sv} -> do
+ hlintBuffer buf
+ when focus $ grabFocus sv)
+ _ -> return ()
+ Nothing -> return ()
+ return True
+
+
+hlintDirectories2 :: [IDEPackage] -> IDEAction
+hlintDirectories2 packages = do
+ hlint <- getHLint Nothing
+ let store = hlintStore hlint
+ liftIO $ do
+ treeStoreClear store
+ forM_ packages $ \ p -> do
+ nDir <- treeModelIterNChildren store Nothing
+ treeStoreInsert store [] nDir $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
+ treeStoreInsert store [nDir] 0 $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
+
+refreshDir :: TreeStore HLintRecord -> TreeIter -> IDEPackage -> IDEM ()
+refreshDir store iter package = do
+ ideR <- ask
+ (flags, classify, hint) <- hlintSettings package
+ let modules = Map.keys (ipdModules package)
+ paths <- getSourcePaths (ipdPackageId package) modules
+ res <- forM paths $ \ file -> do
+ str <- liftIO $ S.readFile file
+ liftIO . debugM "leksah" $ "refreshDir hlint parsing " <> file
+ do result <- liftIO $ H.parseModuleEx flags file (Just str)
+ case result of
+ Left e -> do ideMessage Normal . T.pack $
+ "can't parse: " <> H.parseErrorContents e <> " location " <>
+ show (H.parseErrorLocation e)
+ return Nothing
+ Right r -> do liftIO . debugM "leksah" $
+ "refreshDir hlint parsed " <> file
+ return $ Just r
+ `catchIDE` (\(e :: SomeException) -> do
+ reflectIDE (ideMessage Normal . T.pack $ show e) ideR
+ return Nothing)
+ liftIO $ debugM "leksah" "refreshDir hlint parse complete"
+ let ideas = H.applyHints classify hint (catMaybes res)
+ liftIO $ setHLint2Results store iter (T.unpack $ packageIdentifierToString (ipdPackageId package)) ideas
+ return ()
+
+
+getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath]
+getSourcePaths packId names = do
+ mbWorkspaceInfo <- getWorkspaceInfo
+ case mbWorkspaceInfo of
+ Nothing -> return []
+ Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names)
+ where
+ sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath
+ sourcePathFromScope (GenScopeC (PackScope l _)) mn =
+ case packId `Map.lookup` l of
+ Just pack ->
+ case filter (\md -> modu (mdModuleId md) == mn)
+ (pdModules pack) of
+ (mod : tl) -> mdMbSourcePath mod
+ [] -> Nothing
+ Nothing -> Nothing
+
+
+hlint2Record dir idea = HLintRecord {
+ condPackage = Nothing,
+ context = T.pack $ show idea,
+ condIdea = Just idea,
+ parDir = Just dir}
+
+setHLint2Results :: TreeStore HLintRecord -> TreeIter -> FilePath -> [H.Idea] -> IO Int
+setHLint2Results store parent dir ideas = do
+ liftIO $ debugM "leksah" "setHLint2Results"
+ parentPath <- treeModelGetPath store parent
+ forM_ (zip [0..] records) $ \(n, record) -> do
+ mbChild <- treeModelIterNthChild store (Just parent) n
+ findResult <- find record store mbChild
+ case (mbChild, findResult) of
+ (_, WhereExpected _) -> return ()
+ (Just iter, Found _) -> do
+ path <- treeModelGetPath store iter
+ removeUntil record store path
+ _ -> treeStoreInsert store parentPath n record
+ liftIO $ debugM "leksah" "setHLint2Results removing remaining records"
+ removeRemaining store (parentPath++[nRecords])
+ return nRecords
+ where
+ records = map (hlint2Record dir) ideas
+ nRecords = length records
+
diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs
--- a/src/IDE/Pane/Info.hs
+++ b/src/IDE/Pane/Info.hs
@@ -39,7 +39,7 @@
import IDE.SymbolNavigation
import IDE.Pane.SourceBuffer
import IDE.TextEditor (newDefaultBuffer, TextEditor(..), EditorView(..))
-import IDE.Utils.GUIUtils (getDarkState, openBrowser, __)
+import IDE.Utils.GUIUtils (openBrowser, __)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Graphics.UI.Gtk
@@ -85,10 +85,7 @@
descriptionBuffer <- newDefaultBuffer Nothing ""
descriptionView <- newView descriptionBuffer (textviewFont prefs)
- preferDark <- getDarkState
- setStyle preferDark descriptionBuffer $ case sourceStyle prefs of
- (False,_) -> Nothing
- (True,v) -> Just v
+ updateStyle descriptionBuffer
sw <- getScrolledWindow descriptionView
@@ -154,14 +151,7 @@
setInfoStyle = getPane >>= setInfoStyle'
where
setInfoStyle' Nothing = return ()
- setInfoStyle' (Just IDEInfo{..}) = do
- prefs <- readIDE prefs
- preferDark <- getDarkState
- buffer <- getBuffer descriptionView
- setStyle preferDark buffer $ case sourceStyle prefs of
- (False,_) -> Nothing
- (True,v) -> Just v
-
+ setInfoStyle' (Just IDEInfo{..}) = getBuffer descriptionView >>= updateStyle
getInfoCont :: IDEM (Maybe Descr)
getInfoCont = do
diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs
--- a/src/IDE/Pane/Log.hs
+++ b/src/IDE/Pane/Log.hs
@@ -408,12 +408,11 @@
(_,y') <- textViewWindowToBufferCoords tv TextWindowWidget (x,y)
(iter,_) <- textViewGetLineAtY tv y'
textIterGetLine iter
- case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))
- (zip logRefs' [0..(length logRefs')]) of
- [(thisRef,n)] -> do
+ case filter (\es -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) logRefs' of
+ [thisRef] -> do
mbBuf <- selectSourceBuf (logRefFullFilePath thisRef)
case mbBuf of
- Just buf -> markRefInSourceBuf n buf thisRef True
+ Just buf -> markRefInSourceBuf buf thisRef True
Nothing -> return ()
log :: IDELog <- getLog
markErrorInLog log (logLines thisRef)
diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs
--- a/src/IDE/Pane/Modules.hs
+++ b/src/IDE/Pane/Modules.hs
@@ -69,7 +69,8 @@
import Graphics.UI.Editor.Simple
(textEditor, boolEditor, staticListEditor)
import Graphics.UI.Editor.Composite (maybeEditor)
-import IDE.Utils.GUIUtils (stockIdFromType, __)
+import IDE.Utils.GUIUtils
+ (stockIdFromType, __, treeViewContextMenu)
import IDE.Metainfo.Provider
(getSystemInfo, getWorkspaceInfo, getPackageInfo)
import System.Log.Logger (debugM)
@@ -79,9 +80,8 @@
import Control.Monad (when, void)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ask)
-import IDE.Utils.GUIUtils (treeViewContextMenu)
import System.Glib.Properties (newAttrFromMaybeStringProperty)
-import Data.Text (Text)
+import Data.Text (Text, toCaseFold)
import qualified Data.Text as T (unpack, isInfixOf, toLower, pack)
import Data.Monoid ((<>))
import qualified Text.Printf as S (printf)
@@ -97,19 +97,20 @@
type ModuleRecord = (Text, Maybe (ModuleDescr,PackageDescr))
data IDEModules = IDEModules {
- outer :: VBox
-, paned :: HPaned
-, treeView :: TreeView
-, treeStore :: TreeStore ModuleRecord
-, descrView :: TreeView
-, descrStore :: TreeStore Descr
-, packageScopeB :: RadioButton
-, workspaceScopeB :: RadioButton
-, systemScopeB :: RadioButton
-, dependsB :: CheckButton
-, blacklistB :: CheckButton
-, oldSelection :: IORef SelectionState
-, expanderState :: IORef ExpanderState
+ outer :: VBox
+, paned :: HPaned
+, treeView :: TreeView
+, treeStore :: TreeStore ModuleRecord
+, descrView :: TreeView
+, descrStore :: TreeStore Descr
+, descrSortedStore :: TypedTreeModelSort Descr -- ^ The sorted model for descrs
+, packageScopeB :: RadioButton
+, workspaceScopeB :: RadioButton
+, systemScopeB :: RadioButton
+, dependsB :: CheckButton
+, blacklistB :: CheckButton
+, oldSelection :: IORef SelectionState
+, expanderState :: IORef ExpanderState
} deriving Typeable
@@ -141,7 +142,7 @@
instance Pane IDEModules IDEM
where
- primPaneName _ = (__ "Modules")
+ primPaneName _ = __ "Modules"
getAddedIndex _ = 0
getTopWidget = castToWidget . outer
paneId b = "*Modules"
@@ -168,7 +169,7 @@
Just p -> liftIO $ do
i <- panedGetPosition (paned p)
mbTreeSelection <- getSelectionTree (treeView m) (treeStore m)
- mbFacetSelection <- getSelectionDescr (descrView m) (descrStore m)
+ mbFacetSelection <- getSelectionDescr (descrView m) (descrStore m) (descrSortedStore m)
let mbs = (case mbTreeSelection of
Just (_,Just (md,_)) -> Just (modu $ mdModuleId md)
otherwise -> Nothing,
@@ -181,7 +182,7 @@
p <- buildPane pp nb builder
mod <- getModules Nothing
liftIO $ writeIORef (expanderState mod) exp
- liftIO $ writeIORef (oldSelection mod) (SelectionState (fst se) (snd se) scope useBlacklist)
+ liftIO $ writeIORef (oldSelection mod) (uncurry SelectionState se scope useBlacklist)
liftIO $ panedSetPosition (paned mod) i
return p
builder pp nb windows = do
@@ -241,7 +242,9 @@
descrView <- treeViewNew
descrStore <- treeStoreNew []
- treeViewSetModel descrView descrStore
+ -- sorted model
+ descrSortedStore <- treeModelSortNewWithModel descrStore
+ treeViewSetModel descrView descrSortedStore
renderer30 <- cellRendererPixbufNew
renderer31 <- cellRendererPixbufNew
renderer3 <- cellRendererTextNew
@@ -267,6 +270,14 @@
then ("ide_source" :: Text)
else "ide_source_local"
else "ide_empty"]
+ -- sort definitions on name, ignoring case
+ treeSortableSetSortFunc descrSortedStore 2 $ \iter1 iter2 -> do
+ d1 <- treeModelGetRow descrStore iter1
+ d2 <- treeModelGetRow descrStore iter2
+ let cafName = toCaseFold . descrTreeText
+ return (compare (cafName d1) (cafName d2))
+ treeViewColumnSetSortColumnId col 2
+ treeSortableSetSortColumnId descrSortedStore 2 SortAscending
treeViewSetHeadersVisible descrView True
treeViewSetEnableSearch descrView True
treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))
@@ -306,7 +317,7 @@
oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing SystemScope False
expanderState <- liftIO $ newIORef emptyExpansion
scopeRef <- newIORef (SystemScope,True)
- let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore
+ let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore descrSortedStore
rb1 rb2 rb3 cb2 cb oldState expanderState
cid1 <- after treeView focusInEvent $ do
liftIO $ reflectIDE (makeActive modules) ideR
@@ -316,8 +327,8 @@
return True
(cid3, cid4) <- treeViewContextMenu treeView $ modulesContextMenu ideR treeStore treeView
cid5 <- treeView `on` rowActivated $ modulesSelect ideR treeStore treeView
- (cid6, cid7) <- treeViewContextMenu descrView $ descrViewContextMenu ideR descrStore descrView
- cid8 <- descrView `on` rowActivated $ descrViewSelect ideR descrStore
+ (cid6, cid7) <- treeViewContextMenu descrView $ descrViewContextMenu ideR descrStore descrSortedStore descrView
+ cid8 <- descrView `on` rowActivated $ descrViewSelect ideR descrStore descrSortedStore
on rb1 toggled (reflectIDE scopeSelection ideR)
on rb2 toggled (reflectIDE scopeSelection ideR)
on rb3 toggled (reflectIDE scopeSelection ideR)
@@ -325,12 +336,12 @@
on cb2 toggled (reflectIDE scopeSelection ideR)
sel <- treeViewGetSelection treeView
on sel treeSelectionSelectionChanged $ do
- fillFacets treeView treeStore descrView descrStore
+ fillFacets treeView treeStore descrView descrStore descrSortedStore
reflectIDE recordSelHistory ideR
return ()
sel2 <- treeViewGetSelection descrView
on sel2 treeSelectionSelectionChanged $ do
- fillInfo descrView descrStore ideR
+ fillInfo descrView descrStore descrSortedStore ideR
reflectIDE recordSelHistory ideR
return ()
return (Just modules,map ConnectC [cid1, cid2, cid3, cid4, cid5, cid6, cid7, cid8])
@@ -368,27 +379,27 @@
pid = pack pm
ps = case packageScope of
Nothing -> (False,False)
- Just (GenScopeC (PackScope psc1 _), GenScopeC (PackScope psc2 _)) ->
- if Map.member pid psc1
- then (True,False)
- else if Map.member pid psc2
- then (True,True)
- else (False, False)
+ Just
+ (GenScopeC (PackScope psc1 _),
+ GenScopeC (PackScope psc2 _)) | Map.member pid psc1 ->
+ (True, False)
+ | Map.member pid psc2 -> (True, True)
+ | otherwise -> (False, False)
ws = case workspaceScope of
Nothing -> (False,False)
- Just (GenScopeC (PackScope wsc1 _), GenScopeC (PackScope wsc2 _)) ->
- if Map.member pid wsc1
- then (True,False)
- else if Map.member pid wsc2
- then (True,True)
- else (False, False)
+ Just
+ (GenScopeC (PackScope wsc1 _),
+ GenScopeC (PackScope wsc2 _)) | Map.member pid wsc1 ->
+ (True, False)
+ | Map.member pid wsc2 -> (True, True)
+ | otherwise -> (False, False)
selectIdentifier' :: ModuleName -> Text -> IDEAction
selectIdentifier' moduleName symbol =
let nameArray = map T.pack $ components moduleName
in do
- liftIO $ debugM "leksah" "selectIdentifier'"
+ liftIO $ debugM "leksah" $ "selectIdentifier' " <> show moduleName <> " " <> T.unpack symbol
mods <- getModules Nothing
mbTree <- liftIO $ treeStoreGetTreeSave (treeStore mods) []
case treePathFromNameArray mbTree nameArray [] of
@@ -402,7 +413,8 @@
selF <- treeViewGetSelection (descrView mods)
case findPathFor symbol mbFacetTree of
Nothing -> sysMessage Normal (__ "no path found")
- Just path -> do
+ Just childPath -> do
+ path <- treeModelSortConvertChildPathToPath (descrSortedStore mods) childPath
treeViewExpandToPath (descrView mods) path
treeSelectionSelectPath selF path
col <- treeViewGetColumn (descrView mods) 0
@@ -413,7 +425,7 @@
findPathFor :: Text -> Maybe (Tree Descr) -> Maybe TreePath
findPathFor symbol (Just (Node _ forest)) =
foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath)
- Nothing [0 .. ((length forest) - 1)]
+ Nothing [0 .. (length forest - 1)]
where
findPathFor' :: TreePath -> Tree Descr -> Maybe TreePath -> Maybe TreePath
findPathFor' _ node (Just p) = Just p
@@ -422,13 +434,13 @@
then Just (reverse path)
else
foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath)
- Nothing [0 .. ((length sub) - 1)]
+ Nothing [0 .. (length sub - 1)]
findPathFor symbol Nothing = Nothing
treePathFromNameArray :: Maybe ModTree -> [Text] -> [Int] -> Maybe [Int]
treePathFromNameArray (Just tree) [] accu = Just (reverse accu)
treePathFromNameArray (Just tree) (h:t) accu =
- let names = map (\t -> fst $ rootLabel t) (subForest tree)
+ let names = map (fst . rootLabel) (subForest tree)
mbIdx = elemIndex h names
in case mbIdx of
Nothing -> Nothing
@@ -446,7 +458,7 @@
val <- treeStoreGetValue treeStore path
mbTree <- treeStoreGetTreeSave treeStore path
exp <- treeViewRowExpanded treeView path
- when (isJust mbTree && (not (null (subForest (fromJust mbTree)))) && not exp) $
+ when (isJust mbTree && not (null (subForest (fromJust mbTree))) && not exp) $
let found = searchInModSubnodes (fromJust mbTree) string
in when found $ do
treeViewExpandRow treeView path False
@@ -459,14 +471,14 @@
searchInModSubnodes :: ModTree -> Text -> Bool
searchInModSubnodes tree str =
- not $ null
- $ filter (\ (_,mbPair) ->
- case mbPair of
- Nothing -> False
- Just (mod,_) ->
- let cstr = T.pack $ show (Present (mdModuleId mod))
- in T.isInfixOf (T.toLower str) (T.toLower cstr))
- $ concatMap flatten (subForest tree)
+ any
+ (\ (_, mbPair) ->
+ case mbPair of
+ Nothing -> False
+ Just (mod, _) -> let cstr
+ = T.pack $ show (Present (mdModuleId mod))
+ in T.isInfixOf (T.toLower str) (T.toLower cstr))
+ (concatMap flatten (subForest tree))
descrViewSearch :: TreeView
-> TreeStore Descr
@@ -488,32 +500,32 @@
searchInFacetSubnodes :: DescrTree -> Text -> Bool
searchInFacetSubnodes tree str =
- not $ null
- $ filter (\ val ->
- T.isInfixOf (T.toLower str) (T.toLower (descrTreeText val)))
- $ concatMap flatten (subForest tree)
+ any
+ (T.isInfixOf (T.toLower str) . T.toLower . descrTreeText)
+ (concatMap flatten (subForest tree))
+-- | Fill facet view with descrs from selected module
fillFacets :: TreeView
-> TreeStore ModuleRecord
-> TreeView
-> TreeStore Descr
+ -> TypedTreeModelSort Descr
-> IO ()
-fillFacets treeView treeStore descrView descrStore = do
+fillFacets treeView treeStore descrView descrStore descrSortedStore = do
liftIO $ debugM "leksah" "fillFacets"
- sel <- getSelectionTree treeView treeStore
+ sel <- getSelectionTree treeView treeStore
+ emptyModel <- treeStoreNew []
+ treeViewSetModel descrView emptyModel
+ treeStoreClear descrStore
case sel of
Just (_,Just (mod,package))
- -> let forest = buildFacetForrest mod in do
- emptyModel <- treeStoreNew []
- treeViewSetModel descrView emptyModel
- treeStoreClear descrStore
- mapM_ (\(e,i) -> treeStoreInsertTree descrStore [] i e)
- $ zip forest [0 .. length forest]
- treeViewSetModel descrView descrStore
- treeViewSetEnableSearch descrView True
- treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))
- otheriwse
- -> treeStoreClear descrStore
+ -> mapM_ (\(e,i) -> treeStoreInsertTree descrStore [] i e)
+ $ zip (buildFacetForrest mod) [0 ..]
+ _ -> return ()
+ treeViewSetModel descrView descrSortedStore
+ treeViewSetEnableSearch descrView True
+ treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))
+ liftIO $ debugM "leksah" "fillFacets done"
getSelectionTree :: TreeView
-> TreeStore ModuleRecord
@@ -528,32 +540,37 @@
val <- treeStoreGetValue treeStore a
return (Just val)
+-- | Get selected Descr, if any
getSelectionDescr :: TreeView
-> TreeStore Descr
+ -> TypedTreeModelSort Descr
-> IO (Maybe Descr)
-getSelectionDescr treeView treeStore = do
+getSelectionDescr treeView treeStore descrSortedStore = do
liftIO $ debugM "leksah" "getSelectionDescr"
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
- a:r -> do
- val <- treeStoreGetValue treeStore a
+ a:_ -> do
+ unsorteda <- treeModelSortConvertPathToChildPath descrSortedStore a
+ val <- treeStoreGetValue treeStore unsorteda
return (Just val)
_ -> return Nothing
-
+-- | Fill info pane with selected Descr if any
fillInfo :: TreeView
-> TreeStore Descr
+ -> TypedTreeModelSort Descr
-> IDERef
-> IO ()
-fillInfo treeView lst ideR = do
+fillInfo treeView lst descrSortedStore ideR = do
liftIO $ debugM "leksah" "fillInfo"
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
[] -> return ()
[a] -> do
- descr <- treeStoreGetValue lst a
+ unsorteda <- treeModelSortConvertPathToChildPath descrSortedStore a
+ descr <- treeStoreGetValue lst unsorteda
reflectIDE (setInfo descr) ideR
return ()
_ -> return ()
@@ -578,9 +595,8 @@
SystemScope -> do
accessibleInfo' <- getSystemInfo
case accessibleInfo' of
- Nothing -> liftIO $ do
- treeStoreClear (treeStore mods)
- --treeStoreInsertTree (treeStore mods) [] 0 (Node ("",[]) [])
+ Nothing -> liftIO $ treeStoreClear (treeStore mods)
+ --treeStoreInsertTree (treeStore mods) [] 0 (Node ("",[]) [])
Just (GenScopeC ai@(PackScope pm ps)) ->
let p2 = if useBlacklist
then PackScope (Map.filter (filterBlacklist
@@ -647,7 +663,7 @@
descrTreeText (Real (RealDescr id _ _ _ _ (InstanceDescr binds) _)) = id <> " " <> printBinds binds
where
printBinds [] = ""
- printBinds (a:[]) = a
+ printBinds [a] = a
printBinds (a:b) = a <> " " <> printBinds b
descrTreeText d = dscName d
@@ -672,38 +688,55 @@
buildFacet descr =
case dscTypeHint descr of
DataDescr constructors fields ->
- Node descr ((map (\(SimpleDescr fn ty loc comm exp) ->
- Node (makeReexported descr (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
- dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
- dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})) [])
- constructors)
- ++ (map (\(SimpleDescr fn ty loc comm exp) ->
- Node (makeReexported descr (Real $
- RealDescr{dscName' = fn, dscMbTypeStr' = ty,
- dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
- dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})) [])
- fields))
+ Node descr (map
+ (\ (SimpleDescr fn ty loc comm exp) ->
+ Node
+ (makeReexported descr
+ (Real
+ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
+ dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr,
+ dscExported' = exp}))
+ [])
+ constructors
+ ++
+ map
+ (\ (SimpleDescr fn ty loc comm exp) ->
+ Node
+ (makeReexported descr
+ (Real
+ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
+ dscMbComment' = comm, dscTypeHint' = FieldDescr descr,
+ dscExported' = exp}))
+ [])
+ fields)
NewtypeDescr (SimpleDescr fn ty loc comm exp) mbField ->
- Node descr (Node (makeReexported descr (Real $
- RealDescr{dscName' = fn, dscMbTypeStr' = ty,
- dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
- dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})) []
+ Node descr (Node (makeReexported descr (Real
+ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
+ dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr,
+ dscExported' = exp})) []
: case mbField of
Just (SimpleDescr fn ty loc comm exp) ->
- [Node (makeReexported descr (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
- dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
- dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})) []]
+ [Node (makeReexported descr (Real
+ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
+ dscMbComment' = comm, dscTypeHint' = FieldDescr descr,
+ dscExported' = exp})) []]
Nothing -> [])
ClassDescr _ methods ->
Node descr (map (\(SimpleDescr fn ty loc comm exp) ->
- Node (makeReexported descr (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
- dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
- dscMbComment' = comm, dscTypeHint' = MethodDescr descr, dscExported' = exp})) [])
+ Node (makeReexported descr (Real
+ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ dscMbModu' = dsMbModu descr, dscMbLocation' = loc,
+ dscMbComment' = comm, dscTypeHint' = MethodDescr descr,
+ dscExported' = exp})) [])
methods)
_ -> Node descr []
where
makeReexported :: Descr -> Descr -> Descr
- makeReexported (Reexported d1) d2 = Reexported $ ReexportedDescr{dsrMbModu = dsrMbModu d1, dsrDescr = d2}
+ makeReexported (Reexported d1) d2 = Reexported ReexportedDescr{dsrMbModu = dsrMbModu d1, dsrDescr = d2}
makeReexported _ d2 = d2
addInstances :: (DescrForest,[Descr])
@@ -721,17 +754,17 @@
matches (Real (instDescr@RealDescr{dscTypeHint' = InstanceDescr binds}))
(Node dd@(Real (RealDescr id _ _ _ _ (DataDescr _ _) _)) sub) (forest,False)
| not (null binds) && id == head binds
- = ((Node dd (sub ++ [Node newInstDescr []])):forest,True)
+ = (Node dd (sub ++ [Node newInstDescr []]) : forest,True)
where newInstDescr = if isNothing (dscMbLocation' instDescr)
then Real $ instDescr{dscMbLocation' = dscMbLocation dd}
- else Real $ instDescr
+ else Real instDescr
matches (Real (instDescr@RealDescr{dscTypeHint' = InstanceDescr binds}))
(Node dd@(Real (RealDescr id _ _ _ _ (NewtypeDescr _ _) _)) sub) (forest,False)
| not (null binds) && id == head binds
- = ((Node dd (sub ++ [Node newInstDescr []])):forest,True)
+ = (Node dd (sub ++ [Node newInstDescr []]) : forest,True)
where newInstDescr = if isNothing (dscMbLocation' instDescr)
then Real $ instDescr{dscMbLocation' = dscMbLocation dd}
- else Real $ instDescr
+ else Real instDescr
matches _ node (forest,b) = (node:forest,b)
@@ -754,7 +787,7 @@
insertPairsInTree tree pair =
let nameArray = map T.pack . components . modu . mdModuleId $ fst pair
(startArray,last) = splitAt (length nameArray - 1) nameArray
- pairedWith = (map (\n -> (n,Nothing)) startArray) ++ [(head last,Just pair)]
+ pairedWith = map (\ n -> (n, Nothing)) startArray ++ [(head last, Just pair)]
in insertNodesInTree pairedWith tree
@@ -834,25 +867,24 @@
case mbFile of
Nothing -> return ()
Just fp -> do
- resp <- reflectIDE (respDelModDialog)ideR
- if (resp == False) then return ()
- else do
+ resp <- reflectIDE respDelModDialog ideR
+ when resp $ do
exists <- doesFileExist fp
if exists
then do
reflectIDE (liftIO $ removeFile fp) ideR
reflectIDE (packageTry $ delModule treeView store)ideR
- else do
+ else
reflectIDE (packageTry $ delModule treeView store)ideR
reflectIDE (packageTry packageConfig) ideR
return ()
sel <- getSelectionTree treeView store
case sel of
- Just (s, Nothing) -> do
+ Just (s, Nothing) ->
mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,
castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,
castToMenuItem item6]
- Just (_,Just (m,_)) -> do
+ Just (_,Just (m,_)) ->
mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,
castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,
castToMenuItem item6, castToMenuItem item7]
@@ -870,37 +902,42 @@
mbFile <- getSelectedModuleFile <$> getSelectionTree treeView store
case mbFile of
Nothing -> return ()
- Just fp -> liftIO $ reflectIDE (selectSourceBuf fp) ideR >> return ()
+ Just fp -> liftIO $ void (reflectIDE (selectSourceBuf fp) ideR)
+-- | Build contextual menu on selected Descr
descrViewContextMenu :: IDERef
-> TreeStore Descr
+ -> TypedTreeModelSort Descr
-> TreeView
-> Menu
-> IO ()
-descrViewContextMenu ideR store descrView theMenu = do
+descrViewContextMenu ideR store descrSortedStore descrView theMenu = do
liftIO $ debugM "leksah" "descrViewContextMenu"
item1 <- menuItemNewWithLabel (__ "Go to definition")
item1 `on` menuItemActivate $ do
- sel <- getSelectionDescr descrView store
+ sel <- getSelectionDescr descrView store descrSortedStore
case sel of
Just descr -> reflectIDE (goToDefinition descr) ideR
otherwise -> sysMessage Normal (__ "Modules>> descrViewPopup: no selection")
item2 <- menuItemNewWithLabel (__ "Insert in buffer")
item2 `on` menuItemActivate $ do
- sel <- getSelectionDescr descrView store
+ sel <- getSelectionDescr descrView store descrSortedStore
case sel of
Just descr -> reflectIDE (insertInBuffer descr) ideR
otherwise -> sysMessage Normal (__ "Modules>> descrViewPopup: no selection")
mapM_ (menuShellAppend theMenu) [item1, item2]
+-- | Selects the Descr referenced by the path
descrViewSelect :: IDERef
-> TreeStore Descr
+ -> TypedTreeModelSort Descr
-> TreePath
-> TreeViewColumn
-> IO ()
-descrViewSelect ideR store path _ = do
+descrViewSelect ideR store descrSortedStore path _ = do
liftIO $ debugM "leksah" "descrViewSelect"
- descr <- treeStoreGetValue store path
+ unsortedp <- treeModelSortConvertPathToChildPath descrSortedStore path
+ descr <- treeStoreGetValue store unsortedp
reflectIDE (goToDefinition descr) ideR
setScope :: (Scope,Bool) -> IDEAction
@@ -939,11 +976,10 @@
rb3s <- liftIO $ toggleButtonGetActive (systemScopeB mods)
cb1s <- liftIO $ toggleButtonGetActive (dependsB mods)
cbs <- liftIO $ toggleButtonGetActive (blacklistB mods)
- let scope = if rb1s
- then PackageScope cb1s
- else if rb2s
- then WorkspaceScope cb1s
- else SystemScope
+ let scope
+ | rb1s = PackageScope cb1s
+ | rb2s = WorkspaceScope cb1s
+ | otherwise = SystemScope
return (scope,cbs)
scopeSelection :: IDEAction
@@ -959,7 +995,7 @@
recordExpanderState
mods <- getModules Nothing
mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods)
- mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods)
+ mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) (descrSortedStore mods)
ts <- liftIO $ treeViewGetSelection (treeView mods)
withoutRecordingDo $ do
@@ -1009,7 +1045,8 @@
selF <- treeViewGetSelection (descrView mods)
case findPathFor symbol mbDescrTree of
Nothing -> sysMessage Normal (__ "no path found")
- Just path -> do
+ Just childPath -> do
+ path <- treeModelSortConvertChildPathToPath (descrSortedStore mods) childPath
treeSelectionSelectPath selF path
col <- treeViewGetColumn (descrView mods) 0
treeViewScrollToCell (descrView mods) (Just path) col
@@ -1017,7 +1054,7 @@
reloadKeepSelection :: Bool -> IDEAction
reloadKeepSelection isInitial = do
- liftIO . debugM "leksah" $ (T.unpack $ __ ">>>Info Changed!!! ") ++ show isInitial
+ liftIO . debugM "leksah" $ T.unpack (__ ">>>Info Changed!!! ") ++ show isInitial
mbMod <- getPane
case mbMod of
Nothing -> return ()
@@ -1026,7 +1063,7 @@
if not $ isStartingOrClosing state
then do
mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods)
- mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods)
+ mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) (descrSortedStore mods)
sc <- getScope
recordExpanderState
fillModulesList sc
@@ -1040,14 +1077,12 @@
applyExpanderState
selectNames mbs
- else if isInitial == True
- then do
+ else when isInitial $ do
SelectionState moduleS' facetS' sc bl <- liftIO $ readIORef (oldSelection mods)
setScope (sc,bl)
fillModulesList (sc, bl)
selectNames (moduleS', facetS')
applyExpanderState
- else return ()
treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a))
treeStoreGetTreeSave treeStore treePath = catch (do
@@ -1062,7 +1097,7 @@
paths <- treeSelectionGetSelectedRows sel
case paths of
[] -> return ()
- (hd:_) -> treeViewExpandRow treeView hd True >> return ()
+ (hd:_) -> void (treeViewExpandRow treeView hd True)
collapseHere :: TreeView -> IO ()
collapseHere treeView = do
@@ -1071,18 +1106,18 @@
paths <- treeSelectionGetSelectedRows sel
case paths of
[] -> return ()
- (hd:_) -> treeViewCollapseRow treeView hd >> return ()
+ (hd:_) -> void (treeViewCollapseRow treeView hd)
delModule :: TreeView -> TreeStore ModuleRecord -> PackageAction
delModule treeview store = do
liftIO $ debugM "leksah" "delModule"
- window <- liftIDE $ getMainWindow
+ window <- liftIDE getMainWindow
sel <- liftIO $ treeViewGetSelection treeview
paths <- liftIO $ treeSelectionGetSelectedRows sel
categories <- case paths of
[] -> return []
- (treePath:_) -> liftIO $ mapM (treeStoreGetValue store)
- $ map (\n -> take n treePath) [1 .. length treePath]
+ (treePath:_) -> liftIO $ mapM (treeStoreGetValue store . (`take` treePath))
+ [1 .. length treePath]
liftIDE $ ideMessage Normal (T.pack $ printf (__ "categories: %s") (show categories))
@@ -1094,7 +1129,7 @@
liftIDE $ ideMessage Normal ("modName: " <> T.pack (show modName))
delModuleFromPackageDescr modName
-respDelModDialog :: IDEM (Bool)
+respDelModDialog :: IDEM Bool
respDelModDialog = do
liftIO $ debugM "leksah" "respDelModDialog"
window <- getMainWindow
@@ -1115,8 +1150,8 @@
paths <- liftIO $ treeSelectionGetSelectedRows sel
categories <- case paths of
[] -> return []
- (treePath:_) -> liftIO $ mapM (treeStoreGetValue store)
- $ map (\n -> take n treePath) [1 .. length treePath]
+ (treePath:_) -> liftIO $ mapM (treeStoreGetValue store . (`take` treePath))
+ [1 .. length treePath]
addModule categories
-- Includes non buildable
@@ -1129,13 +1164,12 @@
addModule :: [ModuleRecord] -> PackageAction
addModule categories = do
liftIO $ debugM "leksah" "selectIdentifier"
- mbPD <- liftIDE $ getPackageDescriptionAndPath
+ mbPD <- liftIDE getPackageDescriptionAndPath
case mbPD of
Nothing -> liftIDE $ ideMessage Normal (__ "No package description")
Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo' pd
rootPath = dropFileName cabalPath
- modPath = foldr (\a b -> a <> "." <> b) ""
- (map fst categories)
+ modPath = foldr ((\ a b -> a <> "." <> b) . fst) "" categories
in do
window' <- liftIDE getMainWindow
mbResp <- liftIO $ addModuleDialog window' modPath srcPaths (hasLibs pd) $
@@ -1185,7 +1219,7 @@
liftIO $ debugM "leksah" "addModuleDialog"
dia <- dialogNew
set dia [ windowTransientFor := parent
- , windowTitle := (__ "Construct new module") ]
+ , windowTitle := __ "Construct new module" ]
windowSetDefaultSize dia 400 100
#ifdef MIN_VERSION_gtk3
upper <- dialogGetContentArea dia
@@ -1239,31 +1273,32 @@
moduleFields :: [FilePath] -> Bool -> [Text] -> FieldDescription AddModule
moduleFields list hasLibs exesTests = VFD emptyParams $ [
mkField
- (paraName <<<- ParaName ((__ "New module "))
+ (paraName <<<- ParaName (__ "New module ")
$ emptyParams)
moduleName
(\ a b -> b{moduleName = a})
(textEditor (const True) True),
mkField
- (paraName <<<- ParaName ((__ "Root of the source path"))
+ (paraName <<<- ParaName (__ "Root of the source path")
$ paraMultiSel <<<- ParaMultiSel False
$ paraMinSize <<<- ParaMinSize (-1, 120)
$ emptyParams)
- (\a -> T.pack $ sourceRoot a)
+ (T.pack . sourceRoot)
(\ a b -> b{sourceRoot = T.unpack a})
(staticListEditor (map T.pack list) id)]
- ++ (if hasLibs
- then [
- mkField
- (paraName <<<- ParaName ((__ "Library should"))
- $ emptyParams)
- libExposed
- (\ a b -> b{libExposed = a})
- (maybeEditor (boolEditor, paraName <<<- ParaName ((__ "Expose module")) $ emptyParams) True (__ "Include module"))]
- else [])
+ ++ [mkField
+ (paraName <<<- ParaName (__ "Library should") $ emptyParams)
+ libExposed
+ (\ a b -> b{libExposed = a})
+ (maybeEditor
+ (boolEditor,
+ paraName <<<- ParaName (__ "Expose module") $ emptyParams)
+ True
+ (__ "Include module"))
+ | hasLibs]
++ map (\ name ->
mkField
- (paraName <<<- ParaName ((__ "Include in ") <> name)
+ (paraName <<<- ParaName (__ "Include in " <> name)
$ emptyParams)
(Set.member name . exesAndTests)
(\ a b -> b{exesAndTests = (if a then Set.insert else Set.delete) name (exesAndTests b)})
@@ -1284,15 +1319,15 @@
paths2 <- getExpandedRows (descrView m) (descrStore m)
modifyIORef (expanderState m) (\ es ->
case (sc,bl) of
- ((PackageScope False),True) -> es{packageExp = (paths1,paths2)}
- ((PackageScope False),False) -> es{packageExpNoBlack = (paths1,paths2)}
- (PackageScope True,True) -> es{packageDExp = (paths1,paths2)}
- (PackageScope True,False) -> es{packageDExpNoBlack = (paths1,paths2)}
+ (PackageScope False, True) -> es{packageExp = (paths1,paths2)}
+ (PackageScope False, False) -> es{packageExpNoBlack = (paths1,paths2)}
+ (PackageScope True, True) -> es{packageDExp = (paths1,paths2)}
+ (PackageScope True, False) -> es{packageDExpNoBlack = (paths1,paths2)}
- ((WorkspaceScope False),True) -> es{workspaceExp = (paths1,paths2)}
- ((WorkspaceScope False),False) -> es{workspaceExpNoBlack = (paths1,paths2)}
- (WorkspaceScope True,True) -> es{workspaceDExp = (paths1,paths2)}
- (WorkspaceScope True,False) -> es{workspaceDExpNoBlack = (paths1,paths2)}
+ (WorkspaceScope False, True) -> es{workspaceExp = (paths1,paths2)}
+ (WorkspaceScope False, False) -> es{workspaceExpNoBlack = (paths1,paths2)}
+ (WorkspaceScope True,True) -> es{workspaceDExp = (paths1,paths2)}
+ (WorkspaceScope True,False) -> es{workspaceDExpNoBlack = (paths1,paths2)}
(SystemScope,True) -> es{systemExp = (paths1,paths2)}
(SystemScope,False) -> es{systemExpNoBlack = (paths1,paths2)})
@@ -1333,18 +1368,18 @@
liftIO $ do
es <- readIORef (expanderState m)
let (paths1,paths2) = case (sc,bl) of
- ((PackageScope False),True) -> packageExp es
- ((PackageScope False),False) -> packageExpNoBlack es
- (PackageScope True,True) -> packageDExp es
- (PackageScope True,False) -> packageDExpNoBlack es
- ((WorkspaceScope False),True) -> workspaceExp es
- ((WorkspaceScope False),False) -> workspaceExpNoBlack es
- (WorkspaceScope True,True) -> workspaceDExp es
- (WorkspaceScope True,False) -> workspaceDExpNoBlack es
- (SystemScope,True) -> systemExp es
- (SystemScope,False) -> systemExpNoBlack es
- mapM_ (\p -> treeViewExpandToPath (treeView m) p) paths1
- mapM_ (\p -> treeViewExpandToPath (descrView m) p) paths2
+ (PackageScope False, True) -> packageExp es
+ (PackageScope False, False) -> packageExpNoBlack es
+ (PackageScope True,True) -> packageDExp es
+ (PackageScope True,False) -> packageDExpNoBlack es
+ (WorkspaceScope False, True) -> workspaceExp es
+ (WorkspaceScope False, False) -> workspaceExpNoBlack es
+ (WorkspaceScope True,True) -> workspaceDExp es
+ (WorkspaceScope True,False) -> workspaceDExpNoBlack es
+ (SystemScope,True) -> systemExp es
+ (SystemScope,False) -> systemExpNoBlack es
+ mapM_ (treeViewExpandToPath (treeView m)) paths1
+ mapM_ (treeViewExpandToPath (descrView m)) paths2
-- * GUI History
@@ -1354,7 +1389,7 @@
mods <- getModules Nothing
ideR <- ask
selTree <- liftIO $ getSelectionTree (treeView mods) (treeStore mods)
- selDescr <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods)
+ selDescr <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) (descrSortedStore mods)
let selMod = case selTree of
Just (_,Just (md,_)) -> Just (modu $ mdModuleId md)
otherwise -> Nothing
@@ -1362,8 +1397,8 @@
Nothing -> Nothing
Just descr -> Just (dscName descr)
oldSel <- liftIO $ readIORef (oldSelection mods)
- triggerEventIDE (RecordHistory ((ModuleSelected selMod selFacet),
- (ModuleSelected (moduleS' oldSel) (facetS' oldSel))))
+ triggerEventIDE (RecordHistory (ModuleSelected selMod selFacet,
+ ModuleSelected (moduleS' oldSel) (facetS' oldSel)))
liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= selMod, facetS' = selFacet})
return ()
@@ -1383,8 +1418,8 @@
ideR <- ask
mods <- getModules Nothing
oldSel <- liftIO $ readIORef (oldSelection mods)
- triggerEventIDE (RecordHistory ((ScopeSelected sc bl),
- (ScopeSelected (scope' oldSel) (blacklist' oldSel))))
+ triggerEventIDE (RecordHistory (ScopeSelected sc bl,
+ ScopeSelected (scope' oldSel) (blacklist' oldSel)))
liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl})
return ()
@@ -1394,9 +1429,9 @@
mods <- getModules Nothing
liftIO $ do
toggleButtonSetActive (blacklistB mods) bl
- toggleButtonSetActive (packageScopeB mods) (sc == (PackageScope False))
+ toggleButtonSetActive (packageScopeB mods) (sc == PackageScope False)
toggleButtonSetActive (workspaceScopeB mods) (sc == PackageScope True)
- toggleButtonSetActive (systemScopeB mods) (sc == SystemScope)
+ toggleButtonSetActive (systemScopeB mods) (sc == SystemScope)
setScope (sc,bl)
oldSel <- liftIO $ readIORef (oldSelection mods)
liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl})
diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs
--- a/src/IDE/Pane/PackageEditor.hs
+++ b/src/IDE/Pane/PackageEditor.hs
@@ -78,8 +78,7 @@
(Notifier, Editor(..), GUIEventSelector(..), GUIEvent(..))
import Distribution.Compiler
(CompilerFlavor(..))
-import Distribution.Simple (knownExtensions)
-import Distribution.Simple (Extension(..), VersionRange, anyVersion)
+import Distribution.Simple (knownExtensions, Extension(..), VersionRange, anyVersion)
import Default (Default(..))
import IDE.Utils.GUIUtils
import IDE.Pane.SourceBuffer (fileOpenThis)
@@ -91,7 +90,7 @@
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
-import Control.Monad (when)
+import Control.Monad (void, when)
import Distribution.PackageDescription.PrettyPrint
(writeGenericPackageDescription)
import Distribution.Version (Version(..), orLaterVersion)
@@ -167,10 +166,12 @@
--
choosePackageDir :: Window -> Maybe FilePath -> IO (Maybe FilePath)
-choosePackageDir window mbDir = chooseDir window (__ "Select root folder for package") mbDir
+choosePackageDir window
+ = chooseDir window (__ "Select root folder for package")
choosePackageFile :: Window -> Maybe FilePath -> IO (Maybe FilePath)
-choosePackageFile window mbDir = chooseFile window (__ "Select cabal package file (.cabal)") mbDir
+choosePackageFile window
+ = chooseFile window (__ "Select cabal package file (.cabal)")
packageEdit :: PackageAction
packageEdit = do
@@ -208,27 +209,23 @@
Nothing -> False
Just condTree -> not (null (condTreeComponents condTree))
exeConds = foldr (\ (_,condTree) hasConfigs ->
- if hasConfigs
- then True
- else not (null (condTreeComponents condTree)))
+ (hasConfigs || not (null (condTreeComponents condTree))))
False (condExecutables gpd)
testConds = foldr (\ (_,condTree) hasConfigs ->
- if hasConfigs
- then True
- else not (null (condTreeComponents condTree)))
+ (hasConfigs || not (null (condTreeComponents condTree))))
False (condTestSuites gpd)
in libConds || exeConds || testConds
hasUnknownTestTypes :: PackageDescription -> Bool
hasUnknownTestTypes pd =
- not . null . filter unknown $ testSuites pd
+ any unknown $ testSuites pd
where
unknown (TestSuite _ (TestSuiteExeV10 _ _) _ _) = False
unknown _ = True
hasUnknownBenchmarkTypes :: PackageDescription -> Bool
hasUnknownBenchmarkTypes pd =
- not . null . filter unknown $ benchmarks pd
+ any unknown $ benchmarks pd
where
unknown (Benchmark _ (BenchmarkExeV10 _ _) _ _) = False
unknown _ = True
@@ -241,20 +238,20 @@
packageFields :: FilePath -> FieldDescription NewPackage
packageFields workspaceDir = VFD emptyParams [
mkField
- (paraName <<<- ParaName ((__ "New package name"))
+ (paraName <<<- ParaName (__ "New package name")
$ emptyParams)
newPackageName
(\ a b -> b{newPackageName = a})
(textEditor (const True) True),
mkField
- (paraName <<<- ParaName ((__ "Parent directory"))
+ (paraName <<<- ParaName (__ "Parent directory")
$ paraMinSize <<<- ParaMinSize (-1, 120)
$ emptyParams)
- (\a -> newPackageParentDir a)
+ newPackageParentDir
(\ a b -> b{newPackageParentDir = a})
(fileEditor (Just workspaceDir) FileChooserActionSelectFolder "Select"),
mkField
- (paraName <<<- ParaName ((__ "Copy existing package"))
+ (paraName <<<- ParaName (__ "Copy existing package")
$ emptyParams)
templatePackage
(\ a b -> b{templatePackage = a})
@@ -269,7 +266,7 @@
newPackageDialog parent workspaceDir = do
dia <- dialogNew
set dia [ windowTransientFor := parent
- , windowTitle := (__ "Create New Package") ]
+ , windowTitle := __ "Create New Package" ]
#ifdef MIN_VERSION_gtk3
upper <- dialogGetContentArea dia
#else
@@ -298,7 +295,7 @@
mbNewPackage <- liftIO $ newPackageDialog (head windows) workspaceDir
case mbNewPackage of
Nothing -> return ()
- Just NewPackage{..} | templatePackage == Nothing -> do
+ Just NewPackage{..} | isNothing templatePackage -> do
let dirName = newPackageParentDir T.unpack newPackageName
mbCabalFile <- liftIO $ cabalFileName dirName
window <- getMainWindow
@@ -350,7 +347,7 @@
, defaultLanguage = Just Haskell2010}}]
, testSuites = [emptyTestSuite {
testName = "test-" ++ T.unpack newPackageName
- , testInterface = (TestSuiteExeV10 (Version [1,0] []) "Main.hs")
+ , testInterface = TestSuiteExeV10 (Version [1,0] []) "Main.hs"
, testBuildInfo = emptyBuildInfo {
hsSourceDirs = ["test"]
, targetBuildDepends = [
@@ -377,16 +374,16 @@
cloneFields :: [PackageId] -> FilePath -> FieldDescription ClonePackageSourceRepo
cloneFields packages workspaceDir = VFD emptyParams [
mkField
- (paraName <<<- ParaName ((__ "Existing package to clone source repository"))
+ (paraName <<<- ParaName (__ "Existing package to clone source repository")
$ emptyParams)
packageToClone
(\ a b -> b{packageToClone = a})
(comboEntryEditor ((sort . nub) (map (T.pack . display . pkgName) packages))),
mkField
- (paraName <<<- ParaName ((__ "Parent directory"))
+ (paraName <<<- ParaName (__ "Parent directory")
$ paraMinSize <<<- ParaMinSize (-1, 120)
$ emptyParams)
- (\a -> cloneParentDir a)
+ cloneParentDir
(\ a b -> b{cloneParentDir = a})
(fileEditor (Just workspaceDir) FileChooserActionSelectFolder "Select")]
@@ -395,7 +392,7 @@
packages <- getInstalledPackageIds
dia <- dialogNew
set dia [ windowTransientFor := parent
- , windowTitle := (__ "Clone Package") ]
+ , windowTitle := __ "Clone Package" ]
#ifdef MIN_VERSION_gtk3
upper <- dialogGetContentArea dia
#else
@@ -434,7 +431,7 @@
when oldDirExists $ removeDirectoryRecursive tempDir
createDirectory tempDir
runExternalTool' (__ "Unpacking") "cabal" (["unpack"]
- ++ (if sourceRepo then ["--source-repository"] else [])
+ ++ ["--source-repository" | sourceRepo]
++ ["--destdir=" <> T.pack tempDir, packageToUnpack]) tempDir $ do
mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink log
case mbLastOutput of
@@ -445,17 +442,17 @@
liftIO $ removeDirectoryRecursive tempDir
lift $ ideMessage High $ "Nothing found in " <> T.pack tempDir <> " after doing a cabal unpack."
[repoName] -> do
- let destDir = parentDir (fromMaybe repoName $ T.unpack <$> mbNewName)
+ let destDir = parentDir fromMaybe repoName (T.unpack <$> mbNewName)
exists <- liftIO $ (||) <$> doesDirectoryExist destDir <*> doesFileExist destDir
if exists
then lift $ ideMessage High $ T.pack destDir <> " already exists"
else do
liftIO $ renameDirectory (tempDir repoName) destDir
mbCabalFile <- liftIO $ cabalFileName destDir
- window <- lift $ getMainWindow
+ window <- lift getMainWindow
lift $ case (mbCabalFile, mbNewName) of
(Just cfn, Just newName) -> do
- let newCfn = takeDirectory cfn (T.unpack newName) ++ ".cabal"
+ let newCfn = takeDirectory cfn T.unpack newName ++ ".cabal"
when (cfn /= newCfn) . liftIO $ do
s <- T.readFile cfn
T.writeFile newCfn $ renameCabalFile (T.pack $ takeBaseName cfn) newName s
@@ -480,7 +477,7 @@
prefixesWithLength = zip prefixes $ map T.length prefixes
renameLine :: Text -> Text
renameLine line =
- case catMaybes $ map (rename (line, T.toLower line)) prefixesWithLength of
+ case mapMaybe (rename (line, T.toLower line)) prefixesWithLength of
l:_ -> l
[] -> line
rename :: (Text, Text) -> (Text, Int) -> Maybe Text
@@ -545,11 +542,11 @@
toEditor :: PackageDescription -> PackageDescriptionEd
toEditor pd =
- let (exes,exeBis) = unzip $ map (\((Executable s fb bi), i) -> ((Executable' (T.pack s) fb i), bi))
+ let (exes,exeBis) = unzip $ map (\(Executable s fb bi, i) -> (Executable' (T.pack s) fb i, bi))
(zip (executables pd) [0..])
- (tests,testBis) = unzip $ map (\((TestSuite s fb bi _), i) -> ((Test' (T.pack s) fb i), bi))
+ (tests,testBis) = unzip $ map (\(TestSuite s fb bi _, i) -> (Test' (T.pack s) fb i, bi))
(zip (testSuites pd) [length exeBis..])
- (bms,benchmarkBis) = unzip $ map (\((Benchmark s fb bi _), i) -> ((Benchmark' (T.pack s) fb i), bi))
+ (bms,benchmarkBis) = unzip $ map (\(Benchmark s fb bi _, i) -> (Benchmark' (T.pack s) fb i, bi))
(zip (benchmarks pd) [length testBis..])
bis = exeBis ++ testBis ++ benchmarkBis
(mbLib,bis2) = case library pd of
@@ -584,7 +581,7 @@
instance Pane PackagePane IDEM
where
- primPaneName _ = (__ "Package")
+ primPaneName _ = __ "Package"
getAddedIndex _ = 0
getTopWidget = castToWidget . packageBox
paneId b = "*Package"
@@ -602,7 +599,7 @@
Nothing -> do
pp <- getBestPathForId "*Package"
nb <- getNotebook pp
- packageInfos <- liftIO $ getInstalledPackageIds
+ packageInfos <- liftIO getInstalledPackageIds
let packageEd = toEditor packageD
initPackage packagePath packageEd
(packageDD
@@ -627,17 +624,15 @@
initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction origPackageD = do
let fields = flattenFieldDescription packageDescr
let initialPackagePath = packageDir (display . pkgName . package . pd) packageD ++ ".cabal"
- packageInfos <- liftIO $ getInstalledPackageIds
+ packageInfos <- liftIO getInstalledPackageIds
mbP <- buildThisPane panePath nb
(builder' packageDir packageD packageDescr afterSaveAction
initialPackagePath modules packageInfos fields origPackageD)
case mbP of
Nothing -> return ()
Just (PackagePane{packageNotifer = pn}) -> do
- liftIO $ triggerEvent pn (GUIEvent {
- selector = MayHaveChanged,
- eventText = "",
- gtkReturn = True})
+ liftIO $ triggerEvent pn GUIEvent{selector = MayHaveChanged, eventText = "",
+ gtkReturn = True}
return ()
builder' :: FilePath ->
@@ -673,18 +668,16 @@
boxPackStart vb label PackNatural 0
boxPackEnd vb bb PackNatural 7
- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of
- Just s -> s
- Nothing -> (__ "Unnamed")) fields
+ let fieldNames = map (fromMaybe (__ "Unnamed") . getParameterPrim paraName . parameters) fields
on addB buttonActivated $ do
mbNewPackage' <- extract packageD [getExt]
case mbNewPackage' of
Nothing -> sysMessage Normal (__ "Content doesn't validate")
Just pde -> reflectIDE (do
closePane packagePane
- initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]}
+ initPackage packageDir pde {bis = bis pde ++ [head (bis pde)]}
(packageDD
- (packageInfos)
+ packageInfos
packageDir
modules
(length (bis pde) + 1)
@@ -713,7 +706,7 @@
Nothing -> False
Just p -> p /= origPackageD
if not hasChanged
- then reflectIDE (closePane packagePane >> return ()) ideR
+ then reflectIDE (void (closePane packagePane)) ideR
else do
md <- messageDialogNew (Just window) []
MessageQuestion
@@ -723,8 +716,7 @@
resp <- dialogRun md
widgetDestroy md
case resp of
- ResponseYes -> do
- reflectIDE (closePane packagePane >> return ()) ideR
+ ResponseYes -> reflectIDE (void (closePane packagePane)) ideR
_ -> return ()
on save buttonActivated $ do
mbNewPackage' <- extract packageD [getExt]
@@ -765,7 +757,7 @@
-> [(Text, FieldDescription PackageDescriptionEd)]
-> FieldDescription PackageDescriptionEd
packageDD packages fp modules numBuildInfos extras = NFD ([
- ((__ "Package"), VFD emptyParams [
+ (__ "Package", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Synopsis")
$ paraSynopsis <<<- ParaSynopsis (__ "A one-line summary of this package")
@@ -803,7 +795,7 @@
(\ a b -> b{pd = (pd b){category = a}})
(stringEditor (const True) True)
]),
- ((__ "Description"), VFD emptyParams [
+ (__ "Description", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Stability") $ emptyParams)
(stability . pd)
@@ -859,7 +851,7 @@
-- (sourceRepos . pd)
-- (\ a b -> b{pd = (pd b){sourceRepos = a}})
-- reposEditor]),
- ((__ "Dependencies "), VFD emptyParams [
+ (__ "Dependencies ", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Build Dependencies")
$ paraSynopsis <<<- ParaSynopsis (__ "Does this package depends on other packages?")
@@ -870,7 +862,7 @@
(\ a b -> b{pd = (pd b){buildDepends = a}})
(dependenciesEditor packages)
]),
- ((__ "Meta Dep."), VFD emptyParams [
+ (__ "Meta Dep.", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Cabal version")
$ paraSynopsis <<<- ParaSynopsis
@@ -891,7 +883,7 @@
(\ a b -> b{pd = (pd b){testedWith = a}})
testedWithEditor
]),
- ((__ "Data Files"), VFD emptyParams [
+ (__ "Data Files", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Data Files")
$ paraSynopsis <<<- ParaSynopsis
@@ -908,7 +900,7 @@
(\ a b -> b{pd = (pd b){dataDir = a}})
(fileEditor (Just fp) FileChooserActionSelectFolder (__ "Select file"))
]),
- ((__ "Extra Files"), VFD emptyParams [
+ (__ "Extra Files", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Extra Source Files")
$ paraSynopsis <<<- ParaSynopsis
@@ -930,7 +922,7 @@
(\ a b -> b{pd = (pd b){extraTmpFiles = a}})
(filesEditor (Just fp) FileChooserActionOpen (__ "Select File"))
]),
- ((__ "Other"),VFD emptyParams [
+ (__ "Other",VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Build Type")
$ paraSynopsis <<<- ParaSynopsis
@@ -949,15 +941,15 @@
(customFieldsPD . pd)
(\ a b -> b{pd = (pd b){customFieldsPD = a}})
(multisetEditor
- (ColumnDescr True [((__ "Name"),\(n,_) -> [cellText := T.pack n])
- ,((__ "Value"),\(_,v) -> [cellText := T.pack v])])
- ((pairEditor
- (stringxEditor (const True),emptyParams)
- (stringEditor (const True) True,emptyParams)),emptyParams)
+ (ColumnDescr True [(__ "Name",\(n,_) -> [cellText := T.pack n])
+ ,(__ "Value",\(_,v) -> [cellText := T.pack v])])
+ (pairEditor (stringxEditor (const True), emptyParams)
+ (stringEditor (const True) True, emptyParams),
+ emptyParams)
Nothing
Nothing)
]),
- ((__ "Executables"),VFD emptyParams [
+ (__ "Executables",VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Executables")
$ paraSynopsis <<<- ParaSynopsis
@@ -967,7 +959,7 @@
(\ a b -> b{exes = a})
(executablesEditor (Just fp) modules numBuildInfos)
]),
- ((__ "Tests"),VFD emptyParams [
+ (__ "Tests",VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Tests")
$ paraSynopsis <<<- ParaSynopsis
@@ -977,7 +969,7 @@
(\ a b -> b{tests = a})
(testsEditor (Just fp) modules numBuildInfos)
]),
- ((__ "Benchmarks"),VFD emptyParams [
+ (__ "Benchmarks",VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Benchmarks")
$ paraSynopsis <<<- ParaSynopsis
@@ -987,7 +979,7 @@
(\ a b -> b{bms = a})
(benchmarksEditor (Just fp) modules numBuildInfos)
]),
- ((__ "Library"), VFD emptyParams [
+ (__ "Library", VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Library")
$ paraSynopsis <<<- ParaSynopsis
@@ -1012,10 +1004,10 @@
buildInfoD :: Maybe FilePath -> [ModuleName] -> Int -> [(Text,FieldDescription PackageDescriptionEd)]
buildInfoD fp modules i = [
- ((T.pack $ printf (__ "%s Build Info") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Build Info") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Component is buildable here") $ emptyParams)
- (buildable . (\a -> a !! i) . bis)
+ (buildable . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{buildable = a})})
boolEditor
, mkField
@@ -1027,7 +1019,7 @@
$ paraDirection <<<- ParaDirection Vertical
$ paraMinSize <<<- ParaMinSize (-1,150)
$ emptyParams)
- (hsSourceDirs . (\a -> a !! i) . bis)
+ (hsSourceDirs . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{hsSourceDirs = a})})
(filesEditor fp FileChooserActionSelectFolder (__ "Select folder"))
, mkField
@@ -1039,59 +1031,59 @@
$ paraMinSize <<<- ParaMinSize (-1,300)
$ paraPack <<<- ParaPack PackGrow
$ emptyParams)
- (map (T.pack . display) . otherModules . (\a -> a !! i) . bis)
+ (map (T.pack . display) . otherModules . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi ->
- bi{otherModules = (map (\i -> forceJust (simpleParse $ T.unpack i)
- " PackageEditor >> buildInfoD: no parse for moduile name" ) a)})})
+ bi{otherModules = map (\i -> forceJust (simpleParse $ T.unpack i)
+ " PackageEditor >> buildInfoD: no parse for moduile name" ) a})})
(modulesEditor modules)
]),
- ((T.pack $ printf (__ "%s Compiler ") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Compiler ") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Options for haskell compilers")
$ paraDirection <<<- ParaDirection Vertical
$ paraShadow <<<- ParaShadow ShadowIn
$ paraPack <<<- ParaPack PackGrow $ emptyParams)
- (options . (\a -> a !! i) . bis)
+ (options . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{options = a})})
(multisetEditor
- (ColumnDescr True [( (__ "Compiler Flavor"),\(cv,_) -> [cellText := T.pack $ show cv])
- ,( (__ "Options"),\(_,op) -> [cellText := T.pack $ concatMap (\s -> ' ' : s) op])])
- ((pairEditor
+ (ColumnDescr True [( __ "Compiler Flavor",\(cv,_) -> [cellText := T.pack $ show cv])
+ ,(__ "Options",\(_,op) -> [cellText := T.pack $ concatMap (\s -> ' ' : s) op])])
+ (pairEditor
(compilerFlavorEditor,emptyParams)
- (optsEditor,emptyParams)),
- (paraDirection <<<- ParaDirection Vertical
- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams))
+ (optsEditor,emptyParams),
+ paraDirection <<<- ParaDirection Vertical
+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)
Nothing
Nothing)
#if MIN_VERSION_Cabal(1,22,0)
, mkField
(paraName <<<- ParaName (__ "Additional options for GHC when built with profiling")
$ emptyParams)
- (profOptions . (\a -> a !! i) . bis)
+ (profOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{profOptions = a})})
compilerOptsEditor
, mkField
(paraName <<<- ParaName (__ "Additional options for GHC when the package is built as shared library")
$ emptyParams)
- (sharedOptions . (\a -> a !! i) . bis)
+ (sharedOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{sharedOptions = a})})
compilerOptsEditor
#else
, mkField
(paraName <<<- ParaName (__ "Additional options for GHC when built with profiling")
$ emptyParams)
- (ghcProfOptions . (\a -> a !! i) . bis)
+ (ghcProfOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcProfOptions = a})})
optsEditor
, mkField
(paraName <<<- ParaName (__ "Additional options for GHC when the package is built as shared library")
$ emptyParams)
- (ghcSharedOptions . (\a -> a !! i) . bis)
+ (ghcSharedOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcSharedOptions = a})})
optsEditor
#endif
]),
- ((T.pack $ printf (__ "%s Extensions ") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Extensions ") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Extensions")
$ paraSynopsis <<<- ParaSynopsis
@@ -1099,65 +1091,65 @@
$ paraMinSize <<<- ParaMinSize (-1,400)
$ paraPack <<<- ParaPack PackGrow
$ emptyParams)
- (oldExtensions . (\a -> a !! i) . bis)
+ (oldExtensions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{oldExtensions = a})})
extensionsEditor
]),
- ((T.pack $ printf (__ "%s Build Tools ") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Build Tools ") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Tools needed for a build")
$ paraDirection <<<- ParaDirection Vertical
$ paraMinSize <<<- ParaMinSize (-1,120)
$ emptyParams)
- (buildTools . (\a -> a !! i) . bis)
+ (buildTools . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{buildTools = a})})
(dependenciesEditor [])
]),
- ((T.pack $ printf (__ "%s Pkg Config ") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Pkg Config ") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "A list of pkg-config packages, needed to build this package")
$ paraDirection <<<- ParaDirection Vertical
$ paraMinSize <<<- ParaMinSize (-1,120)
$ emptyParams)
- (pkgconfigDepends . (\a -> a !! i) . bis)
+ (pkgconfigDepends . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{pkgconfigDepends = a})})
(dependenciesEditor [])
]),
- ((T.pack $ printf (__ "%s Opts C -1-") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Opts C -1-") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Options for C compiler")
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
- (ccOptions . (\a -> a !! i) . bis)
+ (ccOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{ccOptions = a})})
optsEditor
, mkField
(paraName <<<- ParaName (__ "Options for linker")
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
- (ldOptions . (\a -> a !! i) . bis)
+ (ldOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{ldOptions = a})})
optsEditor
, mkField
(paraName <<<- ParaName (__ "A list of header files to use when compiling")
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (map T.pack . includes . (\a -> a !! i) . bis)
+ (map T.pack . includes . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = map T.unpack a})})
(textsEditor (const True) True)
, mkField
(paraName <<<- ParaName (__ "A list of header files to install")
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (installIncludes . (\a -> a !! i) . bis)
+ (installIncludes . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{installIncludes = a})})
(filesEditor fp FileChooserActionOpen (__ "Select File"))
]),
- ((T.pack $ printf (__ "%s Opts C -2-") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Opts C -2-") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "A list of directories to search for header files")
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (includeDirs . (\a -> a !! i) . bis)
+ (includeDirs . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{includeDirs = a})})
(filesEditor fp FileChooserActionSelectFolder (__ "Select Folder"))
, mkField
@@ -1165,39 +1157,39 @@
(__ "A list of C source files to be compiled,linked with the Haskell files.")
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (cSources . (\a -> a !! i) . bis)
+ (cSources . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})})
(filesEditor fp FileChooserActionOpen (__ "Select file"))
]),
- ((T.pack $ printf (__ "%s Opts Libs ") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Opts Libs ") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "A list of extra libraries to link with")
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (map T.pack . extraLibs . (\a -> a !! i) . bis)
+ (map T.pack . extraLibs . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibs = map T.unpack a})})
(textsEditor (const True) True)
, mkField
(paraName <<<- ParaName (__ "A list of directories to search for libraries.")
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (extraLibDirs . (\a -> a !! i) . bis)
+ (extraLibDirs . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibDirs = a})})
(filesEditor fp FileChooserActionSelectFolder (__ "Select Folder"))
]),
- ((T.pack $ printf (__ "%s Other") (show (i + 1))), VFD emptyParams [
+ (T.pack $ printf (__ "%s Other") (show (i + 1)), VFD emptyParams [
mkField
(paraName <<<- ParaName (__ "Options for C preprocessor")
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
- (cppOptions . (\a -> a !! i) . bis)
+ (cppOptions . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{cppOptions = a})})
optsEditor
, mkField
(paraName <<<- ParaName (__ "Support frameworks for Mac OS X")
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (map T.pack . frameworks . (\a -> a !! i) . bis)
+ (map T.pack . frameworks . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{frameworks = map T.unpack a})})
(textsEditor (const True) True)
, mkField
@@ -1205,14 +1197,14 @@
$ paraShadow <<<- ParaShadow ShadowIn
$ paraMinSize <<<- ParaMinSize (-1,150)
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
- (customFieldsBI . (\a -> a !! i) . bis)
+ (customFieldsBI . (!! i) . bis)
(\ a b -> b{bis = update (bis b) i (\bi -> bi{customFieldsBI = a})})
(multisetEditor
- (ColumnDescr True [((__ "Name"),\(n,_) -> [cellText := T.pack n])
- ,((__ "Value"),\(_,v) -> [cellText := T.pack v])])
- ((pairEditor
+ (ColumnDescr True [(__ "Name",\(n,_) -> [cellText := T.pack n])
+ ,(__ "Value",\(_,v) -> [cellText := T.pack v])])
+ (pairEditor
(stringxEditor (const True),emptyParams)
- (stringEditor (const True) True,emptyParams)),emptyParams)
+ (stringEditor (const True) True,emptyParams),emptyParams)
Nothing
Nothing)
])]
@@ -1244,16 +1236,15 @@
return (wid,oinj,oext)
compilerOptRecordEditor :: Editor (CompilerFlavor, [String])
-compilerOptRecordEditor para noti = do
+compilerOptRecordEditor para =
pairEditor
(compilerFlavorEditor
, paraName <<<- ParaName "Compiler" $ emptyParams)
(optsEditor,paraName <<<- ParaName "Options" $ emptyParams)
(paraDirection <<<- ParaDirection Vertical $ para)
- noti
compilerOptsEditor :: Editor [(CompilerFlavor, [String])]
-compilerOptsEditor p noti =
+compilerOptsEditor p =
multisetEditor
(ColumnDescr True [("Compiler",\(compiler, _) -> [cellText := T.pack $ show compiler])
,("Options",\(_, opts ) -> [cellText := T.pack $ unwords opts])])
@@ -1269,12 +1260,11 @@
$ paraDirection <<<- ParaDirection Vertical
$ paraPack <<<- ParaPack PackGrow
$ p)
- noti
packageEditor :: Editor PackageIdentifier
packageEditor para noti = do
(wid,inj,ext) <- pairEditor
- (stringEditor (\s -> not (null s)) True, paraName <<<- ParaName (__ "Name") $ emptyParams)
+ (stringEditor (not . null) True, paraName <<<- ParaName (__ "Name") $ emptyParams)
(versionEditor, paraName <<<- ParaName (__ "Version") $ emptyParams)
(paraDirection <<<- ParaDirection Horizontal
$ paraShadow <<<- ParaShadow ShadowIn
@@ -1284,30 +1274,31 @@
mbp <- ext
case mbp of
Nothing -> return Nothing
- Just (n,v) -> do
+ Just (n,v) -> return $
if null n
- then return Nothing
- else return (Just $PackageIdentifier (PackageName n) v)
+ then Nothing
+ else Just $ PackageIdentifier (PackageName n) v
return (wid,pinj,pext)
testedWithEditor :: Editor [(CompilerFlavor, VersionRange)]
-testedWithEditor para = do
+testedWithEditor =
multisetEditor
- (ColumnDescr True [((__ "Compiler Flavor"),\(cv,_) -> [cellText := T.pack $ show cv])
- ,((__ "Version Range"),\(_,vr) -> [cellText := T.pack $ display vr])])
+ (ColumnDescr True [(__ "Compiler Flavor",\(cv,_) -> [cellText := T.pack $ show cv])
+ ,(__ "Version Range",\(_,vr) -> [cellText := T.pack $ display vr])])
(pairEditor
- (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams)
- (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams),
- (paraDirection <<<- (ParaDirection Vertical) $ emptyParams))
+ (compilerFlavorEditor,
+ paraShadow <<<- ParaShadow ShadowNone $ emptyParams)
+ (versionRangeEditor,
+ paraShadow <<<- ParaShadow ShadowNone $ emptyParams),
+ paraDirection <<<- ParaDirection Vertical $ emptyParams)
Nothing
(Just (==))
- para
compilerFlavorEditor :: Editor CompilerFlavor
compilerFlavorEditor para noti = do
(wid,inj,ext) <- eitherOrEditor
- (comboSelectionEditor flavors (T.pack . show), paraName <<<- (ParaName (__ "Select compiler")) $ emptyParams)
- (textEditor (\s -> not (T.null s)) True, paraName <<<- (ParaName (__ "Specify compiler")) $ emptyParams)
+ (comboSelectionEditor flavors (T.pack . show), paraName <<<- ParaName (__ "Select compiler") $ emptyParams)
+ (textEditor (not . T.null) True, paraName <<<- ParaName (__ "Specify compiler") $ emptyParams)
(__ "Other")
(paraName <<<- ParaName (__ "Select") $ para)
noti
@@ -1327,8 +1318,8 @@
buildTypeEditor :: Editor BuildType
buildTypeEditor para noti = do
(wid,inj,ext) <- eitherOrEditor
- (comboSelectionEditor flavors (T.pack . show), paraName <<<- (ParaName (__ "Select")) $ emptyParams)
- (textEditor (const True) True, paraName <<<- (ParaName (__ "Unknown")) $ emptyParams)
+ (comboSelectionEditor flavors (T.pack . show), paraName <<<- ParaName (__ "Select") $ emptyParams)
+ (textEditor (const True) True, paraName <<<- ParaName (__ "Unknown") $ emptyParams)
(__ "Unknown")
(paraName <<<- ParaName (__ "Select") $ para)
noti
@@ -1511,8 +1502,8 @@
(buildInfoEditorP numBuildInfos, paraName <<<- ParaName (__ "Build Info")
$ paraPack <<<- ParaPack PackNatural
$ para),
- (paraDirection <<<- ParaDirection Vertical
- $ emptyParams))
+ paraDirection <<<- ParaDirection Vertical
+ $ emptyParams)
(tupel3Editor
(modulesEditor (sort modules),
paraName <<<- ParaName (__ "Reexported Modules")
@@ -1526,8 +1517,8 @@
paraName <<<- ParaName (__ "Exposed Signatures")
$ paraMinSize <<<- ParaMinSize (-1,300)
$ para),
- (paraDirection <<<- ParaDirection Vertical
- $ emptyParams))
+ paraDirection <<<- ParaDirection Vertical
+ $ emptyParams)
(paraDirection <<<- ParaDirection Vertical
$ emptyParams)
noti
@@ -1581,10 +1572,9 @@
executablesEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Executable']
executablesEditor fp modules countBuildInfo p =
multisetEditor
- (ColumnDescr True [( (__ "Executable Name"),\(Executable' exeName _ _) -> [cellText := exeName])
- ,( (__ "Module Path"),\(Executable' _ mp _) -> [cellText := T.pack mp])
-
- ,( (__ "Build info index"),\(Executable' _ _ bii) -> [cellText := T.pack $ show (bii + 1)])])
+ (ColumnDescr True [(__ "Executable Name",\(Executable' exeName _ _) -> [cellText := exeName])
+ ,(__ "Module Path",\(Executable' _ mp _) -> [cellText := T.pack mp])
+ ,(__ "Build info index",\(Executable' _ _ bii) -> [cellText := T.pack $ show (bii + 1)])])
(executableEditor fp modules countBuildInfo,emptyParams)
Nothing
Nothing
@@ -1594,10 +1584,10 @@
executableEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Executable'
executableEditor fp modules countBuildInfo para noti = do
(wid,inj,ext) <- tupel3Editor
- (textEditor (\s -> not (T.null s)) True,
+ (textEditor (not . T.null) True,
paraName <<<- ParaName (__ "Executable Name")
$ emptyParams)
- (stringEditor (\s -> not (null s)) True,
+ (stringEditor (not . null) True,
paraDirection <<<- ParaDirection Vertical
$ paraName <<<- ParaName (__ "File with main function")
$ emptyParams)
@@ -1620,9 +1610,9 @@
testsEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Test']
testsEditor fp modules countBuildInfo p =
multisetEditor
- (ColumnDescr True [( (__ "Test Name"),\(Test' testName _ _) -> [cellText := testName])
- ,( (__ "Interface"),\(Test' _ i _) -> [cellText := T.pack $ interfaceName i])
- ,( (__ "Build info index"),\(Test' _ _ bii) -> [cellText := T.pack $ show (bii + 1)])])
+ (ColumnDescr True [(__ "Test Name",\(Test' testName _ _) -> [cellText := testName])
+ ,(__ "Interface",\(Test' _ i _) -> [cellText := T.pack $ interfaceName i])
+ ,(__ "Build info index",\(Test' _ _ bii) -> [cellText := T.pack $ show (bii + 1)])])
(testEditor fp modules countBuildInfo,emptyParams)
Nothing
Nothing
@@ -1635,10 +1625,10 @@
testEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Test'
testEditor fp modules countBuildInfo para noti = do
(wid,inj,ext) <- tupel3Editor
- (textEditor (\s -> not (T.null s)) True,
+ (textEditor (not . T.null) True,
paraName <<<- ParaName (__ "Test Name")
$ emptyParams)
- (stringEditor (\s -> not (null s)) True,
+ (stringEditor (not . null) True,
paraDirection <<<- ParaDirection Vertical
$ paraName <<<- ParaName (__ "File with main function")
$ emptyParams)
@@ -1662,9 +1652,9 @@
benchmarksEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Benchmark']
benchmarksEditor fp modules countBuildInfo p =
multisetEditor
- (ColumnDescr True [( (__ "Benchmark Name"),\(Benchmark' benchmarkName _ _) -> [cellText := benchmarkName])
- ,( (__ "Interface"),\(Benchmark' _ i _) -> [cellText := T.pack $ interfaceName i])
- ,( (__ "Build info index"),\(Benchmark' _ _ bii) -> [cellText := T.pack $ show (bii + 1)])])
+ (ColumnDescr True [(__ "Benchmark Name",\(Benchmark' benchmarkName _ _) -> [cellText := benchmarkName])
+ ,(__ "Interface",\(Benchmark' _ i _) -> [cellText := T.pack $ interfaceName i])
+ ,(__ "Build info index",\(Benchmark' _ _ bii) -> [cellText := T.pack $ show (bii + 1)])])
(benchmarkEditor fp modules countBuildInfo,emptyParams)
Nothing
Nothing
@@ -1677,10 +1667,10 @@
benchmarkEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Benchmark'
benchmarkEditor fp modules countBuildInfo para noti = do
(wid,inj,ext) <- tupel3Editor
- (textEditor (\s -> not (T.null s)) True,
+ (textEditor (not . T.null) True,
paraName <<<- ParaName (__ "Benchmark Name")
$ emptyParams)
- (stringEditor (\s -> not (null s)) True,
+ (stringEditor (not . null) True,
paraDirection <<<- ParaDirection Vertical
$ paraName <<<- ParaName (__ "File with main function")
$ emptyParams)
diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs
--- a/src/IDE/Pane/Preferences.hs
+++ b/src/IDE/Pane/Preferences.hs
@@ -71,14 +71,14 @@
import Control.Exception(SomeException,catch)
import Prelude hiding(catch)
import Data.List (isSuffixOf, sortBy)
-import Data.Maybe (catMaybes, fromMaybe, isJust)
+import Data.Maybe (mapMaybe, catMaybes, fromMaybe, isJust)
import Graphics.UI.Gtk.Windows.MessageDialog
(ButtonsType(..), MessageType(..))
import System.Glib.Attributes (set)
import Graphics.UI.Gtk.General.Enums
(ButtonBoxStyle(..), WindowPosition(..))
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad (void, forM_, when)
+import Control.Monad (void, when)
import System.FilePath (())
import Data.Text (Text)
import qualified Data.Text as T (isSuffixOf, unpack, pack, null)
@@ -86,6 +86,7 @@
import Control.Applicative ((<$>))
import Distribution.Text (display, simpleParse)
import IDE.Pane.Files (refreshFiles)
+import Data.Foldable (forM_)
-- ---------------------------------------------------------------------
-- This needs to be incremented, when the preferences format changes
@@ -150,9 +151,7 @@
on preview buttonActivated $ do
mbNewPrefs <- extract initialPrefs [ext]
- case mbNewPrefs of
- Nothing -> return ()
- Just newPrefs -> applyPrefs newPrefs
+ forM_ mbNewPrefs applyPrefs
on restore buttonActivated $ do
applyPrefs initialPrefs
@@ -361,12 +360,7 @@
(\mbs -> do
setInfoStyle
buffers <- allBuffers
- preferDark <- getDarkState
- mapM_ (\(IDEBuffer {sourceView = sv}) -> do
- ebuf <- getBuffer sv
- setStyle preferDark ebuf (case mbs of
- (False,_) -> Nothing
- (True,s) -> Just s)) buffers)
+ mapM_ updateStyle' buffers)
, mkFieldPP
(paraName <<<- ParaName (__ "Found Text Background") $ emptyParams)
(PP.text . show)
@@ -477,7 +471,7 @@
showHiddenFiles
(\b a -> a {showHiddenFiles = b})
boolEditor
- (\b -> refreshFiles)
+ (const refreshFiles)
, mkFieldPP
(paraName <<<- ParaName (__ "Use ctrl Tab for Notebook flipper") $ emptyParams)
(PP.text . show)
@@ -634,7 +628,7 @@
$ paraMinSize <<<- ParaMinSize (-1,200)
$ emptyParams)
(PP.text . show . map display)
- (fmap (catMaybes . map simpleParse) readParser)
+ (fmap (mapMaybe simpleParse) readParser)
packageBlacklist
(\b a -> a{packageBlacklist = b})
(dependenciesEditor packages)
diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs
--- a/src/IDE/Pane/Search.hs
+++ b/src/IDE/Pane/Search.hs
@@ -67,7 +67,9 @@
import Control.Monad (void)
import Graphics.UI.Gtk.General.Enums (ShadowType(..))
import Data.Text (Text)
-import qualified Data.Text as T (pack, null)
+import qualified Data.Text as T (unpack, pack, null)
+import System.Log.Logger (debugM)
+import Data.Monoid ((<>))
-- | A search pane description
--
@@ -251,6 +253,7 @@
searchMetaGUI_ text
searchMetaGUI_ :: Text -> IDEAction
searchMetaGUI_ str = do
+ liftIO $ debugM "leksah" $ "searchMetGUI_ " <> T.unpack str
liftIO $ bringPaneToFront search
liftIO $ entrySetText entry str
scope <- liftIO $ getScope search
diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs
--- a/src/IDE/Pane/SourceBuffer.hs
+++ b/src/IDE/Pane/SourceBuffer.hs
@@ -65,6 +65,13 @@
, editKeystrokeCandy
, editCandy
+, updateStyle
+, updateStyle'
+, addLogRef
+, removeBuildLogRefs
+, resolveActiveHLint
+, hlintSettings
+, hlintBuffer
, markRefInSourceBuf
, inBufContext
, inActiveBufContext
@@ -122,8 +129,6 @@
import Graphics.UI.Gtk.Windows.MessageDialog
(ButtonsType(..), MessageType(..))
import Graphics.UI.Gtk.Windows.Dialog (ResponseId(..))
-import Graphics.UI.Gtk
- (eventModifier, eventKeyName, eventKeyVal, Underline(..))
import Graphics.UI.Gtk.Selectors.FileChooser
(FileChooserAction(..))
import System.Glib.Attributes (AttrOp(..), set)
@@ -131,7 +136,7 @@
import IDE.BufferMode
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad (forM, filterM, unless, when, liftM)
+import Control.Monad (filterM, foldM, void, unless, when, liftM)
import Control.Exception as E (catch, SomeException)
import qualified IDE.Command.Print as Print
@@ -139,11 +144,26 @@
import System.Log.Logger (debugM)
import Data.Text (Text)
import qualified Data.Text as T
- (length, findIndex, replicate, lines, dropWhileEnd, unlines, strip,
- null, pack, unpack)
+ (reverse, take, drop, init, 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 Control.Concurrent (forkIO)
+import Language.Haskell.HLint3
+ (Hint(..), Classify(..), ParseError(..), Idea(..), Severity(..),
+ parseFlagsAddFixities, resolveHints, readSettingsFile,
+ findSettings, applyHints, defaultParseFlags, parseModuleEx,
+ ParseFlags(..), CppFlags(..))
+import qualified Language.Haskell.Exts.SrcLoc as HSE
+ (SrcLoc(..), SrcSpan(..))
+import Language.Preprocessor.Cpphs as Cpphs
+ (runCpphsReturningSymTab, defaultCpphsOptions, CpphsOptions(..))
+import qualified System.IO.Strict as S (readFile)
+import Graphics.UI.Gtk.Gdk.EventM
+ (eventModifier, eventKeyName, eventKeyVal)
+import Data.Foldable (forM_)
+import Data.Traversable (forM)
allBuffers :: MonadIDE m => m [IDEBuffer]
allBuffers = liftIDE getPanes
@@ -245,7 +265,7 @@
liftIO $ debugM "lekash" "selectSourceBuf newTextBuffer returned"
return nbuf
else do
- ideMessage Normal ((__ "File path not found ") <> T.pack fpc)
+ ideMessage Normal (__ "File path not found " <> T.pack fpc)
return Nothing
goToDefinition :: Descr -> IDEAction
@@ -260,15 +280,15 @@
liftIO . debugM "leksah" $ show (mbPackagePath, dscMbLocation idDescr, mbSourcePath)
case (mbPackagePath, dscMbLocation idDescr, mbSourcePath) of
- (Just packagePath, Just loc, _) -> goToSourceDefinition (dropFileName packagePath) loc >> return ()
- (_, Just loc, Just sourcePath) -> goToSourceDefinition' sourcePath loc >> return ()
- (_, _, Just sp) -> selectSourceBuf sp >> return ()
+ (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 mod -> case pack mod `Map.lookup` l of
Just pack -> pdMbSourcePath pack
Nothing -> Nothing
Nothing -> Nothing
@@ -276,7 +296,7 @@
sourcePathFromScope :: GenScope -> Maybe FilePath
sourcePathFromScope (GenScopeC (PackScope l _)) =
case dscMbModu idDescr of
- Just mod -> case (pack mod) `Map.lookup` l of
+ Just mod -> case pack mod `Map.lookup` l of
Just pack ->
case filter (\md -> mdModuleId md == fromJust (dscMbModu idDescr))
(pdModules pack) of
@@ -286,14 +306,14 @@
Nothing -> Nothing
goToSourceDefinition :: FilePath -> Location -> IDEM (Maybe IDEBuffer)
-goToSourceDefinition packagePath loc = do
+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 -> do
+ Just buf ->
inActiveBufContext () $ \_ sv ebuf _ _ -> do
liftIO $ debugM "lekash" "goToSourceDefinition calculating range"
lines <- getLineCount ebuf
@@ -316,29 +336,46 @@
Nothing -> return ()
return mbBuf
-replaceHLintSource :: FilePath -> Int -> Int -> Int -> Int -> Text -> IDEAction
-replaceHLintSource file lineS columnS lineE columnE to = do
- mbBuf <- selectSourceBuf file
+indentHLintText :: Int -> Text -> Text
+indentHLintText startColumn text =
+ T.init $ T.unlines (take 1 lines <> drop 1 (map (indent <>) lines))
+ where
+ lines = T.lines text
+ indent = T.replicate startColumn " "
+
+replaceHLintSource :: (Bool, Int) -> (Text, Idea) -> IDEM (Bool, Int)
+replaceHLintSource (changed, delta) (from, Idea{ideaSpan = ideaSpan, ideaTo = Just ideaTo}) = do
+ let HSE.SrcSpan{..} = ideaSpan
+ to = indentHLintText (srcSpanStartColumn-1) (T.pack ideaTo)
+ liftIO . debugM "leksah" $ "replaceHLintSource From: " <> show from <> "\nreplaceHLintSource To: " <> show to
+ mbBuf <- selectSourceBuf srcSpanFilename
case mbBuf of
- Just buf -> inActiveBufContext () $ \_ sv ebuf _ _ -> do
- useCandy <- useCandyFor buf
- candy' <- readIDE candy
- realString <- if useCandy then stringToCandy candy' to else return to
+ Just buf -> inActiveBufContext (changed, delta) $ \_ sv ebuf _ _ -> do
+ useCandy <- useCandyFor buf
+ candy' <- readIDE candy
+ realString <- if useCandy then stringToCandy candy' to else return to
(lineS', columnS', lineE', columnE') <- if useCandy
then do
- (_,e1) <- positionToCandy candy' ebuf (lineS,columnS - 1)
- (_,e2) <- positionToCandy candy' ebuf (lineE,columnE - 1)
- return (lineS-1,e1,lineE-1,e2)
- else return (lineS-1, columnS-1, lineE-1, columnE-1)
- i1 <- getIterAtLine ebuf (lineS')
- i1' <- forwardCharsC i1 (columnS')
- i2 <- getIterAtLine ebuf (lineE')
- i2' <- forwardCharsC i2 (columnE')
- delete ebuf i1' i2'
- editInsertCode ebuf i1' realString
- fileSave False
- setModified ebuf True
- _ -> return ()
+ (_,e1) <- positionToCandy candy' ebuf (srcSpanStartLine + delta, srcSpanStartColumn - 1)
+ (_,e2) <- positionToCandy candy' ebuf (srcSpanEndLine + delta, srcSpanEndColumn - 1)
+ return (srcSpanStartLine-1 + delta,e1,srcSpanEndLine-1 + delta,e2)
+ else return (srcSpanStartLine-1 + delta,srcSpanStartColumn-1,srcSpanEndLine-1 + delta,srcSpanEndColumn-1)
+ i1 <- getIterAtLine ebuf lineS'
+ i1' <- forwardCharsC i1 columnS'
+ i2 <- getIterAtLine ebuf lineE'
+ i2' <- forwardCharsC i2 columnE'
+ candy <- readIDE candy
+ check <- getCandylessPart candy ebuf i1' i2'
+ if check == from
+ then do
+ beginUserAction ebuf
+ delete ebuf i1' i2'
+ editInsertCode ebuf i1' realString
+ endUserAction ebuf
+ return (True, delta + length (T.lines to) - length (T.lines from))
+ else return (changed, delta)
+ _ -> return (changed, delta)
+replaceHLintSource x _ = return x
insertInBuffer :: Descr -> IDEAction
insertInBuffer idDescr = do
@@ -356,31 +393,49 @@
iter <- getIterAtMark ebuf mark
insert ebuf iter (dscName idDescr)
-markRefInSourceBuf :: Int -> IDEBuffer -> LogRef -> Bool -> IDEAction
-markRefInSourceBuf index buf logRef scrollTo = do
+updateStyle' :: IDEBuffer -> IDEAction
+updateStyle' IDEBuffer {sourceView = sv} = getBuffer sv >>= updateStyle
+
+removeLogRefs :: [LogRefType] -> FilePath -> FilePath -> IDEAction
+removeLogRefs types root file = do
+ modifyIDE_ (\ide -> ide{allLogRefs = filter keep $ allLogRefs ide})
+
+ buffers <- allBuffers
+ let matchingBufs = filter (maybe False (equalFilePath (root file)) . fileName) buffers
+ forM_ matchingBufs $ \ (IDEBuffer {sourceView = sv}) -> do
+ buf <- getBuffer sv
+ forM_ types $ removeTagByName buf . T.pack . show
+
+ triggerEventIDE ErrorChanged
+ return ()
+ where
+ keep ref = logRefRootPath ref /= root
+ || logRefFilePath ref /= file
+ || logRefType ref `notElem` types
+
+removeBuildLogRefs :: FilePath -> FilePath -> IDEAction
+removeBuildLogRefs = removeLogRefs [ErrorRef, WarningRef, TestFailureRef]
+
+addLogRef :: LogRef -> IDEAction
+addLogRef ref = do
+ modifyIDE_ (\ide -> ide{allLogRefs = allLogRefs ide <> [ref]})
+
+ buffers <- allBuffers
+ let matchingBufs = filter (maybe False (equalFilePath (logRefFullFilePath ref)) . fileName) buffers
+ forM_ matchingBufs $ \ buf -> markRefInSourceBuf buf ref False
+
+ triggerEventIDE ErrorChanged
+ 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) ++ show index
+ let tagName = T.pack $ show (logRefType logRef)
liftIO . debugM "lekash" . T.unpack $ "markRefInSourceBuf getting or creating tag " <> tagName
- tagTable <- getTagTable ebuf
- mbTag <- lookupTag tagTable tagName
- case mbTag of
- Just existingTag -> do
- removeTagByName ebuf tagName
- Nothing -> do
- errtag <- newTag tagTable tagName
- case logRefType logRef of
- ErrorRef -> do
- underline errtag UnderlineError
- WarningRef -> do
- underline errtag UnderlineError
- BreakpointRef -> do
- background errtag $ breakpointBackground prefs
- ContextRef -> do
- background errtag $ contextBackground prefs
liftIO $ debugM "lekash" "markRefInSourceBuf calculating range"
let start' = (srcSpanStartLine (logRefSrcSpan logRef),
@@ -394,7 +449,7 @@
then positionToCandy candy' ebuf end'
else return end'
lines <- getLineCount ebuf
- iterTmp <- getIterAtLine ebuf (max 0 (min (lines-1) ((fst start)-1)))
+ iterTmp <- getIterAtLine ebuf (max 0 (min (lines-1) (fst start - 1)))
chars <- getCharsInLine iterTmp
iter <- atLineOffset iterTmp (max 0 (min (chars-1) (snd start)))
@@ -405,7 +460,7 @@
Nothing -> atEnd iter
Just we -> return we
else do
- newTmp <- getIterAtLine ebuf (max 0 (min (lines-1) ((fst end)-1)))
+ 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
@@ -417,12 +472,7 @@
unless isOldContext $ do
liftIO $ debugM "lekash" "markRefInSourceBuf calling applyTagByName"
lineStart <- backwardToLineStartC iter
- createMark sv tagName lineStart (
- case logRefType logRef of
- ErrorRef -> "dialog-error"
- WarningRef -> "dialog-warning"
- BreakpointRef -> "media-playback-pause"
- ContextRef -> "media-playback-start") $ refDescription logRef
+ createMark sv (logRefType logRef) lineStart $ refDescription logRef
applyTagByName ebuf tagName iter iter2
when scrollTo $ do
ideR <- ask
@@ -439,11 +489,11 @@
-- | 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 = do
+newTextBuffer panePath bn mbfn =
case mbfn of
Nothing -> buildPane "" Nothing
Just fn ->
- do eErrorContents <- liftIO $ do
+ do eErrorContents <- liftIO $
catch (Right <$> T.readFile fn)
(\e -> return $ Left (show (e :: IOError)))
case eErrorContents of
@@ -484,7 +534,7 @@
Gtk.Notebook ->
Gtk.Window ->
IDEM (Maybe IDEBuffer,Connections)
-builder' bs mbfn ind bn rbn ct prefs fileContents modTime pp nb windows = do
+builder' bs mbfn ind bn rbn ct prefs fileContents modTime pp nb windows =
-- display a file
case textEditorType prefs of
"GtkSourceView" -> newGtkBuffer mbfn fileContents >>= makeBuffer modTime
@@ -517,12 +567,9 @@
(False,_) -> Nothing
(True,v) -> Just v
setIndentWidth sv $ tabWidth prefs
- setTabWidth sv $ 8 -- GHC treats tabs as 8 we should display them that way
+ setTabWidth sv 8 -- GHC treats tabs as 8 we should display them that way
drawTabs sv
- preferDark <- getDarkState
- setStyle preferDark buffer $ case sourceStyle prefs of
- (False,_) -> Nothing
- (True,v) -> Just v
+ updateStyle buffer
-- put it in a scrolled window
sw <- getScrolledWindow sv
@@ -541,11 +588,9 @@
mode = mod}
-- events
ids1 <- sv `afterFocusIn` makeActive buf
- ids2 <- onCompletion sv (do
- Completion.complete sv False) $ do
- Completion.cancel
+ ids2 <- onCompletion sv (Completion.complete sv False) Completion.cancel
ids3 <- onButtonPress sv $ do
- click <- lift $ Gtk.eventClick
+ click <- lift Gtk.eventClick
liftIDE $
case click of
Gtk.DoubleClick -> do
@@ -556,7 +601,7 @@
(GetTextPopup mbTpm) <- triggerEvent ideR (GetTextPopup Nothing)
ids4 <- case mbTpm of
- Just tpm -> sv `onPopulatePopup` \menu -> liftIO $ (tpm ideR menu)
+ Just tpm -> sv `onPopulatePopup` \menu -> liftIO $ tpm ideR menu
Nothing -> do
sysMessage Normal "SourceBuffer>> no text popup"
return []
@@ -570,8 +615,7 @@
tagTable <- getTagTable ebuf
mbTag <- lookupTag tagTable tagName
case mbTag of
- Just existingTag -> do
- removeTagByName ebuf tagName
+ Just existingTag -> removeTagByName ebuf tagName
Nothing -> do
tag <- newTag tagTable tagName
background tag $ matchBackground prefs
@@ -582,13 +626,11 @@
sTxt <- getCandylessPart candy' ebuf si1 si2
let strippedSTxt = T.strip sTxt
- if T.null strippedSTxt
- then return ()
- else do
- bi1 <- getStartIter ebuf
- bi2 <- getEndIter ebuf
- forwardApplying bi1 strippedSTxt (Just si1) tagName ebuf
- forwardApplying si2 strippedSTxt (Just bi2) tagName ebuf
+ unless (T.null strippedSTxt) $
+ do bi1 <- getStartIter ebuf
+ bi2 <- getEndIter ebuf
+ forwardApplying bi1 strippedSTxt (Just si1) tagName ebuf
+ forwardApplying si2 strippedSTxt (Just bi2) tagName ebuf
return False
ids6 <- onKeyPress sv $ do
@@ -638,7 +680,7 @@
slice <- getSlice buffer start end True
triggerEventIDE (SelectInfo slice True)
return True
- _ -> do
+ _ ->
-- liftIO $ print ("sourcebuffer key:",name,modifier,keyval)
return False
ids7 <- do
@@ -646,7 +688,7 @@
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 -> do
+ return (beg, if ctrl then en else beg)) (\_ shift' slice ->
unless (T.null slice) $ do
-- liftIO$ print ("slice",slice)
triggerEventIDE (SelectInfo slice shift')
@@ -667,9 +709,8 @@
Just (start, end) -> do
startsWord <- startsWord start
endsWord <- endsWord end
- if (startsWord && endsWord)
- then applyTagByName ebuf tagName start end
- else return ()
+ when (startsWord && endsWord) $
+ applyTagByName ebuf tagName start end
forwardApplying end txt mbTi tagName ebuf
Nothing -> return()
@@ -679,7 +720,7 @@
currentChar <- getChar sel
let mbStartCharCat = getCharacterCategory currentChar
mbPrevCharCat <- getCharacterCategory <$> (backwardCharC sel >>= getChar)
- return $ currentChar == Nothing || currentChar == Just '\n' || mbStartCharCat /= mbPrevCharCat && (mbStartCharCat == SyntaxCharacter || mbStartCharCat == IdentifierCharacter)
+ return $ isNothing currentChar || currentChar == Just '\n' || mbStartCharCat /= mbPrevCharCat && (mbStartCharCat == SyntaxCharacter || mbStartCharCat == IdentifierCharacter)
getIdentifierUnderCursor :: forall editor. TextEditor editor => EditorBuffer editor -> IDEM (EditorIter editor, EditorIter editor)
getIdentifierUnderCursor buffer = do
@@ -741,7 +782,7 @@
load <- readIDE (autoLoad . prefs)
if load
then do
- ideMessage Normal $ (__ "Auto Loading ") <> T.pack fn
+ ideMessage Normal $ __ "Auto Loading " <> T.pack fn
revert buf
return (False, True)
else do
@@ -751,7 +792,7 @@
(Just window) []
MessageQuestion
ButtonsNone
- ((__"File \"") <> name <> (__ "\" has changed on disk."))
+ (__ "File \"" <> name <> __ "\" has changed on disk.")
dialogAddButton md (__ "_Load From Disk") (ResponseUser 1)
dialogAddButton md (__ "_Always Load From Disk") (ResponseUser 2)
dialogAddButton md (__ "_Don't Load") (ResponseUser 3)
@@ -772,7 +813,7 @@
nmt2 <- liftIO $ getModificationTime fn
liftIO $ writeIORef (modTime buf) (Just nmt2)
return (True, True)
- _ -> do return (False, False)
+ _ -> return (False, False)
else return (False, False)
else return (False, False)
Nothing -> return (False, False)
@@ -791,7 +832,7 @@
return ())
fileRevert :: IDEAction
-fileRevert = inActiveBufContext () $ \ _ _ _ currentBuffer _ -> do
+fileRevert = inActiveBufContext () $ \ _ _ _ currentBuffer _ ->
revert currentBuffer
revert :: MonadIDE m => IDEBuffer -> m ()
@@ -807,10 +848,10 @@
mt <- liftIO $ getModificationTime fn
beginNotUndoableAction buffer
setText buffer $ T.pack fc
- if useCandy
- then modeTransformToCandy (mode buf)
- (modeEditInCommentOrString (mode buf)) buffer
- else return ()
+ when useCandy $
+ modeTransformToCandy (mode buf)
+ (modeEditInCommentOrString (mode buf))
+ buffer
endNotUndoableAction buffer
setModified buffer False
return mt
@@ -849,9 +890,7 @@
Just path -> do
nb <- getNotebook path
mbBS <- maybeActiveBuf
- case mbBS of
- Nothing -> return ()
- Just buf -> markLabelAsChanged nb buf
+ forM_ mbBS (markLabelAsChanged nb)
markLabelAsChanged :: Notebook -> IDEBuffer -> IDEAction
markLabelAsChanged nb (buf@IDEBuffer{sourceView = sv}) = do
@@ -872,10 +911,10 @@
case mbpage of
Nothing -> throwIDE (__ "fileSave: Page not found")
Just page ->
- if isJust mbfn && query == False
+ if isJust mbfn && not query
then do (modifiedOnDiskNotLoaded, modifiedOnDisk) <- checkModTime ideBuf -- The user is given option to reload
modifiedInBuffer <- getModified ebuf
- if (modifiedOnDiskNotLoaded || modifiedInBuffer)
+ if modifiedOnDiskNotLoaded || modifiedInBuffer
then do
fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf
useCandy candy $fromJust mbfn
@@ -884,7 +923,7 @@
else return modifiedOnDisk
else reifyIDE $ \ideR -> do
dialog <- fileChooserDialogNew
- (Just $ (__ "Save File"))
+ (Just $ __ "Save File")
(Just window)
FileChooserActionSave
[("gtk-cancel" --buttons to display
@@ -892,7 +931,7 @@
,("gtk-save"
, ResponseAccept)]
case mbfn of
- Just fn -> fileChooserSelectFilename dialog fn >> return ()
+ Just fn -> void (fileChooserSelectFilename dialog fn)
Nothing -> return ()
widgetShow dialog
response <- dialogRun dialog
@@ -932,7 +971,7 @@
where
fileSave' :: Bool -> Bool -> Notebook -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IDEAction
fileSave' forceLineEnds removeTBlanks nb ideBuf useCandy candyTable fn = do
- buf <- getBuffer $ sv
+ buf <- getBuffer sv
text <- getCandylessText candyTable buf
let text' = if removeTBlanks
then T.unlines $ map (T.dropWhileEnd $ \c -> c == ' ') $ T.lines text
@@ -943,7 +982,103 @@
return False)
setModified buf (not succ)
markLabelAsChanged nb ideBuf
+ hlintBuffer' ideBuf text' fn
+hlintSettings :: IDEPackage -> IDEM (ParseFlags, [Classify], Hint)
+hlintSettings package = do
+ mbHlintDir <- liftIO $ leksahSubDir "hlint"
+ let cabalMacros = ipdBuildDir package "dist/build/autogen/cabal_macros.h"
+ cabalMacrosExist <- liftIO $ doesFileExist cabalMacros
+ defines <- liftIO $ if cabalMacrosExist
+ then do
+ raw <- S.readFile cabalMacros
+ map (\(a, b) -> (a, concat (lines b))) . snd <$> runCpphsReturningSymTab defaultCpphsOptions cabalMacros raw
+ else return []
+ (fixities, classify, hints) <- liftIO $ findSettings (readSettingsFile mbHlintDir) Nothing
+ let hint = resolveHints hints
+ flags = parseFlagsAddFixities fixities defaultParseFlags{ cppFlags = Cpphs defaultCpphsOptions
+ { defines = defines } }
+ liftIO . debugM "leksah" $ "hlintSettings defines = " <> show defines
+ return (flags, classify, hint)
+
+hlintBuffer :: IDEBuffer -> IDEAction
+hlintBuffer ideBuf@IDEBuffer{..} = do
+ buf <- getBuffer sourceView
+ candy <- readIDE candy
+ text <- getCandylessText candy buf
+ maybe (return ()) (hlintBuffer' ideBuf text) fileName
+
+hlintBuffer' :: IDEBuffer -> Text -> FilePath -> IDEAction
+hlintBuffer' ideBuf text fn = do
+ packs <- belongsToPackages ideBuf
+ ideR <- ask
+ case packs of
+ (package:_) -> do
+ let file = makeRelative (ipdBuildDir package) fn
+ removeLogRefs [LintRef] (ipdBuildDir package) file
+ liftIO . void . forkIO $ do
+ (flags, classify, hint) <- reflectIDE (hlintSettings package) ideR
+ parseResult <- parseModuleEx flags fn (Just $ T.unpack text)
+ case parseResult of
+ (Right m) -> do
+ let allIdeas = applyHints classify hint [m]
+ ideas = filter (\Idea{..} -> ideaSeverity /= Ignore
+ && equalFilePath (HSE.srcSpanFilename ideaSpan) fn) allIdeas
+ forM_ ideas $ \ idea@Idea{..} -> do
+ let fixColumn c = max 0 (c - 1)
+ srcSpan = SrcSpan file
+ (HSE.srcSpanStartLine ideaSpan)
+ (HSE.srcSpanStartColumn ideaSpan - 1)
+ (HSE.srcSpanEndLine ideaSpan)
+ (HSE.srcSpanEndColumn ideaSpan - 1)
+ fromLines = drop (HSE.srcSpanStartLine ideaSpan - 1)
+ . take (HSE.srcSpanEndLine ideaSpan) $ T.lines text
+ fixHead [] = []
+ fixHead (x:xs) = T.drop (HSE.srcSpanStartColumn ideaSpan - 1) x : xs
+ fixTail [] = []
+ fixTail (x:xs) = T.take (HSE.srcSpanEndColumn ideaSpan - 1) x : xs
+ from = T.reverse . T.drop 1 . T.reverse
+ . T.unlines . fixHead . reverse . fixTail $ reverse fromLines
+ reflectIDE (postAsyncIDE $ addLogRef
+ (LogRef srcSpan package (T.pack ideaHint <> maybe "" (("\n" <>) . T.pack) ideaTo)
+ (Just (from, idea)) (0, 0) LintRef)) ideR
+ Left error -> do
+ let loc = parseErrorLocation error
+ srcSpan = SrcSpan file
+ (HSE.srcLine loc)
+ (HSE.srcColumn loc - 1)
+ (HSE.srcLine loc)
+ (HSE.srcColumn loc - 1)
+ reflectIDE (postAsyncIDE $ addLogRef
+ (LogRef srcSpan package ("Hlint Parse Error: " <> T.pack (parseErrorMessage error))
+ Nothing (0, 0) LintRef)) ideR
+ _ -> liftIO . debugM "leksah" $ "hlintBuffer package not found for " <> fn
+
+resolveActiveHLint :: IDEM Bool
+resolveActiveHLint = inActiveBufContext False $ \_ _ ebuf _ _ -> do
+ allLogRefs <- readIDE allLogRefs
+ (iStart, iEnd) <- getSelectionBounds ebuf
+ lStart <- getLine iStart
+ cStart <- getLineOffset iStart
+ lEnd <- getLine iEnd
+ cEnd <- getLineOffset iEnd
+ let selectedRefs = filter (\ LogRef{..} -> logRefType == LintRef
+ && (lStart+1, cStart) <= (srcSpanEndLine logRefSrcSpan, srcSpanEndColumn logRefSrcSpan)
+ && (lEnd+1, cEnd) >= (srcSpanStartLine logRefSrcSpan, srcSpanStartColumn logRefSrcSpan)) allLogRefs
+ safeRefs = takeWhileNotOverlapping selectedRefs
+ (changed, _) <- foldM replaceHLintSource (False, 0) . catMaybes $ map logRefIdea safeRefs
+ prefs <- readIDE prefs
+ when changed $ if backgroundBuild prefs
+ then setModified ebuf True
+ else void $ fileSave False
+ return changed
+ where
+ takeWhileNotOverlapping = takeWhileNotOverlapping' (-1)
+ takeWhileNotOverlapping' _ [] = []
+ takeWhileNotOverlapping' line (ref:refs)
+ | srcSpanEndLine (logRefSrcSpan ref) > line = ref : takeWhileNotOverlapping' (srcSpanEndLine $ logRefSrcSpan ref) refs
+ | otherwise = takeWhileNotOverlapping' line refs
+
fileSave :: Bool -> IDEM Bool
fileSave query = inActiveBufContext False $ fileSaveBuffer query
@@ -984,19 +1119,19 @@
return ()
fileClose :: IDEM Bool
-fileClose = inActiveBufContext True $ fileClose'
+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 -> do
+ cancel <- reifyIDE $ \ideR ->
if modified
then do
md <- messageDialogNew (Just window) []
MessageQuestion
ButtonsCancel
- ((__ "Save changes to document: ")
+ (__ "Save changes to document: "
<> paneName currentBuffer
<> "?")
dialogAddButton md (__ "_Save") ResponseYes
@@ -1016,8 +1151,7 @@
then return False
else do
closeThisPane currentBuffer
- when (isJust $ fileName currentBuffer)
- (addRecentlyUsedFile (fromJust $ fileName currentBuffer))
+ forM_ (fileName currentBuffer) addRecentlyUsedFile
return True
fileCloseAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool
@@ -1035,7 +1169,7 @@
fileCloseAllButPackage :: IDEAction
fileCloseAllButPackage = do
- mbActivePath <- (fmap ipdBuildDir) <$> readIDE activePack
+ mbActivePath <- fmap ipdBuildDir <$> readIDE activePack
bufs <- allBuffers
case mbActivePath of
Just p -> mapM_ (close' p) bufs
@@ -1058,7 +1192,7 @@
fileCloseAllButWorkspace = do
mbWorkspace <- readIDE workspace
bufs <- allBuffers
- when (not (null bufs) && isJust mbWorkspace) $ do
+ when (not (null bufs) && isJust mbWorkspace) $
mapM_ (close' (fromJust mbWorkspace)) bufs
where
close' workspace (buf@IDEBuffer {sourceView = sv}) = do
@@ -1075,7 +1209,7 @@
$ do fileClose' nb sv ebuf buf i; return ()
isSubPathOfAny workspace fileName =
let paths = wsPackages workspace >>= ipdAllDirs
- in or (map (\dir -> isSubPath dir fileName) paths)
+ in any (`isSubPath` fileName) paths
fileOpen :: IDEAction
@@ -1085,7 +1219,7 @@
mbBuf <- maybeActiveBuf
mbFileName <- liftIO $ do
dialog <- fileChooserDialogNew
- (Just $ (__ "Open File"))
+ (Just $ __ "Open File")
(Just window)
FileChooserActionOpen
[("gtk-cancel"
@@ -1093,7 +1227,7 @@
,("gtk-open"
,ResponseAccept)]
case mbBuf >>= fileName of
- Just fn -> fileChooserSetCurrentFolder dialog (dropFileName $ fn) >> return ()
+ Just fn -> void (fileChooserSetCurrentFolder dialog (dropFileName fn))
Nothing -> return ()
widgetShow dialog
response <- dialogRun dialog
@@ -1109,9 +1243,7 @@
widgetDestroy dialog
return Nothing
_ -> return Nothing
- case mbFileName of
- Nothing -> return ()
- Just fp -> fileOpenThis fp
+ forM_ mbFileName fileOpenThis
fileOpenThis :: FilePath -> IDEAction
@@ -1150,70 +1282,65 @@
return ()
filePrint :: IDEAction
-filePrint = inActiveBufContext () $ filePrint'
+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 <- messageDialogNew (Just window) []
- MessageQuestion
- ButtonsNone
- (__"Print document: "
- <> pName
- <> "?")
- dialogAddButton md (__"_Print") ResponseYes
- dialogAddButton md (__"_Don't Print") ResponseNo
- set md [ windowWindowPosition := WinPosCenterOnParent ]
- resp <- dialogRun md
- widgetDestroy md
- case resp of
- ResponseYes -> do
- return True
- ResponseCancel -> return False
- ResponseNo -> return False
- _ -> return False
- if not print
- then return ()
- else do
- --real code
- modified <- getModified ebuf
- cancel <- reifyIDE $ \ideR -> do
- if modified
- then do
- md <- messageDialogNew (Just window) []
- MessageQuestion
- ButtonsNone
- (__"Save changes to document: "
- <> pName
- <> "?")
- dialogAddButton md (__"_Save") ResponseYes
- dialogAddButton md (__"_Don't Save") ResponseNo
- dialogAddButton md (__"_Cancel Printing") ResponseCancel
- set md [ windowWindowPosition := WinPosCenterOnParent ]
- 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 ()
- else do
- case fileName currentBuffer of
- Just name -> do
- status <- liftIO $ Print.print name
- case status of
- Left error -> liftIO $ showDialog (T.pack $ show error) MessageError
- Right _ -> liftIO $ showDialog "Print job has been sent successfully" MessageInfo
- return ()
- Nothing -> return ()
+ md <- messageDialogNew (Just window) []
+ MessageQuestion
+ ButtonsNone
+ (__"Print document: "
+ <> pName
+ <> "?")
+ dialogAddButton md (__"_Print") ResponseYes
+ dialogAddButton md (__"_Don't Print") ResponseNo
+ set md [ windowWindowPosition := WinPosCenterOnParent ]
+ resp <- dialogRun md
+ widgetDestroy md
+ case resp of
+ ResponseYes -> return True
+ ResponseCancel -> return False
+ ResponseNo -> return False
+ _ -> return False
+ when print $ do
+ --real code
+ modified <- getModified ebuf
+ cancel <- reifyIDE $ \ideR ->
+ if modified
+ then do
+ md <- messageDialogNew (Just window) []
+ MessageQuestion
+ ButtonsNone
+ (__"Save changes to document: "
+ <> pName
+ <> "?")
+ dialogAddButton md (__"_Save") ResponseYes
+ dialogAddButton md (__"_Don't Save") ResponseNo
+ dialogAddButton md (__"_Cancel Printing") ResponseCancel
+ set md [ windowWindowPosition := WinPosCenterOnParent ]
+ 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
+ unless cancel $
+ case fileName currentBuffer of
+ Just name -> do
+ status <- liftIO $ Print.print name
+ case status of
+ Left error -> liftIO $ showDialog (T.pack $ show error) MessageError
+ Right _ -> liftIO $ showDialog "Print job has been sent successfully" MessageInfo
+ return ()
+ Nothing -> return ()
editUndo :: IDEAction
editUndo = inActiveBufContext () $ \_ _ buf _ _ -> do
@@ -1258,14 +1385,12 @@
prefs <- readIDE prefs
let str = T.replicate (tabWidth prefs) " "
b <- canShiftLeft str prefs
- if b
- then do
- doForSelectedLines [] $ \ebuf lineNr -> do
- sol <- getIterAtLine ebuf lineNr
- sol2 <- forwardCharsC sol (tabWidth prefs)
- delete ebuf sol sol2
- return ()
- else return ()
+ 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
@@ -1288,12 +1413,10 @@
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 ()
+ let alignTo = foldl' max 0 (mapMaybe snd positions)
+ when (alignTo > 0) $ alignChar (Map.fromList positions) alignTo
where
- positionsOfChar :: IDEM ([(Int, Maybe Int)])
+ positionsOfChar :: IDEM [(Int, Maybe Int)]
positionsOfChar = doForSelectedLines [] $ \ebuf lineNr -> do
sol <- getIterAtLine ebuf lineNr
eol <- forwardToLineEndC sol
@@ -1301,7 +1424,7 @@
return (lineNr, T.findIndex (==char) line)
alignChar :: Map Int (Maybe Int) -> Int -> IDEM ()
alignChar positions alignTo = do
- doForSelectedLines [] $ \ebuf lineNr -> do
+ doForSelectedLines [] $ \ebuf lineNr ->
case lineNr `Map.lookup` positions of
Just (Just n) -> do
sol <- getIterAtLine ebuf lineNr
@@ -1322,9 +1445,9 @@
addRecentlyUsedFile :: FilePath -> IDEAction
addRecentlyUsedFile fp = do
state <- readIDE currentState
- when (not $ isStartingOrClosing state) $ do
+ unless (isStartingOrClosing state) $ do
recentFiles' <- readIDE recentFiles
- unless (elem fp recentFiles') $
+ unless (fp `elem` recentFiles') $
modifyIDE_ (\ide -> ide{recentFiles = take 12 (fp : recentFiles')})
triggerEventIDE UpdateRecent
return ()
@@ -1332,10 +1455,10 @@
removeRecentlyUsedFile :: FilePath -> IDEAction
removeRecentlyUsedFile fp = do
state <- readIDE currentState
- when (not $ isStartingOrClosing state) $ do
+ unless (isStartingOrClosing state) $ do
recentFiles' <- readIDE recentFiles
- when (elem fp recentFiles') $
- modifyIDE_ (\ide -> ide{recentFiles = filter (\e -> e /= fp) recentFiles'})
+ when (fp `elem` recentFiles') $
+ modifyIDE_ (\ide -> ide{recentFiles = filter (/= fp) recentFiles'})
triggerEventIDE UpdateRecent
return ()
@@ -1364,7 +1487,7 @@
iStart <- getIterAtLine ebuf line
iEnd <- forwardToLineEndC iStart
return (iStart, iEnd)
- fmap Just $ getCandylessPart candy' ebuf i1 i2
+ Just <$> getCandylessPart candy' ebuf i1 i2
selectedLocation :: IDEM (Maybe (Int, Int))
selectedLocation = do
@@ -1416,7 +1539,7 @@
belongsToPackage :: FilePath -> IDEPackage -> Bool
belongsToPackage f = any (`isSubPath` f) . ipdAllDirs
-belongsToWorkspace b = belongsToPackages b >>= return . (not . null)
+belongsToWorkspace b = liftM (not . null) (belongsToPackages b)
useCandyFor :: MonadIDE m => IDEBuffer -> m Bool
useCandyFor aBuffer = do
diff --git a/src/IDE/Pane/WebKit/Documentation.hs b/src/IDE/Pane/WebKit/Documentation.hs
--- a/src/IDE/Pane/WebKit/Documentation.hs
+++ b/src/IDE/Pane/WebKit/Documentation.hs
@@ -80,25 +80,25 @@
paneId b = "*Doc"
instance RecoverablePane IDEDocumentation DocumentationState IDEM where
- saveState p = liftIO $ do
+ saveState p = liftIO $
#ifdef WEBKITGTK
- zoom <- webView p `get` webViewZoomLevel
- uri <- webView p `get` webViewUri
- return (Just DocumentationState{..})
+ do zoom <- webView p `get` webViewZoomLevel
+ uri <- webView p `get` webViewUri
+ return (Just DocumentationState{..})
#else
- Just <$> readIORef (docState p)
+ Just <$> readIORef (docState p)
#endif
recoverState pp DocumentationState {..} = do
nb <- getNotebook pp
mbPane <- buildPane pp nb builder
case mbPane of
Nothing -> return ()
- Just p -> liftIO $ do
+ Just p -> liftIO $
#ifdef WEBKITGTK
- webView p `set` [webViewZoomLevel := zoom]
- maybe (return ()) (webViewLoadUri (webView p)) uri
+ do webView p `set` [webViewZoomLevel := zoom]
+ maybe (return ()) (webViewLoadUri (webView p)) uri
#else
- writeIORef (docState p) DocumentationState {..}
+ writeIORef (docState p) DocumentationState {..}
#endif
return mbPane
builder pp nb windows = reifyIDE $ \ ideR -> do
@@ -140,22 +140,22 @@
getDocumentation (Just pp) = forceGetPane (Left pp)
loadDoc :: Text -> IDEAction
-loadDoc uri = do
+loadDoc uri =
#ifdef WEBKITGTK
- doc <- getDocumentation Nothing
- let view = webView doc
- liftIO $ webViewLoadUri view uri
+ do doc <- getDocumentation Nothing
+ let view = webView doc
+ liftIO $ webViewLoadUri view uri
#else
- return ()
+ return ()
#endif
reloadDoc :: IDEAction
-reloadDoc = do
+reloadDoc =
#ifdef WEBKITGTK
- doc <- getDocumentation Nothing
- let view = webView doc
- liftIO $ webViewReload view
+ do doc <- getDocumentation Nothing
+ let view = webView doc
+ liftIO $ webViewReload view
#else
- return ()
+ return ()
#endif
diff --git a/src/IDE/Pane/WebKit/Inspect.hs b/src/IDE/Pane/WebKit/Inspect.hs
--- a/src/IDE/Pane/WebKit/Inspect.hs
+++ b/src/IDE/Pane/WebKit/Inspect.hs
@@ -94,7 +94,7 @@
paneId b = "*Inspect"
instance RecoverablePane IDEInspect InspectState IDEM where
- saveState p = liftIO $ do
+ saveState p = liftIO $
#ifdef WEBKITGTK
return (Just InspectState{})
#else
@@ -105,7 +105,7 @@
mbPane <- buildPane pp nb builder
case mbPane of
Nothing -> return ()
- Just p -> liftIO $ do
+ Just p -> liftIO $
#ifdef WEBKITGTK
return ()
#else
diff --git a/src/IDE/Pane/WebKit/Output.hs b/src/IDE/Pane/WebKit/Output.hs
--- a/src/IDE/Pane/WebKit/Output.hs
+++ b/src/IDE/Pane/WebKit/Output.hs
@@ -102,25 +102,25 @@
paneId b = "*Out"
instance RecoverablePane IDEOutput OutputState IDEM where
- saveState p = liftIO $ do
+ saveState p = liftIO $
#ifdef WEBKITGTK
- zoom <- webView p `get` webViewZoomLevel
- alwaysHtml <- readIORef $ alwaysHtmlRef p
- return (Just OutputState{..})
+ do zoom <- webView p `get` webViewZoomLevel
+ alwaysHtml <- readIORef $ alwaysHtmlRef p
+ return (Just OutputState{..})
#else
- Just <$> readIORef (outState p)
+ Just <$> readIORef (outState p)
#endif
recoverState pp OutputState {..} = do
nb <- getNotebook pp
mbPane <- buildPane pp nb builder
case mbPane of
Nothing -> return ()
- Just p -> liftIO $ do
+ Just p -> liftIO $
#ifdef WEBKITGTK
- webView p `set` [webViewZoomLevel := zoom]
- writeIORef (alwaysHtmlRef p) alwaysHtml
+ do webView p `set` [webViewZoomLevel := zoom]
+ writeIORef (alwaysHtmlRef p) alwaysHtml
#else
- writeIORef (outState p) OutputState {..}
+ writeIORef (outState p) OutputState {..}
#endif
return mbPane
builder pp nb windows = reifyIDE $ \ ideR -> do
@@ -216,34 +216,34 @@
++ "/value.html"
setOutput :: Text -> Text -> IDEAction
-setOutput command str = do
+setOutput command str =
#ifdef WEBKITGTK
- out <- getOutputPane Nothing
- liftIO $ do
- entrySetText (uriEntry out) (T.pack $ show command)
- uri <- getValueUri
- alwaysHtml <- readIORef $ alwaysHtmlRef out
- let view = webView out
- html = case (alwaysHtml, parseValue $ T.unpack str) of
- (False, Just value) -> T.pack $ valToHtmlPage defaultHtmlOpts value
- _ -> str
- webViewLoadString view html Nothing uri
+ do out <- getOutputPane Nothing
+ liftIO $ do
+ entrySetText (uriEntry out) (T.pack $ show command)
+ uri <- getValueUri
+ alwaysHtml <- readIORef $ alwaysHtmlRef out
+ let view = webView out
+ html = case (alwaysHtml, parseValue $ T.unpack str) of
+ (False, Just value) -> T.pack $ valToHtmlPage defaultHtmlOpts value
+ _ -> str
+ webViewLoadString view html Nothing uri
#else
- return ()
+ return ()
#endif
loadOutputUri :: FilePath -> IDEAction
-loadOutputUri uri = do
+loadOutputUri uri =
#ifdef WEBKITGTK
- out <- getOutputPane Nothing
- let view = webView out
- liftIO $ do
- entrySetText (uriEntry out) (T.pack uri)
- currentUri <- webViewGetUri view
- if Just (T.pack uri) == currentUri
- then webViewReload view
- else webViewLoadUri view (T.pack uri)
+ do out <- getOutputPane Nothing
+ let view = webView out
+ liftIO $ do
+ entrySetText (uriEntry out) (T.pack uri)
+ currentUri <- webViewGetUri view
+ if Just (T.pack uri) == currentUri
+ then webViewReload view
+ else webViewLoadUri view (T.pack uri)
#else
- return ()
+ return ()
#endif
diff --git a/src/IDE/Session.hs b/src/IDE/Session.hs
--- a/src/IDE/Session.hs
+++ b/src/IDE/Session.hs
@@ -73,10 +73,12 @@
import IDE.Workspaces (workspaceOpenThis)
import IDE.Completion (setCompletionSize)
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad (forM_, forM, when)
+import Control.Monad (void, when)
import System.Log.Logger (debugM)
import Data.Text (Text)
import qualified Data.Text as T (pack)
+import Data.Traversable (forM)
+import Data.Foldable (forM_)
-- ---------------------------------------------------------------------
-- This needs to be incremented, when the session format changes
@@ -109,45 +111,45 @@
deriving(Eq,Ord,Read,Show)
asPaneState :: RecoverablePane alpha beta gamma => beta -> PaneState
-asPaneState s | isJust ((cast s) :: Maybe BufferState) = BufferSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe LogState) = LogSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe InfoState) = InfoSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe ModulesState) = ModulesSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe PrefsState) = PrefsSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe FlagsState) = FlagsSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe SearchState) = SearchSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe FilesState) = FilesSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe GrepState) = GrepSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe HLintState) = HLintSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe DocumentationState) = DocumentationSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe OutputState) = OutputSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe InspectState) = InspectSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe BreakpointsState) = BreakpointsSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe TraceState) = TraceSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe VariablesState) = VariablesSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe ErrorsState) = ErrorsSt (fromJust $ cast s)
-asPaneState s | isJust ((cast s) :: Maybe WorkspaceState) = WorkspaceSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe BufferState) = BufferSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe LogState) = LogSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe InfoState) = InfoSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe ModulesState) = ModulesSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe PrefsState) = PrefsSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe FlagsState) = FlagsSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe SearchState) = SearchSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe FilesState) = FilesSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe GrepState) = GrepSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe HLintState) = HLintSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe DocumentationState) = DocumentationSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe OutputState) = OutputSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe InspectState) = InspectSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe BreakpointsState) = BreakpointsSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe TraceState) = TraceSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe VariablesState) = VariablesSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe ErrorsState) = ErrorsSt (fromJust $ cast s)
+asPaneState s | isJust (cast s :: Maybe WorkspaceState) = WorkspaceSt (fromJust $ cast s)
asPaneState s = error "SaveSession>>asPaneState incomplete cast"
recover :: PanePath -> PaneState -> IDEAction
-recover pp (BufferSt p) = recoverState pp p >> return ()
-recover pp (LogSt p) = recoverState pp p >> return ()
-recover pp (InfoSt p) = recoverState pp p >> return ()
-recover pp (ModulesSt p) = recoverState pp p >> return ()
-recover pp (PrefsSt p) = recoverState pp p >> return ()
-recover pp (FlagsSt p) = recoverState pp p >> return ()
-recover pp (SearchSt p) = recoverState pp p >> return ()
-recover pp (FilesSt p) = recoverState pp p >> return ()
-recover pp (GrepSt p) = recoverState pp p >> return ()
-recover pp (HLintSt p) = recoverState pp p >> return ()
-recover pp (DocumentationSt p) = recoverState pp p >> return ()
-recover pp (OutputSt p) = recoverState pp p >> return ()
-recover pp (InspectSt p) = recoverState pp p >> return ()
-recover pp (BreakpointsSt p) = recoverState pp p >> return ()
-recover pp (TraceSt p) = recoverState pp p >> return ()
-recover pp (VariablesSt p) = recoverState pp p >> return ()
-recover pp (ErrorsSt p) = recoverState pp p >> return ()
-recover pp (WorkspaceSt p) = recoverState pp p >> return ()
+recover pp (BufferSt p) = void (recoverState pp p)
+recover pp (LogSt p) = void (recoverState pp p)
+recover pp (InfoSt p) = void (recoverState pp p)
+recover pp (ModulesSt p) = void (recoverState pp p)
+recover pp (PrefsSt p) = void (recoverState pp p)
+recover pp (FlagsSt p) = void (recoverState pp p)
+recover pp (SearchSt p) = void (recoverState pp p)
+recover pp (FilesSt p) = void (recoverState pp p)
+recover pp (GrepSt p) = void (recoverState pp p)
+recover pp (HLintSt p) = void (recoverState pp p)
+recover pp (DocumentationSt p) = void (recoverState pp p)
+recover pp (OutputSt p) = void (recoverState pp p)
+recover pp (InspectSt p) = void (recoverState pp p)
+recover pp (BreakpointsSt p) = void (recoverState pp p)
+recover pp (TraceSt p) = void (recoverState pp p)
+recover pp (VariablesSt p) = void (recoverState pp p)
+recover pp (ErrorsSt p) = void (recoverState pp p)
+recover pp (WorkspaceSt p) = void (recoverState pp p)
-- ---------------------------------------------------------------------
@@ -186,43 +188,43 @@
sessionVersion = theSessionVersion
, saveTime = ""
, layoutS = VerticalP
- (TerminalP {
+ TerminalP {
paneGroups = Map.fromList []
, paneTabs = Just TopP
, currentPage = -1
, detachedId = Nothing
- , detachedSize = Nothing})
+ , detachedSize = Nothing}
(HorizontalP
- (TerminalP {
+ TerminalP {
paneGroups = Map.fromList [
("Debug",HorizontalP
- (TerminalP {
+ TerminalP {
paneGroups = Map.fromList []
, paneTabs = Nothing
, currentPage = -1
, detachedId = Nothing
- , detachedSize = Nothing})
- (TerminalP {
+ , detachedSize = Nothing}
+ TerminalP {
paneGroups = Map.fromList []
, paneTabs = Just TopP
, currentPage = -1
, detachedId = Nothing
- , detachedSize = Nothing}) 167)]
+ , detachedSize = Nothing} 167)]
, paneTabs = Just TopP
, currentPage = 2
, detachedId = Nothing
- , detachedSize = Nothing})
- (TerminalP {
+ , detachedSize = Nothing}
+ TerminalP {
paneGroups = Map.fromList []
, paneTabs = Just TopP
, currentPage = 1
, detachedId = Nothing
- , detachedSize = Nothing}) 456) 693
+ , detachedSize = Nothing} 456) 693
, population = [ (Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP BottomP])
, (Just (LogSt LogState),[SplitP RightP,SplitP BottomP])
, (Just (ModulesSt
(ModulesState 200 (SystemScope,False) (Nothing,Nothing)
- (ExpanderState {
+ ExpanderState {
packageExp = ([],[])
, packageExpNoBlack = ([],[])
, packageDExp = ([],[])
@@ -232,7 +234,7 @@
, workspaceDExp = ([],[])
, workspaceDExpNoBlack = ([],[])
, systemExp = ([],[])
- , systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP])
+ , systemExpNoBlack = ([],[])})),[SplitP RightP,SplitP TopP])
, (Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP BottomP])]
, windowSize = (1024,768)
, fullScreen = False
@@ -258,85 +260,85 @@
sessionDescr :: [FieldDescriptionS SessionState]
sessionDescr = [
mkFieldS
- (paraName <<<- ParaName ( "Version of session file format") $ emptyParams)
+ (paraName <<<- ParaName "Version of session file format" $ emptyParams)
(PP.text . show)
intParser
sessionVersion
(\ b a -> a{sessionVersion = b})
, mkFieldS
- (paraName <<<- ParaName ( "Time of storage") $ emptyParams)
+ (paraName <<<- ParaName "Time of storage" $ emptyParams)
(PP.text . show)
stringParser
saveTime
(\ b a -> a{saveTime = b})
, mkFieldS
- (paraName <<<- ParaName ( "Layout") $ emptyParams)
+ (paraName <<<- ParaName "Layout" $ emptyParams)
(PP.text . show)
readParser
layoutS
(\ b a -> a{layoutS = b})
, mkFieldS
- (paraName <<<- ParaName ( "Population") $ emptyParams)
+ (paraName <<<- ParaName "Population" $ emptyParams)
(PP.text . show)
readParser
population
(\ b a -> a{population = b})
, mkFieldS
- (paraName <<<- ParaName ( "Window size") $ emptyParams)
+ (paraName <<<- ParaName "Window size" $ emptyParams)
(PP.text . show)
(pairParser intParser)
windowSize
(\(c,d) a -> a{windowSize = (c,d)})
, mkFieldS
- (paraName <<<- ParaName ( "Full screen") $ emptyParams)
+ (paraName <<<- ParaName "Full screen" $ emptyParams)
(PP.text . show)
readParser
fullScreen
(\b a -> a{fullScreen = b})
, mkFieldS
- (paraName <<<- ParaName ( "Dark") $ emptyParams)
+ (paraName <<<- ParaName "Dark" $ emptyParams)
(PP.text . show)
readParser
dark
(\b a -> a{dark = b})
, mkFieldS
- (paraName <<<- ParaName ( "Completion size") $ emptyParams)
+ (paraName <<<- ParaName "Completion size" $ emptyParams)
(PP.text . show)
(pairParser intParser)
completionSize
(\(c,d) a -> a{completionSize = (c,d)})
, mkFieldS
- (paraName <<<- ParaName ( "Workspace") $ emptyParams)
+ (paraName <<<- ParaName "Workspace" $ emptyParams)
(PP.text . show)
readParser
workspacePath
(\fp a -> a{workspacePath = fp})
, mkFieldS
- (paraName <<<- ParaName ( "Active pane") $ emptyParams)
+ (paraName <<<- ParaName "Active pane" $ emptyParams)
(PP.text . show)
readParser
activePaneN
(\fp a -> a{activePaneN = fp})
, mkFieldS
- (paraName <<<- ParaName ( "Toolbar visible") $ emptyParams)
+ (paraName <<<- ParaName "Toolbar visible" $ emptyParams)
(PP.text . show)
readParser
toolbarVisibleS
(\fp a -> a{toolbarVisibleS = fp})
, mkFieldS
- (paraName <<<- ParaName ( "FindbarState") $ emptyParams)
+ (paraName <<<- ParaName "FindbarState" $ emptyParams)
(PP.text . show)
readParser
findbarState
(\fp a -> a{findbarState = fp})
, mkFieldS
- (paraName <<<- ParaName ( "Recently opened files") $ emptyParams)
+ (paraName <<<- ParaName "Recently opened files" $ emptyParams)
(PP.text . show)
readParser
recentOpenedFiles
(\fp a -> a{recentOpenedFiles = fp})
, mkFieldS
- (paraName <<<- ParaName ( "Recently opened workspaces") $ emptyParams)
+ (paraName <<<- ParaName "Recently opened workspaces" $ emptyParams)
(PP.text . show)
readParser
recentOpenedWorksp
@@ -365,7 +367,7 @@
sysMessage Normal (__ "Now saving session")
bufs <- allBuffers
case filter (\b -> bufferName b == "_Eval.hs") bufs of
- [(IDEBuffer {sourceView = sv})] -> do
+ [IDEBuffer{sourceView = sv}] -> do
ebuf <- getBuffer sv
setModified ebuf False
_ -> return ()
@@ -427,7 +429,7 @@
response <- liftIO $ do
configFolder <- getConfigDir
dialog <- fileChooserDialogNew
- (Just $ (__ "Select session file"))
+ (Just $ __ "Select session file")
(Just window')
FileChooserActionOpen
[("gtk-cancel"
@@ -457,16 +459,15 @@
recentFiles' <- readIDE recentFiles
recentWorkspaces' <- readIDE recentWorkspaces
b <- fileCloseAll (\_ -> return True)
- if b
- then do
- detachedCloseAll
- paneCloseAll
- groupsCloseAll
- viewCollapseAll
- recoverSession sessionPath
- modifyIDE_ (\ide -> ide{recentFiles = recentFiles', recentWorkspaces = recentWorkspaces'})
- return ()
- else return ()
+ when b $ do
+ detachedCloseAll
+ paneCloseAll
+ groupsCloseAll
+ viewCollapseAll
+ recoverSession sessionPath
+ modifyIDE_ (\ ide -> ide{ recentFiles = recentFiles'
+ , recentWorkspaces = recentWorkspaces'})
+ return ()
detachedCloseAll :: IDEAction
detachedCloseAll = do
@@ -487,11 +488,11 @@
viewCollapseAll = do
layout' <- getLayout
case layout' of
- TerminalP {} -> return ()
- VerticalP _ _ _ -> viewCollapse' [SplitP LeftP]
- HorizontalP _ _ _ -> viewCollapse' [SplitP TopP]
+ TerminalP {} -> return ()
+ VerticalP {} -> viewCollapse' [SplitP LeftP]
+ HorizontalP {} -> viewCollapse' [SplitP TopP]
-mkLayout :: IDEM(PaneLayout)
+mkLayout :: IDEM PaneLayout
mkLayout = do
rawLayout <- getLayout
getLayout' rawLayout []
@@ -519,7 +520,7 @@
size <- case detachedId raw of
Just _ -> do
Just parent <- liftIO $ widgetGetParent nb
- liftIO $ fmap Just $ windowGetSize (castToWindow parent)
+ liftIO (Just <$> windowGetSize (castToWindow parent))
Nothing -> return $ detachedSize raw
return raw {
paneGroups = Map.fromAscList groups2
@@ -560,7 +561,7 @@
sessionSt <- liftIO $ catch
(readFields sessionPath sessionDescr defaultSession)
(\(_ :: SomeException) -> return defaultSession)
- liftIO $ windowSetDefaultSize wdw (fst (windowSize sessionSt))(snd (windowSize sessionSt))
+ liftIO $ uncurry (windowSetDefaultSize wdw) (windowSize sessionSt)
applyLayout (layoutS sessionSt)
workspaceOpenThis False (workspacePath sessionSt)
liftIO $ debugM "leksah" "recoverSession calling populate"
@@ -616,7 +617,7 @@
case mbTabPos of
Just p -> liftIO $notebookSetTabPos nb (paneDirectionToPosType p)
_ -> return ()
- forM_ (Map.toAscList groups) $ \(group, g) -> do
+ forM_ (Map.toAscList groups) $ \(group, g) ->
applyLayout' g (pp ++ [GroupP group])
applyLayout' (VerticalP l r pos) pp = do
viewSplit' pp Vertical
@@ -632,10 +633,7 @@
applyLayout' b (pp ++ [SplitP BottomP])
populate :: [(Maybe PaneState,PanePath)] -> IDEAction
-populate = mapM_ (\ (mbPs,pp) ->
- case mbPs of
- Nothing -> return ()
- Just s -> recover pp s)
+populate = mapM_ (\ (mbPs,pp) -> forM_ mbPs (recover pp))
setCurrentPages :: PaneLayout -> IDEAction
setCurrentPages layout = setCurrentPages' layout []
@@ -645,7 +643,7 @@
setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (SplitP LeftP : p)
setCurrentPages' r (SplitP RightP : p)
setCurrentPages' (TerminalP groups _ ind _ _) p = do
- forM_ (Map.toAscList groups) $ \(group, g) -> do
+ forM_ (Map.toAscList groups) $ \(group, g) ->
setCurrentPages' g (GroupP group : p)
when (ind >= 0) $ do
nb <- getNotebook (reverse p)
@@ -661,8 +659,7 @@
(Just window, False) -> liftIO $ windowUnfullscreen window
viewDark :: IDEAction
-viewDark = do
- getDarkState >>= setDark
+viewDark = getDarkState >>= setDark
#ifdef MIN_VERSION_gtk3
getActiveSettings :: PaneMonad alpha => alpha (Maybe Settings)
@@ -678,11 +675,7 @@
setInfoStyle
prefs <- readIDE prefs
buffers <- allBuffers
- mapM_ (\(IDEBuffer {sourceView = sv}) -> do
- ebuf <- getBuffer sv
- setStyle dark ebuf (case sourceStyle prefs of
- (False,_) -> Nothing
- (True,s) -> Just s)) buffers
+ mapM_ updateStyle' buffers
#ifdef MIN_VERSION_gtk3
mbSettings <- getActiveSettings
case mbSettings of
diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs
--- a/src/IDE/SourceCandy.hs
+++ b/src/IDE/SourceCandy.hs
@@ -39,7 +39,7 @@
import IDE.Core.State
import IDE.TextEditor
-import Control.Monad (unless)
+import Control.Monad (when, unless)
import Data.Text (Text)
import qualified Data.Text as T
(pack, singleton, replicate, head, takeWhile, isSuffixOf, length,
@@ -53,10 +53,9 @@
---------------------------------------------------------------------------------
-- * Implementation
-notBeforeId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['_']
-notAfterId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_']
-notBeforeOp = Set.fromList $['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\',
- '^','|','-','~','\'','"']
+notBeforeId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ "_"
+notAfterId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
+notBeforeOp = Set.fromList "!#$%&*+./<=>?@\\^|-~'\""
notAfterOp = notBeforeOp
keystrokeCandy :: TextEditor editor => CandyTable -> Maybe Char -> EditorBuffer editor -> (Text -> Bool) -> IDEM ()
@@ -69,32 +68,31 @@
startIter <- backwardToLineStartC endIter
slice <- getSlice ebuf startIter endIter True
mbc2 <- case mbc of
- Just c -> return (Just c)
- Nothing -> do
- getChar endIter
+ Just c -> return (Just c)
+ Nothing -> getChar endIter
let block = editInCommentOrString slice
unless block $
replace mbc2 cursorMark slice offset transformTable
where
-- replace :: Maybe Char -> m -> Text -> Int -> [(Bool,Text,Text)] -> IDEM ()
- replace mbAfterChar cursorMark match offset list = replace' list
+ replace mbAfterChar cursorMark match offset = replace'
where
replace' [] = return ()
replace' ((isOp,from,to):rest) =
let beforeChar = T.index match (max 0 (T.length match - (T.length from + 1)))
- beforeOk = not $if isOp
- then Set.member beforeChar notBeforeOp
- else Set.member beforeChar notBeforeId
+ beforeOk = not $ if isOp
+ then Set.member beforeChar notBeforeOp
+ else Set.member beforeChar notBeforeId
afterOk = case mbAfterChar of
Nothing -> True
Just afterChar ->
- not $if isOp
- then Set.member afterChar notAfterOp
- else Set.member afterChar notAfterId
+ not $ if isOp
+ then Set.member afterChar notAfterOp
+ else Set.member afterChar notAfterId
in if T.isSuffixOf from match && beforeOk && afterOk
then do
beginNotUndoableAction ebuf
- start <- getIterAtOffset ebuf (offset - (T.length from))
+ start <- getIterAtOffset ebuf (offset - T.length from)
end <- getIterAtOffset ebuf offset
delete ebuf start end
ins <- getIterAtMark ebuf cursorMark
@@ -135,29 +133,23 @@
mbChar <- getChar iter
case mbChar of
Nothing -> return True
- Just char -> return (not $if isOp
+ Just char -> return (not $ if isOp
then Set.member char notBeforeOp
else Set.member char notBeforeId)
- if beforeOk
- then do
- afterOk <- do
- endOff <- getOffset end
- iter <- getIterAtOffset buf endOff
- mbChar <- getChar iter
- case mbChar of
- Nothing -> return True
- Just char -> return (not $if isOp
- then Set.member char notAfterOp
- else Set.member char notAfterId)
- if afterOk
- then do
- delete buf st end
- insert buf st to
- return ()
- else do
- return ()
- else do
- return ()
+ when beforeOk $ do
+ afterOk <- do
+ endOff <- getOffset end
+ iter <- getIterAtOffset buf endOff
+ mbChar <- getChar iter
+ case mbChar of
+ Nothing -> return True
+ Just char -> return (not $ if isOp
+ then Set.member char notAfterOp
+ else Set.member char notAfterId)
+ when afterOk $ do
+ delete buf st end
+ insert buf st to
+ return ()
replaceTo' (stOff + 1)
transformFromCandy :: TextEditor editor => CandyTable -> EditorBuffer editor -> IDEM ()
@@ -183,8 +175,7 @@
mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack
i1 <- getStartIter workBuffer
i2 <- getEndIter workBuffer
- text2 <- getText workBuffer i1 i2 True
- return text2
+ getText workBuffer i1 i2 True
getCandylessPart :: TextEditor editor => CandyTable -> EditorBuffer editor -> EditorIter editor -> EditorIter editor -> IDEM Text
getCandylessPart (CT(_,transformTableBack)) ebuf i1 i2 = do
@@ -193,17 +184,15 @@
mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack
i1 <- getStartIter workBuffer
i2 <- getEndIter workBuffer
- text2 <- getText workBuffer i1 i2 True
- return text2
+ getText workBuffer i1 i2 True
stringToCandy :: CandyTable -> Text -> IDEM Text
stringToCandy candyTable text = do
workBuffer <- simpleGtkBuffer text
- transformToCandy candyTable workBuffer (\ _ -> False)
+ transformToCandy candyTable workBuffer (const False)
i1 <- getStartIter workBuffer
i2 <- getEndIter workBuffer
- text2 <- getText workBuffer i1 i2 True
- return text2
+ getText workBuffer i1 i2 True
-- We only need a TextMark here not a SourceMark
createTextMark (GtkBuffer sb) (GtkIter i) leftGravity = liftIO $ textBufferCreateMark sb Nothing i leftGravity
@@ -231,13 +220,13 @@
transformFromCandy candyTable workBuffer
i3 <- getIterAtOffset workBuffer column
mark <- createTextMark workBuffer i3 True
- transformToCandy candyTable workBuffer (\ _ -> False)
+ transformToCandy candyTable workBuffer (const False)
i4 <- getIterAtTextMark workBuffer mark
columnNew <- getLineOffset i4
return (line,columnNew)
replaceFrom :: TextEditor editor => EditorBuffer editor -> (Text,Text,Int) -> Int -> IDEM ()
-replaceFrom buf (to,from,spaces) offset = replaceFrom' offset
+replaceFrom buf (to,from,spaces) = replaceFrom'
where
replaceFrom' offset = do
iter <- getIterAtOffset buf offset
@@ -247,18 +236,14 @@
Just (st,end) -> do
offset <- getOffset st
delete buf st end
- if spaces > 0
- then do
- iter2 <- getIterAtOffset buf offset
- iter3 <- getIterAtOffset buf (offset + spaces + 1)
- slice <- getSlice buf iter2 iter3 True
- let l = T.length (T.takeWhile (== ' ') slice)
- if l > 1
- then do
- iter4 <- atOffset iter3 (offset + l - 1)
- delete buf iter2 iter4
- else return ()
- else return ()
+ when (spaces > 0) $ do
+ iter2 <- getIterAtOffset buf offset
+ iter3 <- getIterAtOffset buf (offset + spaces + 1)
+ slice <- getSlice buf iter2 iter3 True
+ let l = T.length (T.takeWhile (== ' ') slice)
+ when (l > 1) $ do
+ iter4 <- atOffset iter3 (offset + l - 1)
+ delete buf iter2 iter4
iter <- getIterAtOffset buf offset
insert buf iter to
replaceFrom' offset
@@ -266,7 +251,7 @@
type CandyTableI = [(Text,Char,Bool)]
forthFromTable :: CandyTableI -> CandyTableForth
-forthFromTable table = map forthFrom table
+forthFromTable = map forthFrom
where
forthFrom (str,chr,noTrimming) =
let isOp = not (Set.member (T.head str) notBeforeId)
@@ -276,7 +261,7 @@
in (isOp,from,to)
backFromTable :: CandyTableI -> CandyTableBack
-backFromTable table = map backFrom table
+backFromTable = map backFrom
where
backFrom (str,chr,noTrimming) =
let numTrailingBlanks = if noTrimming then 0 else T.length str - 1
diff --git a/src/IDE/SymbolNavigation.hs b/src/IDE/SymbolNavigation.hs
--- a/src/IDE/SymbolNavigation.hs
+++ b/src/IDE/SymbolNavigation.hs
@@ -70,9 +70,9 @@
underline linkTag UnderlineSingle
cursor <- liftIO $ cursorNew Hand2
- id1 <- liftIO $ sw `on` leaveNotifyEvent $ do
+ id1 <- liftIO (sw `on` leaveNotifyEvent $ do
eventTime >>= (liftIO . pointerUngrab)
- return True
+ return True)
let moveOrClick eventX eventY mods eventTime click = do
sx <- liftIO $ scrolledWindowGetHAdjustment sw >>= adjustmentGetValue
@@ -80,7 +80,7 @@
let ex = eventX + sx
ey = eventY + sy
- ctrlPressed = (mapControlCommand Control) `elem` mods
+ ctrlPressed = mapControlCommand Control `elem` mods
shiftPressed = Shift `elem` mods
iter <- getIterAtLocation sv (round ex) (round ey)
(Rectangle _ _ szx szy) <- liftIO $ widgetGetAllocation sw
@@ -94,13 +94,13 @@
removeTagByName tvb "link"
offs <- getLineOffset beg
offsc <- getLineOffset iter
- if (T.length slice > 1) then do
- if (click) then do
+ if T.length slice > 1 then
+ if click then do
liftIO $ pointerUngrab eventTime
clickHandler ctrlPressed shiftPressed slice
else do
applyTagByName tvb "link" beg en
- Just screen <- liftIO $ screenGetDefault
+ Just screen <- liftIO screenGetDefault
#ifdef MIN_VERSION_gtk3
mbDW <- liftIO $ widgetGetWindow tv
#else
@@ -117,42 +117,43 @@
return True
lineNumberBugFix <- liftIO $ newIORef Nothing
let fixBugWithX mods isHint (eventX, eventY) ptrx = do
- let hasNoControlModifier = not $ (mapControlCommand Control) `elem` mods
+ let hasNoControlModifier = mapControlCommand Control `notElem` mods
lnbf <- readIORef lineNumberBugFix
-- print ("ishint?, adjusted, event.x, ptr.x, adjustment,hasControl?",isHint,ptrx - fromMaybe (-1000) lnbf , eventX, ptrx, lnbf, hasNoControlModifier)
- when (isHint && hasNoControlModifier) $ do
+ when (isHint && hasNoControlModifier) $
-- get difference between event X and pointer x
-- event X is in coordinates of sourceView text
-- pointer X is in coordinates of window (remember "show line numbers" ?)
liftIO $ writeIORef lineNumberBugFix $ Just (ptrx - eventX) -- captured difference
-- When control key is pressed, mostly NON-HINT events come,
-- GTK gives (mistakenly?) X in window coordinates in such cases
- let nx = if (isJust lnbf && not isHint)
+ let nx = if isJust lnbf && not isHint
then ptrx - fromJust lnbf -- translate X back
else eventX
return (nx, eventY)
ideR <- ask
- id2 <- liftIO $ sw `on` motionNotifyEvent $ do
- isHint <- eventIsHint
- eventTime <- eventTime
- mods <- eventModifier
- (oldX, oldY) <- eventCoordinates
- (rootX, _) <- eventRootCoordinates
- (eventX, eventY) <- liftIO $ fixBugWithX mods isHint (oldX, oldY) rootX
- liftIO $ do
- -- print ("move adjustment: isHint, old, new root", isHint, eventX, oldX, rootX)
- (`reflectIDE` ideR) $ moveOrClick eventX eventY mods eventTime False
- return True
- id3 <- liftIO $ sw `on` buttonPressEvent $ do
- eventTime <- eventTime
- mods <- eventModifier
- -- liftIO $ print ("button press")
- (oldX, oldY) <- eventCoordinates
- (rootX, _) <- eventRootCoordinates
- (eventX, eventY) <- liftIO $ fixBugWithX mods False (oldX, oldY) rootX
- -- liftIO $ print ("click adjustment: old, new", eventX, oldX)
- liftIO $ (`reflectIDE` ideR) $ moveOrClick eventX eventY mods eventTime True
+ liftIO $ do
+ id2 <- sw `on` motionNotifyEvent $ do
+ isHint <- eventIsHint
+ eventTime <- eventTime
+ mods <- eventModifier
+ (oldX, oldY) <- eventCoordinates
+ (rootX, _) <- eventRootCoordinates
+ (eventX, eventY) <- liftIO $ fixBugWithX mods isHint (oldX, oldY) rootX
+ liftIO $
+ -- print ("move adjustment: isHint, old, new root", isHint, eventX, oldX, rootX)
+ (`reflectIDE` ideR) $ moveOrClick eventX eventY mods eventTime False
+ return True
+ id3 <- sw `on` buttonPressEvent $ do
+ eventTime <- eventTime
+ mods <- eventModifier
+ -- liftIO $ print ("button press")
+ (oldX, oldY) <- eventCoordinates
+ (rootX, _) <- eventRootCoordinates
+ (eventX, eventY) <- liftIO $ fixBugWithX mods False (oldX, oldY) rootX
+ -- liftIO $ print ("click adjustment: old, new", eventX, oldX)
+ liftIO $ (`reflectIDE` ideR) $ moveOrClick eventX eventY mods eventTime True
- return $ [ConnectC id1, ConnectC id2, ConnectC id3]
+ return [ConnectC id1, ConnectC id2, ConnectC id3]
diff --git a/src/IDE/TextEditor.hs b/src/IDE/TextEditor.hs
--- a/src/IDE/TextEditor.hs
+++ b/src/IDE/TextEditor.hs
@@ -14,10 +14,7 @@
-----------------------------------------------------------------------------
module IDE.TextEditor (
- module IDE.TextEditor.Class
- , module IDE.TextEditor.GtkSourceView
- , module IDE.TextEditor.Yi
- , module IDE.TextEditor.CodeMirror
+ module Exported
, TextEditor(..)
, EditorBuffer(..)
@@ -36,10 +33,10 @@
#endif
) where
-import IDE.TextEditor.Class
-import IDE.TextEditor.GtkSourceView
-import IDE.TextEditor.Yi
-import IDE.TextEditor.CodeMirror
+import IDE.TextEditor.Class as Exported
+import IDE.TextEditor.GtkSourceView as Exported
+import IDE.TextEditor.Yi as Exported
+import IDE.TextEditor.CodeMirror as Exported
newDefaultBuffer = newGtkBuffer
diff --git a/src/IDE/TextEditor/Class.hs b/src/IDE/TextEditor/Class.hs
--- a/src/IDE/TextEditor/Class.hs
+++ b/src/IDE/TextEditor/Class.hs
@@ -15,9 +15,13 @@
module IDE.TextEditor.Class (
TextEditor(..)
+ , EditorStyle(..)
+ , updateStyle
) where
-import IDE.Core.Types (IDERef, IDEM, IDEEventM)
+import IDE.Core.Types
+ (LogRefType, IDE(..), IDERef, IDEM, IDEEventM, EditorStyle(..),
+ IDEAction(..), editorStyle)
import Graphics.UI.Editor.Basics (Connection)
import Control.Monad.Reader (ReaderT(..))
import Graphics.UI.Gtk
@@ -29,7 +33,15 @@
import Control.Monad.IO.Class (MonadIO(..))
import System.Glib.Signals (on)
import Data.Text (Text)
+import IDE.Core.State (readIDE)
+import IDE.Utils.GUIUtils (getDarkState)
+updateStyle :: TextEditor editor => EditorBuffer editor -> IDEAction
+updateStyle ebuf = do
+ prefs <- readIDE prefs
+ preferDark <- getDarkState
+ setStyle ebuf $ editorStyle preferDark prefs
+
class TextEditor editor where
data EditorBuffer editor
data EditorView editor
@@ -50,10 +62,9 @@
canUndo :: EditorBuffer editor -> IDEM Bool
copyClipboard :: EditorBuffer editor -> Clipboard -> IDEM ()
createMark :: EditorView editor
- -> Text
+ -> LogRefType
-> EditorIter editor
-> Text
- -> Text
-> IDEM (EditorMark editor)
cutClipboard :: EditorBuffer editor -> Clipboard -> Bool -> IDEM ()
delete :: EditorBuffer editor -> EditorIter editor -> EditorIter editor -> IDEM ()
@@ -97,7 +108,7 @@
-> IDEM ()
selectRange :: EditorBuffer editor -> EditorIter editor -> EditorIter editor -> IDEM ()
setModified :: EditorBuffer editor -> Bool -> IDEM ()
- setStyle :: Bool -> EditorBuffer editor -> Maybe Text -> IDEM ()
+ setStyle :: EditorBuffer editor -> EditorStyle -> IDEM ()
setText :: EditorBuffer editor -> Text -> IDEM ()
undo :: EditorBuffer editor -> IDEM ()
diff --git a/src/IDE/TextEditor/CodeMirror.hs b/src/IDE/TextEditor/CodeMirror.hs
--- a/src/IDE/TextEditor/CodeMirror.hs
+++ b/src/IDE/TextEditor/CodeMirror.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
+#ifdef LEKSAH_WITH_CODE_MIRROR
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
+#endif
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
@@ -261,7 +263,7 @@
m <- codeMirror
lift $ (m ^. historySize ^. undo') >>= valToBool
copyClipboard (CMBuffer cm) _ = return () -- TODO
- createMark (CMView cm) _name (CMIter _ i) _icon _tooltip = runCM cm $ do
+ createMark (CMView cm) _refType (CMIter _ i) _tooltip = runCM cm $ do
m <- codeMirror
lift $ CMMark <$> do
o <- obj
@@ -349,7 +351,7 @@
setModified (CMBuffer cm) modified = unless modified . runCM cm $ do
m <- codeMirror
lift $ m ^. markClean >> return ()
- setStyle preferDark (CMBuffer cm) mbStyle = return () -- TODO
+ setStyle (CMBuffer cm) _style = return () -- TODO
setText (CMBuffer cm) text = runCM cm $ do
m <- codeMirror
lift $ m ^. setValue text
diff --git a/src/IDE/TextEditor/GtkSourceView.hs b/src/IDE/TextEditor/GtkSourceView.hs
--- a/src/IDE/TextEditor/GtkSourceView.hs
+++ b/src/IDE/TextEditor/GtkSourceView.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -30,8 +31,10 @@
) where
-import IDE.TextEditor.Class (TextEditor(..))
-import IDE.Core.Types (colorHexString, Prefs(..), IDE(..), IDEM)
+import IDE.TextEditor.Class (TextEditor(..), EditorStyle(..))
+import IDE.Core.Types
+ (LogRefType(..), LogRef(..), LogRefType, colorHexString, Prefs(..),
+ IDE(..), IDEM)
import Control.Monad.IO.Class (MonadIO(..))
import Graphics.UI.Gtk
(castToWidget, textViewGetIterAtLocation, focusOutEvent,
@@ -71,7 +74,8 @@
textBufferApplyTagByName, TextTag, TextTagTable, TextMark,
textBufferSetText, textIterCopy, TextIter, Modifier(..),
FontDescription, fontDescriptionFromString, fontDescriptionNew,
- fontDescriptionSetFamily, EventMask(..), after,
+ fontDescriptionSetFamily, EventMask(..), after, Underline(..),
+ Color(..),
#ifdef MIN_VERSION_gtk3
widgetGetWindow
#else
@@ -81,7 +85,8 @@
import Data.Typeable (Typeable)
import Control.Applicative ((<$>))
import Graphics.UI.Gtk.SourceView
- (sourceBufferCreateSourceMark, SourceMark,
+ (sourceBufferRemoveSourceMarks, sourceViewGetMarkAttributes,
+ sourceBufferCreateSourceMark, SourceMark,
sourceViewSetShowLineMarks,
sourceStyleSchemeManagerAppendSearchPath, sourceViewSetTabWidth,
sourceViewSetShowLineNumbers, sourceViewSetRightMarginPosition,
@@ -107,29 +112,33 @@
(SourceDrawSpacesFlags(..), SourceSmartHomeEndType(..))
import Graphics.UI.Gtk.General.Enums
(PolicyType(..), TextWindowType(..), WrapMode(..))
-import Control.Monad (when, forM_)
+import Control.Monad (void, when, forM_)
import Control.Monad.Reader.Class (MonadReader(..))
import Graphics.UI.Editor.Basics (Connection(..))
-import Data.Maybe (maybeToList, fromJust)
+import Data.Maybe (isNothing, maybeToList, fromJust)
import Data.IORef (writeIORef, readIORef, newIORef)
import System.Glib.MainLoop (priorityDefault, idleRemove)
-import Data.Char (isSymbol, isAlphaNum)
+import Data.Char (isDigit, isSymbol, isAlphaNum)
import System.Glib.Signals (after, on)
import Control.Monad.Trans.Class (MonadTrans(..))
import System.Glib.Attributes (get, AttrOp(..), set)
import qualified Graphics.UI.Gtk as Gtk (endUserAction)
import IDE.Utils.GUIUtils (fontDescription)
import Data.Text (Text)
-import qualified Data.Text as T (all, length, pack)
+import qualified Data.Text as T
+ (drop, dropWhile, all, length, pack)
import Data.Monoid ((<>))
import Graphics.UI.Gtk.Multiline.TextBuffer
- (textBufferDeleteMark, textBufferGetMark)
+ (textBufferDeleteMarkByName, textBufferDeleteMark,
+ textBufferGetMark)
import Graphics.UI.Gtk.SourceView.SourceMarkAttributes
(queryTooltipText, sourceMarkAttributesSetIconName,
sourceMarkAttributesNew)
import Graphics.UI.Gtk.SourceView.SourceView
(sourceViewSetMarkAttributes)
-import Graphics.UI.Gtk.Multiline.TextMark (toTextMark)
+import Graphics.UI.Gtk.Multiline.TextMark
+ (textMarkGetName, toTextMark)
+import Control.Arrow (Arrow(..))
transformGtkIter :: EditorIter GtkSourceView -> (TextIter -> IO a) -> IDEM (EditorIter GtkSourceView)
transformGtkIter (GtkIter i) f = do
@@ -171,6 +180,9 @@
sourceBufferBeginNotUndoableAction buffer
textBufferSetText buffer contents
sourceBufferEndNotUndoableAction buffer
+ tagTable <- textBufferGetTagTable buffer
+ forM_ [minBound .. maxBound :: LogRefType] $ \ refType ->
+ textTagNew (Just . T.pack $ show refType) >>= textTagTableAdd tagTable
return $ GtkBuffer buffer
instance TextEditor GtkSourceView where
@@ -189,18 +201,15 @@
canRedo (GtkBuffer sb) = liftIO $ sourceBufferGetCanRedo sb
canUndo (GtkBuffer sb) = liftIO $ sourceBufferGetCanUndo sb
copyClipboard (GtkBuffer sb) clipboard = liftIO $ textBufferCopyClipboard sb clipboard
- createMark (GtkView sv) name (GtkIter i) icon tooltip = liftIO $ do
- attributes <- sourceMarkAttributesNew
- sourceMarkAttributesSetIconName attributes (Just icon)
- on attributes queryTooltipText $ \ mark -> return tooltip
- sourceViewSetMarkAttributes sv name (Just attributes) 1
+ createMark (GtkView sv) refType (GtkIter i) tooltip = liftIO $ do
+ let cat = T.pack $ show refType
sb <- castToSourceBuffer <$> get sv textViewBuffer
- GtkMark . toTextMark <$> sourceBufferCreateSourceMark sb (Just name) name i
+ n <- textIterGetLine i
+ GtkMark . toTextMark <$> sourceBufferCreateSourceMark sb (Just $ T.pack (show n) <> " " <> tooltip) cat i
cutClipboard (GtkBuffer sb) clipboard defaultEditable = liftIO $ textBufferCutClipboard sb clipboard defaultEditable
delete (GtkBuffer sb) (GtkIter first) (GtkIter last) = liftIO $
textBufferDelete sb first last
- deleteSelection (GtkBuffer sb) = liftIO $
- textBufferDeleteSelection sb True True >> return ()
+ deleteSelection (GtkBuffer sb) = liftIO . void $ textBufferDeleteSelection sb True True
endNotUndoableAction (GtkBuffer sb) = liftIO $ sourceBufferEndNotUndoableAction sb
endUserAction (GtkBuffer sb) = liftIO $ textBufferEndUserAction sb
getEndIter (GtkBuffer sb) = liftIO $ GtkIter <$> textBufferGetEndIter sb
@@ -211,7 +220,7 @@
getLineCount (GtkBuffer sb) = liftIO $ textBufferGetLineCount sb
getModified (GtkBuffer sb) = liftIO $ textBufferGetModified sb
getSelectionBoundMark (GtkBuffer sb) = liftIO $ GtkMark <$> textBufferGetSelectionBound sb
- getSelectionBounds (GtkBuffer sb) = liftIO $ (\(a, b) -> (GtkIter a, GtkIter b)) <$>
+ getSelectionBounds (GtkBuffer sb) = liftIO $ (GtkIter *** GtkIter) <$>
textBufferGetSelectionBounds sb
getInsertIter (GtkBuffer sb) = liftIO $ GtkIter <$> do
insertMark <- textBufferGetInsert sb
@@ -235,6 +244,19 @@
sourceViewSetAutoIndent sv True
sourceViewSetSmartHomeEnd sv SourceSmartHomeEndBefore
sourceViewSetShowLineMarks sv True
+ forM_ [minBound..maxBound] $ \ refType -> do
+ let cat = T.pack $ show refType
+ icon = case refType of
+ ErrorRef -> "dialog-error"
+ WarningRef -> "dialog-warning"
+ TestFailureRef -> "software-update-urgent"
+ LintRef -> "emblem-generic"
+ BreakpointRef -> "media-playback-pause"
+ ContextRef -> "media-playback-start"
+ attributes <- sourceMarkAttributesNew
+ sourceMarkAttributesSetIconName attributes (Just (icon :: Text))
+ on attributes queryTooltipText $ \ mark -> maybe "" (T.drop 1 . T.dropWhile isDigit) <$> textMarkGetName mark
+ sourceViewSetMarkAttributes sv cat (Just attributes) (1 + fromEnum(maxBound :: LogRefType) - fromEnum refType)
if wrapLines prefs
then textViewSetWrapMode sv WrapWord
else textViewSetWrapMode sv WrapNone
@@ -250,25 +272,38 @@
first <- textBufferGetStartIter sb
last <- textBufferGetEndIter sb
textBufferRemoveTagByName sb name first last
- mbMark <- textBufferGetMark sb name
- case mbMark of
- Just mark -> textBufferDeleteMark sb mark
- Nothing -> return ()
+ sourceBufferRemoveSourceMarks sb first last name
selectRange (GtkBuffer sb) (GtkIter first) (GtkIter last) = liftIO $
textBufferSelectRange sb first last
- setModified (GtkBuffer sb) modified = liftIO $ textBufferSetModified sb modified >> return ()
- setStyle preferDark (GtkBuffer sb) mbStyle = liftIO $ do
- case mbStyle of
+ setModified (GtkBuffer sb) modified = liftIO . void $ textBufferSetModified sb modified
+ setStyle (GtkBuffer sb) EditorStyle {..} =
+ case styleName of
Nothing -> return ()
Just str -> do
- styleManager <- sourceStyleSchemeManagerNew
- dataDir <- getDataDir
- sourceStyleSchemeManagerAppendSearchPath styleManager $ dataDir "data/styles"
- ids <- sourceStyleSchemeManagerGetSchemeIds styleManager
+ styleManager <- liftIO sourceStyleSchemeManagerNew
+ dataDir <- liftIO getDataDir
+ liftIO $ sourceStyleSchemeManagerAppendSearchPath styleManager $ dataDir "data/styles"
+ ids <- liftIO $ sourceStyleSchemeManagerGetSchemeIds styleManager
let preferedNames = if preferDark then [str<>"-dark", str] else [str]
- forM_ (take 1 $ filter (flip elem ids) preferedNames) $ \ name -> do
- scheme <- sourceStyleSchemeManagerGetScheme styleManager name
- sourceBufferSetStyleScheme sb (Just scheme)
+ forM_ (take 1 $ filter (`elem` ids) preferedNames) $ \ name -> do
+ liftIO $ do
+ scheme <- sourceStyleSchemeManagerGetScheme styleManager name
+ sourceBufferSetStyleScheme sb (Just scheme)
+ tagTable <- getTagTable (GtkBuffer sb)
+ let isDark = name `elem` ["leksah-dark", "oblivion", "cobalt"]
+ forM_ [minBound .. maxBound] $ \ refType -> do
+ mbTag <- lookupTag tagTable (T.pack $ show refType)
+ case mbTag of
+ Nothing -> return ()
+ Just tag ->
+ case refType of
+ ErrorRef -> underline tag UnderlineError
+ WarningRef -> underline tag UnderlineError
+ TestFailureRef -> underline tag UnderlineError
+ LintRef | isDark -> background tag $ Color 0 15000 0
+ | otherwise -> background tag $ Color 60000 65535 60000
+ BreakpointRef -> background tag breakpointBG
+ ContextRef -> background tag contextBG
setText (GtkBuffer sb) text = liftIO $ textBufferSetText sb text
undo (GtkBuffer sb) = liftIO $ sourceBufferUndo sb
@@ -290,11 +325,11 @@
getIterAtLocation (GtkView sv) x y = liftIO $ GtkIter <$> textViewGetIterAtLocation sv x y
getIterLocation (GtkView sv) (GtkIter i) = liftIO $ textViewGetIterLocation sv i
getOverwrite (GtkView sv) = liftIO $ textViewGetOverwrite sv
- getScrolledWindow (GtkView sv) = liftIO $ fmap (castToScrolledWindow . fromJust) $ widgetGetParent sv
+ getScrolledWindow (GtkView sv) = liftIO $ (castToScrolledWindow . fromJust) <$> widgetGetParent sv
getEditorWidget (GtkView sv) = return $ castToWidget sv
grabFocus (GtkView sv) = liftIO $ widgetGrabFocus sv
scrollToMark (GtkView sv) (GtkMark m) withMargin mbAlign = liftIO $ textViewScrollToMark sv m withMargin mbAlign
- scrollToIter (GtkView sv) (GtkIter i) withMargin mbAlign = liftIO $ textViewScrollToIter sv i withMargin mbAlign >> return ()
+ scrollToIter (GtkView sv) (GtkIter i) withMargin mbAlign = liftIO . void $ textViewScrollToIter sv i withMargin mbAlign
setFont (GtkView sv) mbFontString = do
fd <- fontDescription mbFontString
liftIO $ widgetModifyFont sv (Just fd)
@@ -308,7 +343,7 @@
else liftIO $ do
textViewSetWrapMode sv WrapNone
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
- setRightMargin (GtkView sv) mbRightMargin = liftIO $ do
+ setRightMargin (GtkView sv) mbRightMargin = liftIO $
case mbRightMargin of
Just n -> do
sourceViewSetShowRightMargin sv True
@@ -354,26 +389,26 @@
lastHandler <- newIORef Nothing
id1 <- after sb bufferInsertText $ \iter text -> do
mapM_ idleRemove =<< maybeToList <$> readIORef lastHandler
- writeIORef lastHandler =<< Just <$> do
- (flip idleAdd) priorityDefault $ do
- let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.'
- let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'
- || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'
- if (T.all isIdent text) || (T.all isOp text)
- then do
- hasSel <- textBufferHasSelection sb
- if not hasSel
- then do
- (iterC, _) <- textBufferGetSelectionBounds sb
- atC <- textIterEqual iter iterC
- when atC $ reflectIDE start ideR
- return False
- else do
- reflectIDE cancel ideR
- return False
- else do
- reflectIDE cancel ideR
- return False
+ h <- flip idleAdd priorityDefault $ do
+ let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.'
+ let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'
+ || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'
+ if T.all isIdent text || T.all isOp text
+ then do
+ hasSel <- textBufferHasSelection sb
+ if not hasSel
+ then do
+ (iterC, _) <- textBufferGetSelectionBounds sb
+ atC <- textIterEqual iter iterC
+ when atC $ reflectIDE start ideR
+ return False
+ else do
+ reflectIDE cancel ideR
+ return False
+ else do
+ reflectIDE cancel ideR
+ return False
+ writeIORef lastHandler (Just h)
return ()
id2 <- sv `on` moveCursor $ \_ _ _ -> reflectIDE cancel ideR
id3 <- sv `on` buttonPressEvent $ lift $ reflectIDE cancel ideR >> return False
@@ -394,7 +429,7 @@
onLookupInfo (GtkView sv) f = do
liftIO $ sv `widgetAddEvents` [ButtonReleaseMask]
id1 <- sv `onIDE` buttonReleaseEvent $ do
- mod <- lift $ eventModifier
+ mod <- lift eventModifier
case mod of
[Control] -> f >> return True
_ -> return False
@@ -430,7 +465,7 @@
case mbLimit of
Just (GtkIter limit) -> Just limit
Nothing -> Nothing
- forwardSearch (GtkIter i) str flags mbLimit = liftIO $ fmap (fmap (\(a, b) -> (GtkIter a, GtkIter b))) $
+ forwardSearch (GtkIter i) str flags mbLimit = liftIO $ fmap (fmap (GtkIter *** GtkIter)) $
textIterForwardSearch i str flags $
case mbLimit of
Just (GtkIter limit) -> Just limit
diff --git a/src/IDE/Utils/GUIUtils.hs b/src/IDE/Utils/GUIUtils.hs
--- a/src/IDE/Utils/GUIUtils.hs
+++ b/src/IDE/Utils/GUIUtils.hs
@@ -75,14 +75,14 @@
chooseDir :: Window -> Text -> Maybe FilePath -> IO (Maybe FilePath)
chooseDir window prompt mbFolder = do
dialog <- fileChooserDialogNew
- (Just $ prompt)
+ (Just prompt)
(Just window)
FileChooserActionSelectFolder
[("gtk-cancel"
,ResponseCancel)
,("gtk-open"
,ResponseAccept)]
- when (isJust mbFolder) $ fileChooserSetCurrentFolder dialog (fromJust mbFolder) >> return ()
+ when (isJust mbFolder) . void $ fileChooserSetCurrentFolder dialog (fromJust mbFolder)
widgetShow dialog
response <- dialogRun dialog
case response of
@@ -101,14 +101,14 @@
chooseFile :: Window -> Text -> Maybe FilePath -> IO (Maybe FilePath)
chooseFile window prompt mbFolder = do
dialog <- fileChooserDialogNew
- (Just $ prompt)
+ (Just prompt)
(Just window)
FileChooserActionOpen
[("gtk-cancel"
,ResponseCancel)
,("gtk-open"
,ResponseAccept)]
- when (isJust mbFolder) $ fileChooserSetCurrentFolder dialog (fromJust mbFolder) >> return ()
+ when (isJust mbFolder) $ void (fileChooserSetCurrentFolder dialog (fromJust mbFolder))
widgetShow dialog
response <- dialogRun dialog
case response of
@@ -127,12 +127,12 @@
chooseSaveFile :: Window -> Text -> Maybe FilePath -> IO (Maybe FilePath)
chooseSaveFile window prompt mbFolder = do
dialog <- fileChooserDialogNew
- (Just $ prompt)
+ (Just prompt)
(Just window)
FileChooserActionSave
[("gtk-cancel", ResponseCancel)
,("gtk-save", ResponseAccept)]
- when (isJust mbFolder) $ fileChooserSetCurrentFolder dialog (fromJust mbFolder) >> return ()
+ when (isJust mbFolder) $ void (fileChooserSetCurrentFolder dialog (fromJust mbFolder))
widgetShow dialog
res <- dialogRun dialog
case res of
@@ -198,7 +198,7 @@
ui <- getUIAction "ui/menubar/_View/Dark" castToToggleAction
liftIO $toggleActionSetActive ui b
-getForgetSession :: PaneMonad alpha => alpha (Bool)
+getForgetSession :: PaneMonad alpha => alpha Bool
getForgetSession = do
ui <- getUIAction "ui/menubar/_Configuration/Forget Session" castToToggleAction
liftIO $toggleActionGetActive ui
@@ -211,7 +211,7 @@
Nothing -> throwIDE ("State.hs>>getMenuItem: Can't find ui path " <> path)
Just widget -> return (castToMenuItem widget)
-getBackgroundBuildToggled :: PaneMonad alpha => alpha (Bool)
+getBackgroundBuildToggled :: PaneMonad alpha => alpha Bool
getBackgroundBuildToggled = do
ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction
liftIO $ toggleActionGetActive ui
@@ -221,7 +221,7 @@
ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction
liftIO $ toggleActionSetActive ui b
-getRunUnitTests :: PaneMonad alpha => alpha (Bool)
+getRunUnitTests :: PaneMonad alpha => alpha Bool
getRunUnitTests = do
ui <- getUIAction "ui/toolbar/BuildToolItems/RunUnitTests" castToToggleAction
liftIO $ toggleActionGetActive ui
@@ -231,7 +231,7 @@
ui <- getUIAction "ui/toolbar/BuildToolItems/RunUnitTests" castToToggleAction
liftIO $ toggleActionSetActive ui b
-getMakeModeToggled :: PaneMonad alpha => alpha (Bool)
+getMakeModeToggled :: PaneMonad alpha => alpha Bool
getMakeModeToggled = do
ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" castToToggleAction
liftIO $ toggleActionGetActive ui
@@ -241,7 +241,7 @@
ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" castToToggleAction
liftIO $ toggleActionSetActive ui b
-getDebugToggled :: PaneMonad alpha => alpha (Bool)
+getDebugToggled :: PaneMonad alpha => alpha Bool
getDebugToggled = do
ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction
liftIO $ toggleActionGetActive ui
@@ -325,9 +325,9 @@
#endif
fontDescription :: Maybe Text -> IDEM FontDescription
-fontDescription mbFontString = liftIO $ do
+fontDescription mbFontString = liftIO $
case mbFontString of
- Just str -> do
+ Just str ->
fontDescriptionFromString str
Nothing -> do
f <- fontDescriptionNew
diff --git a/src/IDE/Utils/ServerConnection.hs b/src/IDE/Utils/ServerConnection.hs
--- a/src/IDE/Utils/ServerConnection.hs
+++ b/src/IDE/Utils/ServerConnection.hs
@@ -42,11 +42,11 @@
q <- case q' of
Just q -> return q
Nothing -> do
- q <- liftIO $ newEmptyMVar
+ q <- liftIO newEmptyMVar
modifyIDE_ (\ ide -> ide{serverQueue = Just q})
ideR <- ask
liftIO . forkIO . forever $ do
- debugM "leksah" $ "Ready for command"
+ debugM "leksah" "Ready for command"
(command, cont) <- takeMVar q
reflectIDE (doServerCommand' command cont) ideR
return q