diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -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 diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -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, diff --git a/osx/makedmgs.sh b/osx/makedmgs.sh --- a/osx/makedmgs.sh +++ b/osx/makedmgs.sh @@ -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:. + diff --git a/scripts/clean.sh b/scripts/clean.sh --- a/scripts/clean.sh +++ b/scripts/clean.sh @@ -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 \ diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -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 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 @@ -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 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 @@ -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" diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs --- a/src/IDE/Debug.hs +++ b/src/IDE/Debug.hs @@ -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 diff --git a/src/IDE/HLint.hs b/src/IDE/HLint.hs --- a/src/IDE/HLint.hs +++ b/src/IDE/HLint.hs @@ -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 diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -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 diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -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 diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs --- a/src/IDE/LogRef.hs +++ b/src/IDE/LogRef.hs @@ -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 diff --git a/src/IDE/OSX.hs b/src/IDE/OSX.hs --- a/src/IDE/OSX.hs +++ b/src/IDE/OSX.hs @@ -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 diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -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' 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 @@ -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..]) 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 @@ -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 diff --git a/src/IDE/Session.hs b/src/IDE/Session.hs --- a/src/IDE/Session.hs +++ b/src/IDE/Session.hs @@ -673,7 +673,7 @@ setDark :: Bool -> IDEM () setDark dark = do setInfoStyle - fillErrorList + fillErrorList False prefs <- readIDE prefs buffers <- allBuffers mapM_ updateStyle' buffers 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 @@ -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 () 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 @@ -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 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 @@ -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 diff --git a/src/IDE/Utils/ExternalTool.hs b/src/IDE/Utils/ExternalTool.hs --- a/src/IDE/Utils/ExternalTool.hs +++ b/src/IDE/Utils/ExternalTool.hs @@ -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"