leksah 0.15.1.0 → 0.15.1.1

raw patch · 21 files changed

+265/−136 lines, 21 filesdep ~gtk3-mac-integrationdep ~leksahdep ~leksah-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: gtk3-mac-integration, leksah, leksah-server, ltk

API changes (from Hackage documentation)

Files

• Readme.md +1/−1
• leksah.cabal +7/−7
• osx/makedmgs.sh +3/−0
• scripts/clean.sh +0/−10
• src/IDE/Command.hs +1/−1
• src/IDE/Core/State.hs +4/−4
• src/IDE/Core/Types.hs +2/−2
• src/IDE/Debug.hs +4/−3
• src/IDE/HLint.hs +16/−14
• src/IDE/ImportTool.hs +11/−8
• src/IDE/Leksah.hs +15/−10
• src/IDE/LogRef.hs +4/−4
• src/IDE/OSX.hs +3/−0
• src/IDE/Package.hs +38/−13
• src/IDE/Pane/Errors.hs +19/−8
• src/IDE/Pane/SourceBuffer.hs +68/−27
• src/IDE/Session.hs +1/−1
• src/IDE/TextEditor/Class.hs +1/−1
• src/IDE/TextEditor/CodeMirror.hs +2/−1
• src/IDE/TextEditor/GtkSourceView.hs +5/−2
• src/IDE/Utils/ExternalTool.hs +60/−19

@@ -50,7 +50,7 @@  Use MacPorts to install GHC and the C libraries needed by Leksah (this will take a long time):      -    sudo port install ghc gtk3 webkit-gtk3 gtksourceview3 gtk-osx-application adwaita-icon-theme+    sudo port install ghc gtk3 webkit-gtk3 gtksourceview3 gtk-osx-application-gtk3 adwaita-icon-theme  Update Cabal and cabal-install 

@@ -1,5 +1,5 @@ name: leksah-version: 0.15.1.0+version: 0.15.1.1 cabal-version: >=1.18 build-type: Simple license: GPL@@ -208,7 +208,7 @@      if os(osx)         build-depends:-            gtk3-mac-integration >=0.3.0.0 && <0.4+            gtk3-mac-integration >=0.3.1.0 && <0.4      if flag(yi)         build-depends:@@ -333,11 +333,11 @@         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,+        ltk >=0.15.0.2 && <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.4 && <0.16,+        leksah-server >=0.15.0.6 && <0.16,         ghc >=6.10.1 && <7.11,         strict >=0.3.2 && <0.4,         conduit >=1.0.8 && <1.3,@@ -389,7 +389,7 @@         ghc-options: -optl-headerpad_max_install_names     main-is: Main.hs     build-depends:-        leksah ==0.15.1.0,+        leksah ==0.15.1.1,         base >=4.0.0.0 && <=4.9,         gtk3 >=0.13.9 && <0.14,         stm >=2.4.4 && <2.5@@ -400,7 +400,7 @@ executable bewleksah     main-is: Main.hs     build-depends:-        leksah ==0.15.1.0,+        leksah ==0.15.1.1,         base >=4.0.0.0 && <=4.9,         jsaddle -any,         ghcjs-dom -any,@@ -424,7 +424,7 @@         base >=4.0.0.0 && <4.9,         Cabal >=1.10.2.0 && <1.23,         QuickCheck >=2.4.2 && <2.9,-        leksah ==0.15.1.0,+        leksah ==0.15.1.1,         containers -any,         ltk -any,         leksah-server -any,

@@ -7,3 +7,6 @@ scripts/clean.sh osx/makedmg.sh +scp osx/leksah-0.15.1.1-ghc-7.8.3.dmg server:.+scp osx/leksah-0.15.1.1-ghc-7.10.1.dmg server:.+

@@ -10,18 +10,8 @@ ghc-pkg$GHCVERSION unregister --force jsaddle || true ghc-pkg$GHCVERSION unregister --force gtksourceview2 || true ghc-pkg$GHCVERSION unregister --force gtksourceview3 || true-ghc-pkg$GHCVERSION unregister --force webkit-javascriptcore || true-ghc-pkg$GHCVERSION unregister --force webkitgtk3-javascriptcore || true-ghc-pkg$GHCVERSION unregister --force webkit || true-ghc-pkg$GHCVERSION unregister --force webkitgtk3 || true ghc-pkg$GHCVERSION unregister --force gtk-mac-integration || true ghc-pkg$GHCVERSION unregister --force gtk3-mac-integration || true-ghc-pkg$GHCVERSION unregister --force gtk || true-ghc-pkg$GHCVERSION unregister --force gtk3 || true-ghc-pkg$GHCVERSION unregister --force pango || true-ghc-pkg$GHCVERSION unregister --force cairo || true-ghc-pkg$GHCVERSION unregister --force gio || true-ghc-pkg$GHCVERSION unregister --force glib || true ghc-pkg$GHCVERSION unregister --force hlint || true  rm -rf vendor/*/dist \

@@ -918,7 +918,7 @@     registerEvent stRef "VariablesChanged"         (\ e@VariablesChanged     -> fillVariablesListQuiet >> return e)     registerEvent stRef "ErrorChanged"-        (\ e@ErrorChanged         -> postAsyncIDE fillErrorList >> return e)+        (\ e@(ErrorChanged show') -> postAsyncIDE (fillErrorList show') >> return e)     registerEvent stRef "CurrentErrorChanged"         (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do             selectRef mbLogRef

@@ -313,16 +313,16 @@ liftYi :: Yi.YiM a -> IDEM a liftYi = liftYiControl . Yi.liftYi -catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a+catchIDE :: (MonadIDE m, Exception e) => IDEM a -> (e -> IO a) -> m a catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler) -forkIDE :: IDEAction  -> IDEAction+forkIDE :: MonadIDE m => IDEAction  -> m () forkIDE block  = reifyIDE (void . forkIO . reflectIDE block) -postSyncIDE :: IDEM a -> IDEM a+postSyncIDE :: MonadIDE m => IDEM a -> m a postSyncIDE f = reifyIDE (postGUISync . reflectIDE f) -postAsyncIDE :: IDEM () -> IDEM ()+postAsyncIDE :: MonadIDE m => IDEM () -> m () postAsyncIDE f = reifyIDE (postGUIAsync . reflectIDE f)  onIDE obj signal callback = do

@@ -288,7 +288,7 @@     |   SaveSession FilePath     |   UpdateRecent     |   VariablesChanged-    |   ErrorChanged+    |   ErrorChanged Bool     |   CurrentErrorChanged (Maybe LogRef)     |   BreakpointChanged     |   CurrentBreakChanged (Maybe LogRef)@@ -314,7 +314,7 @@     getSelector (SaveSession _)         =   "SaveSession"     getSelector UpdateRecent            =   "UpdateRecent"     getSelector VariablesChanged        =   "VariablesChanged"-    getSelector ErrorChanged            =   "ErrorChanged"+    getSelector (ErrorChanged _)        =   "ErrorChanged"     getSelector (CurrentErrorChanged _) =   "CurrentErrorChanged"     getSelector BreakpointChanged       =   "BreakpointChanged"     getSelector (CurrentBreakChanged _) =   "CurrentBreakChanged"

@@ -74,7 +74,7 @@ import IDE.Metainfo.Provider (getActivePackageDescr) import Distribution.Text (display) import IDE.Pane.Log-import Data.List (stripPrefix, isSuffixOf)+import Data.List (intersperse, stripPrefix, isSuffixOf) import IDE.Utils.GUIUtils (getDebugToggled) import IDE.Package (debugStart, executeDebugCommand, tryDebug, printBindResultFlag,         breakOnErrorFlag, breakOnExceptionFlag, printEvldWithShowFlag)@@ -90,7 +90,8 @@ import Data.Monoid ((<>), Monoid(..)) import Data.Text (Text) import qualified Data.Text as T-       (pack, lines, stripPrefix, unlines, isSuffixOf, unpack)+       (concat, intersperse, pack, lines, stripPrefix, unlines,+        isSuffixOf, unpack) import System.Exit (ExitCode(..)) import IDE.Pane.WebKit.Output (loadOutputUri) @@ -134,7 +135,7 @@ -- -- > stripComments "-- This is still a comment" stripComments :: Text -> Text-stripComments t = maybe t T.unlines $+stripComments t = maybe t (T.concat . intersperse "\n") $         mapM (T.stripPrefix "-- >>>") lines'     <|> mapM (T.stripPrefix "-- >") lines'   where

@@ -51,13 +51,13 @@        (defaultCpphsOptions, runCpphsReturningSymTab, CpphsOptions(..)) import System.Log.Logger (debugM) import Data.Monoid ((<>))-import Data.List (intercalate, find)+import Data.List (sortBy, intercalate, find) import qualified Data.Map as M (keys, lookup) import qualified Data.Text as T        (replicate, init, unlines, reverse, take, drop, lines, unpack,         pack) import Control.Exception (SomeException(..))-import Data.Maybe (mapMaybe, catMaybes)+import Data.Maybe (isJust, mapMaybe, catMaybes) import Distribution.Package (PackageIdentifier(..)) import Distribution.ModuleName (ModuleName) import IDE.Core.CTypes@@ -68,13 +68,14 @@        (SrcLoc(..), SrcSpan(..)) import IDE.Pane.SourceBuffer        (useCandyFor, selectSourceBuf, fileSave, inActiveBufContext,-        addLogRef, belongsToPackage, removeLogRefs)+        addLogRef, belongsToPackage, removeLintLogRefs) import qualified Data.Text.IO as T (readFile) import Data.Text (Text) import IDE.TextEditor (TextEditor(..)) import IDE.SourceCandy        (getCandylessPart, positionToCandy, stringToCandy) import IDE.BufferMode (editInsertCode)+import Data.Ord (comparing)  packageHLint :: PackageAction packageHLint = asks ipdCabalFile >>= (lift . lift . scheduleHLint . Left)@@ -108,8 +109,8 @@ runHLint (Right sourceFile) = do     liftIO . debugM "leksah" $ "runHLint"     packages <- maybe [] wsAllPackages <$> readIDE workspace-    case find (belongsToPackage sourceFile) packages of-        Just package -> runHLint' package (Just sourceFile)+    case reverse . (sortBy $ comparing (length . ipdBuildDir)) $ filter (belongsToPackage sourceFile) packages of+        (package:_) -> runHLint' package (Just sourceFile)         _ -> liftIO . debugM "leksah" $ "runHLint package not found for " <> sourceFile runHLint (Left cabalFile) = do     liftIO . debugM "leksah" $ "runHLint"@@ -129,12 +130,12 @@                     Nothing -> getSourcePaths (ipdPackageId package) modules     res <- forM paths $ \ full -> do         let file = makeRelative (ipdBuildDir package) full-        postSyncIDE $ removeLogRefs [LintRef] (ipdBuildDir package) file+        postSyncIDE $ removeLintLogRefs (ipdBuildDir package) file         text <- liftIO $ T.readFile full         liftIO . debugM "leksah" $ "runHLint parsing " <> full         do result <- liftIO $ parseModuleEx flags full (Just (T.unpack text))            case result of-                Left e -> logHLintError package e >> return Nothing+                Left e -> logHLintError (isJust mbSourceFile) package e >> return Nothing                 Right r -> do                     liftIO . debugM "leksah" $ "runHLint parsed " <> full                     return $ Just (r, (full, text))@@ -146,7 +147,7 @@         ideas = map fst results         texts = map snd results         getText f = maybe "" snd $ find (equalFilePath f . fst) texts-    logHLintResult package (applyHints classify hint ideas) getText+    logHLintResult (isJust mbSourceFile) package (applyHints classify hint ideas) getText   getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath]@@ -183,8 +184,8 @@     liftIO . debugM "leksah" $ "hlintSettings defines = " <> show defines     return (flags, classify, hint) -logHLintResult :: IDEPackage -> [Idea] -> (FilePath -> Text) -> IDEAction-logHLintResult package allIdeas getText = do+logHLintResult :: Bool -> IDEPackage -> [Idea] -> (FilePath -> Text) -> IDEAction+logHLintResult fileScope package allIdeas getText = do     let ideas = filter (\Idea{..} -> ideaSeverity /= Ignore) allIdeas     forM_ ideas $ \ idea@Idea{..} -> do         let text = getText (HSE.srcSpanFilename ideaSpan)@@ -204,11 +205,11 @@                  . T.unlines . fixHead . reverse . fixTail $ reverse fromLines             ref = LogRef srcSpan package (T.pack $ showHLint idea)                     (Just (from, idea)) Nothing LintRef-        postSyncIDE $ addLogRef ref+        postSyncIDE $ addLogRef fileScope fileScope ref     return () -logHLintError :: IDEPackage -> ParseError -> IDEAction-logHLintError package error = do+logHLintError :: Bool -> IDEPackage -> ParseError -> IDEAction+logHLintError fileScope package error = do     let loc = parseErrorLocation error         srcSpan = SrcSpan (makeRelative (ipdBuildDir package) $ HSE.srcFilename loc)                           (HSE.srcLine loc)@@ -216,7 +217,7 @@                           (HSE.srcLine loc)                           (HSE.srcColumn loc - 1)         ref = LogRef srcSpan package ("Hlint Parse Error: " <> T.pack (parseErrorMessage error)) Nothing Nothing LintRef-    postSyncIDE $ addLogRef ref+    postSyncIDE $ addLogRef fileScope fileScope ref  -- Cut down version of showEx from HLint showHLint :: Idea -> String@@ -236,6 +237,7 @@  resolveActiveHLint :: IDEM Bool resolveActiveHLint = inActiveBufContext False  $ \_ _ ebuf _ _ -> do+    liftIO $ debugM "leksah" "resolveActiveHLint"     allLogRefs <- readIDE allLogRefs     (iStart, iEnd) <- getSelectionBounds ebuf     lStart <- getLine iStart

@@ -76,6 +76,7 @@ import Language.Haskell.Exts (KnownExtension) import Data.Text (Text) import Data.Monoid ((<>))+import System.Log.Logger (debugM)  readMaybe :: Read a => Text -> Maybe a readMaybe s = case reads $ T.unpack s of@@ -85,6 +86,7 @@ -- | Add all imports which gave error messages ... resolveErrors :: IDEAction resolveErrors = do+    liftIO $ debugM "leksah" "resolveErrors"     prefs' <- readIDE prefs     let buildInBackground = backgroundBuild prefs'     when buildInBackground $@@ -99,12 +101,9 @@             nubBy (\ (p1,_) (p2,_) -> p1 == p2)                   [(x,y) |  (x,y) <- [((parsePerhapsYouIntendedToUse . refDescription) e, e) | e <- errors]],                                 length x == 1]-    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+    addAll addPackageResults buildInBackground notInScopes extensions   where-    addAll buildInBackground notInScopes extensions = addAllImports notInScopes (True,[])+    addAll addPackageResults buildInBackground notInScopes extensions = addAllImports notInScopes (True,[])       where         addAllImports :: [LogRef] -> (Bool,[Descr]) -> IDEM ()         addAllImports (errorSpec:rest) (True,descrList)  =  addImport errorSpec descrList (addAllImports rest)@@ -114,9 +113,13 @@         addAllExtensions (errorSpec:rest) True =  addExtension errorSpec (addAllExtensions rest)         addAllExtensions _ _                   =  finally -        finally = when buildInBackground $ do-            prefs' <- readIDE prefs-            modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}})+        finally = do+            when buildInBackground $ do+                prefs' <- readIDE prefs+                modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}})+            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"  -- | Add import for current error ... addOneImport :: IDEAction

@@ -214,11 +214,13 @@ startGUI :: Yi.Config -> FilePath -> Maybe FilePath -> [FilePath] -> Prefs -> Bool -> IO () startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs iprefs isFirstStart =   Yi.start yiConfig $ \yiControl -> do-    st          <-  unsafeInitGUIForThreadedRTS-    when rtsSupportsBoundThreads $ do-        setNumCapabilities 2-        sysMessage Normal "Linked with -threaded"-    timeout <- timeoutAddFull (yield >> return True) priorityLow 10+    st       <- unsafeInitGUIForThreadedRTS+    timeout  <- if rtsSupportsBoundThreads+                    then do+                        setNumCapabilities 2+                        sysMessage Normal "Linked with -threaded"+                        return Nothing+                    else Just <$> timeoutAddFull (yield >> return True) priorityLow 10     mbScreen <- screenGetDefault     case mbScreen of         Just screen -> do@@ -238,7 +240,6 @@             styleContextAddProviderForScreen screen provider 600         Nothing -> debugM "leksah" "Unable to add style provider for screen"     mapM_ (sysMessage Normal . T.pack) st-    initGtkRc     dataDir       <- getDataDir     mbStartupPrefs <- if not isFirstStart                                 then return $ Just iprefs@@ -250,7 +251,7 @@                                             prefsPath  <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir                                             prefs <- readPrefs prefsPath                                             return $ Just prefs-    timeoutRemove timeout+    maybe (return ()) timeoutRemove timeout     postGUIAsync $         case mbStartupPrefs of             Nothing           -> return ()@@ -272,7 +273,7 @@                     active <- newEmptyMVar                     mvarSentIdleMessage <- newEmptyMVar                     idleThread <- forkIO $ do-                        threadDelay 50000+                        threadDelay 200000                         isActive <- isJust <$> tryTakeMVar active                         unless isActive $ do                             putMVar mvarSentIdleMessage ()@@ -332,7 +333,9 @@ startMainWindow :: Yi.Control -> FilePath -> Maybe FilePath -> [FilePath] ->                         Prefs -> Bool -> IO () startMainWindow yiControl sessionFP mbWorkspaceFP sourceFPs startupPrefs isFirstStart = do-    timeout <- timeoutAddFull (yield >> return True) priorityLow 10+    timeout  <- if rtsSupportsBoundThreads+                    then return Nothing+                    else Just <$> timeoutAddFull (yield >> return True) priorityLow 10     debugM "leksah" "startMainWindow"     osxApp <- OSX.applicationNew     uiManager   <-  uiManagerNew@@ -422,6 +425,8 @@         return pair         ) ideR +    on win realize $ widgetGetWindow win >>= maybe (return ()) OSX.allowFullscreen+     debugM "leksah" "Show main window"     widgetShowAll win @@ -460,7 +465,7 @@             workspaceTryQuiet $ void (workspaceAddPackage' welcomeCabal)             fileOpenThis welcomeMain) ideR     reflectIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning}))) ideR-    timeoutRemove timeout+    maybe (return ()) timeoutRemove timeout     postGUIAsync . mainLoop $         reflectIDE (do             currentPrefs <- readIDE prefs

@@ -129,7 +129,7 @@     modifyIDE_ (\ide -> ide{allLogRefs = allLogRefs ide ++ refs})     setCurrentError Nothing     markLogRefs-    triggerEventIDE ErrorChanged+    triggerEventIDE (ErrorChanged False)     triggerEventIDE BreakpointChanged     triggerEventIDE TraceChanged     return ()@@ -437,18 +437,18 @@     BuildOutputState {..} <- CL.foldM (readAndShow logLaunch) $ initialState log     ideR <- lift ask     liftIO $ postGUISync $ reflectIDE (do-        triggerEventIDE (Sensitivity [(SensitivityError,not (null errs))])+        allErrorLikeRefs <- readIDE errorRefs+        triggerEventIDE (Sensitivity [(SensitivityError,not (null allErrorLikeRefs))])         let errorNum    =   length (filter isError errs)         let warnNum     =   length errs - errorNum         triggerEventIDE (StatusbarChanged [CompartmentState             (T.pack $ show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"), CompartmentBuild False])-        unless (backgroundBuild || (not jumpToWarnings && errorNum == 0)) nextError         return errs) ideR   where     readAndShow :: LogLaunch -> BuildOutputState -> ToolOutput -> IDEM BuildOutputState     readAndShow logLaunch state@BuildOutputState {..} output = do         ideR <- ask-        let logPrevious (previous:_) = reflectIDE (addLogRef previous) ideR+        let logPrevious (previous:_) = reflectIDE (addLogRef False backgroundBuild previous) ideR             logPrevious _ = return ()          liftIO $ postGUISync $ case output of

@@ -19,6 +19,7 @@     applicationNew ,   updateMenu ,   applicationReady+,   allowFullscreen ) where  import Graphics.UI.Gtk@@ -75,5 +76,7 @@ updateMenu _ _ = return () applicationReady :: Application -> IO () applicationReady _ = return ()+allowFullscreen :: DrawWindowClass window => window -> IO ()+allowFullscreen _ = return ()  #endif

@@ -166,10 +166,31 @@ deactivatePackage :: IDEAction deactivatePackage = activatePackage Nothing Nothing Nothing +interruptSaveAndRun :: MonadIDE m => IDEAction -> m ()+interruptSaveAndRun action = do+    ideR <- liftIDE ask+    alreadyRunning <- isRunning+    if alreadyRunning+        then do+            liftIO $ debugM "leksah" "interruptSaveAndRun"+            interruptBuild+            liftIO $ timeoutAddFull (do+                reflectIDE (do+                    interruptSaveAndRun action+                    return False) ideR+                return False) priorityDefaultIdle 200+            return ()+        else liftIDE run+  where+    run = do+        prefs <- readIDE prefs+        when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace+        action+ packageConfig :: PackageAction packageConfig = do     package <- ask-    liftIDE $ packageConfig' package (\ _ -> return ())+    interruptSaveAndRun $ packageConfig' package (\ _ -> return ())  packageConfig'  :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageConfig' package continuation = do@@ -237,6 +258,7 @@             alreadyRunning <- isRunning             if alreadyRunning                 then do+                    liftIO $ debugM "leksah" "buildPackage interruptBuild"                     interruptBuild                     unless backgroundBuild . liftIO $ do                         timeoutAddFull (do@@ -244,9 +266,11 @@                                 buildPackage backgroundBuild jumpToWarnings withoutLinking                                                 package continuation                                 return False) ideR-                            return False) priorityDefaultIdle 1000+                            return False) priorityDefaultIdle 100                         return ()-                else runCabalBuild backgroundBuild jumpToWarnings withoutLinking package True $ \f -> do+                else do+                    when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace+                    runCabalBuild backgroundBuild jumpToWarnings withoutLinking package True $ \f -> do                         when f $ do                             mbURI <- readIDE autoURI                             case mbURI of@@ -271,7 +295,7 @@ packageDoc :: PackageAction packageDoc = do     package <- ask-    liftIDE $ packageDoc' False True package (\ _ -> return ())+    interruptSaveAndRun $ packageDoc' False True package (\ _ -> return ())  packageDoc' :: Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction packageDoc' backgroundBuild jumpToWarnings package continuation = do@@ -281,14 +305,14 @@         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 $ postAsyncIDE reloadDoc                 lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))         (\(e :: SomeException) -> print e)  packageClean :: PackageAction packageClean = do     package <- ask-    liftIDE $ packageClean' package (\ _ -> return ())+    interruptSaveAndRun $ packageClean' package (\ _ -> return ())  packageClean' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageClean' package continuation = do@@ -307,7 +331,7 @@ packageCopy :: PackageAction packageCopy = do     package <- ask-    liftIDE $ do+    interruptSaveAndRun $ do         logLaunch <- getDefaultLogLaunch         showDefaultLogLaunch' @@ -329,7 +353,7 @@ packageInstallDependencies :: PackageAction packageInstallDependencies = do     package <- ask-    liftIDE $ do+    interruptSaveAndRun $ do         logLaunch <- getDefaultLogLaunch         showDefaultLogLaunch' @@ -358,7 +382,7 @@         (\(e :: SomeException) -> print e)  packageRun :: PackageAction-packageRun = ask >>= (liftIDE . packageRun' True)+packageRun = ask >>= (interruptSaveAndRun . packageRun' True)  packageRun' :: Bool -> IDEPackage -> IDEAction packageRun' removeGhcjsFlagIfPresent package =@@ -420,7 +444,7 @@     isActiveExe selected (Executable name _ _) = selected == Just (T.pack name)  packageRunJavaScript :: PackageAction-packageRunJavaScript = ask >>= (liftIDE . packageRunJavaScript' True)+packageRunJavaScript = ask >>= (interruptSaveAndRun . packageRunJavaScript' True)  packageRunJavaScript' :: Bool -> IDEPackage -> IDEAction packageRunJavaScript' addFlagIfMissing package =@@ -478,7 +502,7 @@ packageRegister :: PackageAction packageRegister = do     package <- ask-    liftIDE $ packageRegister' package (\ _ -> return ())+    interruptSaveAndRun $ packageRegister' package (\ _ -> return ())  packageRegister' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageRegister' package continuation =@@ -498,7 +522,7 @@ packageTest :: PackageAction packageTest = do     package <- ask-    liftIDE $ packageTest' False True package True (\ _ -> return ())+    interruptSaveAndRun $ packageTest' False True package True (\ _ -> return ())  packageTest' :: Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction packageTest' backgroundBuild jumpToWarnings package shallConfigure continuation =@@ -509,6 +533,7 @@           catchIDE (do             prefs <- readIDE prefs             let dir = ipdBuildDir package+            removeTestLogRefs dir             runExternalTool' (__ "Testing") (cabalCommand prefs) (["test", "--with-ghc=leksahtrue"]                 ++ ipdBuildFlags package ++ ipdTestFlags package) dir $ do                     (mbLastOutput, isConfigErr, _) <- C.getZipSink $ (,,)@@ -530,7 +555,7 @@ packageSdist :: PackageAction packageSdist = do     package <- ask-    liftIDE $ do+    interruptSaveAndRun $ do         logLaunch <- getDefaultLogLaunch         showDefaultLogLaunch' 

@@ -35,7 +35,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import IDE.Utils.GUIUtils (getDarkState, treeViewContextMenu, __) import Data.Text (Text)-import Control.Monad (void, when, forM_)+import Control.Monad (foldM_, unless, void, when, forM_) import qualified Data.Text as T        (intercalate, lines, takeWhile, length, drop) import Data.IORef (writeIORef, readIORef, newIORef, IORef)@@ -126,8 +126,9 @@ getErrors Nothing    = forceGetPane (Right "*Errors") getErrors (Just pp)  = forceGetPane (Left pp) -fillErrorList :: IDEAction-fillErrorList = getPane >>= maybe (return ()) fillErrorList'+fillErrorList :: Bool -> IDEAction+fillErrorList False = getPane >>= maybe (return ()) fillErrorList'+fillErrorList True = getErrors Nothing  >>= \ p -> fillErrorList' p >> displayPane p False  fillErrorList' :: IDEErrors -> IDEAction fillErrorList' pane = do@@ -170,10 +171,16 @@     liftIO $ do         selection <- treeViewGetSelection (treeView errors)         case mbLogRef of-            Nothing -> treeSelectionUnselectAll selection+            Nothing -> do+                size <- listStoreGetSize (errorStore errors)+                unless (size == 0) $+                    treeViewScrollToCell (treeView errors) (Just [0]) Nothing Nothing+                treeSelectionUnselectAll selection             Just lr -> case lr `elemIndex` errorRefs' of                         Nothing  -> return ()-                        Just ind -> treeSelectionSelectPath selection [ind]+                        Just ind -> do+                            treeViewScrollToCell (treeView errors) (Just [ind]) Nothing Nothing+                            treeSelectionSelectPath selection [ind]  errorsContextMenu :: IDERef                   -> ListStore ErrColumn@@ -211,10 +218,10 @@                     Nothing -> treeSelectionUnselectAll treeSel                     Just (SrcSpan file lStart cStart lEnd cEnd) -> do                         size <- listStoreGetSize (errorStore pane)-                        forM_ (take size [0..]) $ \ n -> do+                        foldM_ (\ haveScrolled n -> do                             mbIter <- treeModelGetIter (errorStore pane) [n]                             case mbIter of-                                Nothing -> return ()+                                Nothing -> return False                                 Just iter -> do                                     ErrColumn {logRef = ref@LogRef{..}} <- listStoreGetValue (errorStore pane) n                                     isSelected <- treeSelectionIterIsSelected treeSel iter@@ -224,6 +231,10 @@                                                      && (lEnd, cEnd)     >= (srcSpanStartLine   logRefSrcSpan,                                                                                srcSpanStartColumn logRefSrcSpan)                                     when (isSelected && not shouldBeSel) $ treeSelectionUnselectIter treeSel iter-                                    when (not isSelected && shouldBeSel) $ treeSelectionSelectIter treeSel iter+                                    when (not isSelected && shouldBeSel) $ do+                                        unless haveScrolled $ treeViewScrollToCell (treeView pane) (Just [n]) Nothing Nothing+                                        treeSelectionSelectIter treeSel iter+                                    return $ haveScrolled || shouldBeSel)+                            False (take size [0..])  

@@ -69,6 +69,8 @@ ,   addLogRef ,   removeLogRefs ,   removeBuildLogRefs+,   removeTestLogRefs+,   removeLintLogRefs ,   markRefInSourceBuf ,   inBufContext ,   inActiveBufContext@@ -152,6 +154,7 @@        (eventModifier, eventKeyName, eventKeyVal) import Data.Foldable (forM_) import Data.Traversable (forM)+import Language.Haskell.HLint3 (Idea(..))  allBuffers :: MonadIDE m => m [IDEBuffer] allBuffers = liftIDE getPanes@@ -343,45 +346,83 @@ 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})+removeLogRefs :: (FilePath -> FilePath -> Bool) -> [LogRefType] -> IDEAction+removeLogRefs toRemove' types = do+    (remove, keep) <- partition toRemove <$> readIDE allLogRefs+    let removeDetails = Map.fromListWith (<>) . nub $ map (\ref ->+                            (logRefRootPath ref </> logRefFilePath ref,+                            [logRefType ref])) remove+    modifyIDE_ (\ide -> ide{allLogRefs = keep})      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+    let matchingBufs = filter (maybe False (`Map.member` removeDetails) . fileName) buffers+    forM_ matchingBufs $ \ (IDEBuffer {..}) -> do+        buf <- getBuffer sourceView+        forM_ (maybe [] (fromMaybe [] . (`Map.lookup` removeDetails)) fileName) $+            removeTagByName buf . T.pack . show -    triggerEventIDE ErrorChanged+    triggerEventIDE (ErrorChanged False)     return ()   where-    keep ref = logRefRootPath ref /= root-            || logRefFilePath ref /= file-            || logRefType ref `notElem` types+    toRemove ref = toRemove' (logRefRootPath ref) (logRefFilePath ref)+                && logRefType ref `elem` types +removeFileLogRefs :: FilePath -> FilePath -> [LogRefType] -> IDEAction+removeFileLogRefs root file types = do+    liftIO . debugM "leksah" $ "removeFileLogRefs " <> root <> " " <> file <> " " <> show types+    removeLogRefs (\r f -> r == root && f == file) types++removePackageLogRefs :: FilePath -> [LogRefType] -> IDEAction+removePackageLogRefs root types = do+    liftIO . debugM "leksah" $ "removePackageLogRefs " <> root <> " " <> show types+    removeLogRefs (\r _ -> r == root) types+ removeBuildLogRefs :: FilePath -> FilePath -> IDEAction-removeBuildLogRefs = removeLogRefs [ErrorRef, WarningRef, TestFailureRef]+removeBuildLogRefs root file = removeFileLogRefs root file [ErrorRef, WarningRef] --- | Test failures have the same imporance as errors so should be--- sorted the same-importance :: LogRef -> LogRefType-importance LogRef{ logRefType = TestFailureRef } = ErrorRef-importance ref = logRefType ref+removeTestLogRefs :: FilePath -> IDEAction+removeTestLogRefs root = removePackageLogRefs root [TestFailureRef] -addLogRef :: LogRef -> IDEAction-addLogRef ref = do+removeLintLogRefs :: FilePath -> FilePath -> IDEAction+removeLintLogRefs root file = removeFileLogRefs root file [LintRef]++canResolve :: LogRef -> Bool+canResolve LogRef { logRefIdea = Just (_, Idea{..}) }+    = ideaHint /= "Reduce duplication" && isJust ideaTo+canResolve _ = False++addLogRef :: Bool -> Bool -> LogRef -> IDEAction+addLogRef hlintFileScope backgroundBuild ref = do+    liftIO . debugM "leksah" $ "addLogRef " <> show hlintFileScope <> " " <> show (logRefType ref) <> " " <> logRefFullFilePath ref     -- Put most important errors first.     -- If the importance of two errors is the same then     -- then the older one might be stale (unless it is in the same file)+    allLogRefs   <- readIDE allLogRefs+    currentError <- readIDE currentError+    let (moreImportant, rest) =+            span (\old ->+                let samePackage = logRefRootPath old     == logRefRootPath ref+                    sameFile    = logRefFullFilePath old == logRefFullFilePath ref in+                -- Work out when the old ref is more important than the new+                case (logRefType ref, logRefType old) of+                    (ErrorRef      , ErrorRef      ) -> sameFile+                    (ErrorRef      , _             ) -> False+                    (WarningRef    , ErrorRef      ) -> samePackage+                    (WarningRef    , WarningRef    ) -> samePackage+                    (WarningRef    , _             ) -> False+                    (TestFailureRef, ErrorRef      ) -> samePackage  -- Probably should never be True+                    (TestFailureRef, TestFailureRef) -> samePackage+                    (TestFailureRef, _             ) -> False+                    (LintRef       , LintRef       ) -> (if hlintFileScope then sameFile else samePackage)+                                                            && (canResolve old+                                                               || not (canResolve ref))+                    (LintRef       , _             ) -> samePackage+                    (ContextRef    , _             ) -> False+                    (BreakpointRef , _             ) -> False) allLogRefs+        currErr = if currentError `elem` map Just moreImportant+                        then currentError+                        else Nothing     modifyIDE_ $ \ ide ->-        let (moreImportant, rest) =-                partition (\old -> importance old < importance ref -- Note: a low LogRefType is more important-                               || (importance old == importance ref-                                            && logRefFullFilePath old == logRefFullFilePath ref)) (allLogRefs ide)-            currErr = if currentError ide `elem` map Just moreImportant-                                then currentError ide-                                else Nothing in         ide{ allLogRefs = moreImportant <> [ref] <> rest            , currentEBC = (currErr, currentBreak ide, currentContext ide)            }@@ -390,7 +431,7 @@     let matchingBufs = filter (maybe False (equalFilePath (logRefFullFilePath ref)) . fileName) buffers     forM_ matchingBufs $ \ buf -> markRefInSourceBuf buf ref False -    triggerEventIDE ErrorChanged+    triggerEventIDE . ErrorChanged $ not backgroundBuild && null moreImportant     return ()  markRefInSourceBuf :: IDEBuffer -> LogRef -> Bool -> IDEAction

@@ -673,7 +673,7 @@ setDark :: Bool -> IDEM () setDark dark = do     setInfoStyle-    fillErrorList+    fillErrorList False     prefs <- readIDE prefs     buffers <- allBuffers     mapM_ updateStyle' buffers

@@ -65,7 +65,7 @@                   -> LogRefType                   -> EditorIter editor                   -> Text-                  -> IDEM (EditorMark editor)+                  -> IDEM ()     cutClipboard :: EditorBuffer editor -> Clipboard -> Bool -> IDEM ()     delete :: EditorBuffer editor -> EditorIter editor -> EditorIter editor -> IDEM ()     deleteSelection :: EditorBuffer editor -> IDEM ()

@@ -265,9 +265,10 @@     copyClipboard (CMBuffer cm) _ = return () -- TODO     createMark (CMView cm) _refType (CMIter _ i) _tooltip = runCM cm $ do         m <- codeMirror-        lift $ CMMark <$> do+        lift $ do                 o <- obj                 m ^. setBookmark' i o+                return ()     cutClipboard (CMBuffer cm) _ _ = return () -- TODO     delete (CMBuffer cm) (CMIter _ first) (CMIter _ last) = runCM cm $ do         m <- codeMirror

@@ -207,10 +207,13 @@     canUndo (GtkBuffer sb) = liftIO $ sourceBufferGetCanUndo sb     copyClipboard (GtkBuffer sb) clipboard = liftIO $ textBufferCopyClipboard sb clipboard     createMark (GtkView sv) refType (GtkIter i) tooltip = liftIO $ do-        let cat = T.pack $ show refType         sb <- castToSourceBuffer <$> get sv textViewBuffer         n <- textIterGetLine i-        GtkMark . toTextMark <$> sourceBufferCreateSourceMark sb (Just $ T.pack (show n) <> " " <> tooltip) cat i+        let cat  = T.pack $ show refType+            name = T.pack (show n) <> " " <> tooltip+        mark <- textBufferGetMark sb name+        when (isNothing mark) . void $+            sourceBufferCreateSourceMark sb (Just name) cat i     cutClipboard (GtkBuffer sb) clipboard defaultEditable = liftIO $ textBufferCutClipboard sb clipboard defaultEditable     delete (GtkBuffer sb) (GtkIter first) (GtkIter last) = liftIO $         textBufferDelete sb first last

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module      :  IDE.Utils.Tools@@ -17,6 +19,7 @@   , runExternalTool   , isRunning   , interruptBuild+  , showProcessHandle ) where  import qualified Data.Conduit as C (Sink)@@ -24,9 +27,9 @@        (interruptProcessGroupOf, getProcessExitCode, runTool,         ProcessHandle, ToolOutput(..)) import IDE.Core.State-       (runningTool, modifyIDE_, reflectIDE, useVado, reifyIDE,-        triggerEventIDE, saveAllBeforeBuild, prefs, readIDE, IDEAction,-        IDEM, MonadIDE(..))+       (postSyncIDE, runningTool, modifyIDE_, reflectIDE, useVado,+        reifyIDE, triggerEventIDE, saveAllBeforeBuild, prefs, readIDE,+        IDEAction, IDEM, MonadIDE(..)) import Control.Monad (void, unless, when) import IDE.Pane.SourceBuffer (belongsToWorkspace, fileSaveAll) import IDE.Core.Types (StatusbarCompartment(..), IDEEvent(..))@@ -38,7 +41,39 @@ import Control.Applicative ((<$>)) import Data.Text (Text) import qualified Data.Text as T (unpack, pack, null)+import System.Log.Logger (debugM)+import Data.Monoid ((<>)) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+import System.Posix.Types (CPid(..))+import System.Exit (ExitCode)+import Control.Concurrent.MVar (withMVar, MVar)+import Unsafe.Coerce (unsafeCoerce)+import System.Posix.Process (getProcessGroupIDOf)+#endif++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+type PHANDLE = CPid+data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode+data ProcessHandleLike = ProcessHandleLike !(MVar ProcessHandle__) !Bool++withProcessHandle+        :: ProcessHandleLike+        -> (ProcessHandle__ -> IO a)+        -> IO a+withProcessHandle (ProcessHandleLike m _) = withMVar m++showProcessHandle :: ProcessHandle -> IO String+showProcessHandle h = withProcessHandle (unsafeCoerce h) $ \case+        (OpenHandle (CPid pid)) -> do+            CPid gid <- getProcessGroupIDOf (CPid pid)+            return $ "pid " <> show pid <> " gid " <> show gid+        (ClosedHandle _)        -> return "closed handle"+#else+showProcessHandle :: ProcessHandle -> IO String+showProcessHandle _ = return ""+#endif+ runExternalTool' :: MonadIDE m                 => Text                 -> FilePath@@ -71,24 +106,27 @@         prefs <- readIDE prefs         run <- runGuard         when run $ do-            when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ())             unless (T.null description) . void $                 triggerEventIDE (StatusbarChanged [CompartmentState description, CompartmentBuild True])-            reifyIDE $ \ideR -> forkIO $ do-                -- If vado is enabled then look up the mount point and transform-                -- the execuatble to "ssh" and the arguments-                mountPoint <- if useVado prefs then getMountPoint dir else return $ Right ""-                (executable', args') <- case mountPoint of-                                            Left mp -> do-                                                s <- readSettings-                                                a <- vado mp s dir [] executable (map T.unpack args)-                                                return ("ssh", map T.pack a)-                                            _ -> return (executable, args)-                -- Run the tool-                (output, pid) <- runTool executable' args' (Just dir)+            -- If vado is enabled then look up the mount point and transform+            -- the execuatble to "ssh" and the arguments+            mountPoint <- if useVado prefs then liftIO $ getMountPoint dir else return $ Right ""+            (executable', args') <- case mountPoint of+                                        Left mp -> do+                                            s <- liftIO readSettings+                                            a <- liftIO $ vado mp s dir [] executable (map T.unpack args)+                                            return ("ssh", map T.pack a)+                                        _ -> return (executable, args)+            -- Run the tool+            (output, pid) <- liftIO $ runTool executable' args' (Just dir)+            modifyIDE_ (\ide -> ide{runningTool = Just pid})+            reifyIDE $ \ideR -> forkIO $                 reflectIDE (do                     pidHandler pid-                    modifyIDE_ (\ide -> ide{runningTool = Just pid})+                    liftIO $ do+                        s <- showProcessHandle pid+                        debugM "leksah" $ "runExternalTool " <> s <> " " <>+                                            unwords (executable' : map T.unpack args')                     output $$ handleOutput) ideR             return () @@ -108,7 +146,10 @@ interruptBuild = do     maybeProcess <- readIDE runningTool     liftIO $ case maybeProcess of-        Just h -> interruptProcessGroupOf h-        _ -> return ()+            Just h -> do+                pid <- showProcessHandle h+                debugM "leksah" $ "interruptBuild " <> pid+                interruptProcessGroupOf h+            _ -> debugM "leksah" "interruptBuild Nothing"