6cba2e5 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Separate diagnostics from rule results (#1423)

6cba2e5Moritz Kiefer7 years ago

BUILD.bazel+1

compare with master

unifiedsplit

@@ -21,6 +21,7 @@ depends = [

21 "mtl",

22 "pretty",

23 "safe-exceptions",

24+ "sorted-list",

24 "shake",

25 "shake",

25 "stm",

26 "stm",

26 "syb",

27 "syb",

src/Development/IDE/State/FileStore.hs−9

@@ -42,10 +42,6 @@ newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)

42instance IsIdeGlobal GlobalDirtyFiles

45−

46−-- | Get the modification time of a file.

47−type instance RuleResult GetModificationTime = UTCTime

48−

49-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.

45-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.

50type instance RuleResult GetFileContents = (UTCTime, StringBuffer)

46type instance RuleResult GetFileContents = (UTCTime, StringBuffer)

@@ -58,11 +54,6 @@ data GetFileExists = GetFileExists

58instance Hashable GetFileExists

54instance Hashable GetFileExists

59instance NFData GetFileExists

55instance NFData GetFileExists

61−data GetModificationTime = GetModificationTime

62− deriving (Eq, Show, Generic)

63−instance Hashable GetModificationTime

64−instance NFData GetModificationTime

65−

66data GetFileContents = GetFileContents

57data GetFileContents = GetFileContents

67 deriving (Eq, Show, Generic)

58 deriving (Eq, Show, Generic)

68instance Hashable GetFileContents

59instance Hashable GetFileContents

src/Development/IDE/State/Shake.hs+54−56

@@ -24,7 +24,7 @@

24-- useStale.

25module Development.IDE.State.Shake(

26 IdeState,

27− IdeRule, IdeResult,

27+ IdeRule, IdeResult, GetModificationTime(..),

28 shakeOpen, shakeShut,

29 shakeRun,

30 shakeProfile,

@@ -55,19 +55,18 @@ import Data.List.Extra

55import qualified Data.Text as T

56import Development.IDE.Logger as Logger

57import Development.IDE.Types.LSP

58−import Development.IDE.Types.Diagnostics

58+import Development.IDE.Types.Diagnostics hiding (getAllDiagnostics)

59+import qualified Development.IDE.Types.Diagnostics as D

59import Control.Concurrent.Extra

60import Control.Concurrent.Extra

60import Control.Exception

61import Control.Exception

61import Control.DeepSeq

62import Control.DeepSeq

62import System.Time.Extra

63import System.Time.Extra

63import Data.Typeable

64import Data.Typeable

64−import Data.Tuple.Extra

65−import System.Directory

66−import System.FilePath

65+import System.FilePath hiding (makeRelative)

67import qualified Development.Shake as Shake

66import qualified Development.Shake as Shake

68import Control.Monad.Extra

67import Control.Monad.Extra

69−import qualified Data.Set as Set

70import Data.Time

68import Data.Time

69+import GHC.Generics

71import System.IO.Unsafe

70import System.IO.Unsafe

72import Numeric.Extra

71import Numeric.Extra

@@ -79,6 +78,7 @@ data ShakeExtras = ShakeExtras

79 ,logger :: Logger.Handle

78 ,logger :: Logger.Handle

80 ,globals :: Var (Map.HashMap TypeRep Dynamic)

79 ,globals :: Var (Map.HashMap TypeRep Dynamic)

81 ,state :: Var Values

80 ,state :: Var Values

81+ ,diagnostics :: Var (ProjectDiagnostics Key)

82 }

84getShakeExtras :: Action ShakeExtras

@@ -116,12 +116,7 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras

116

117

118-- | The state of the all values - nested so you can easily find all errors at a given file.

119−type Values =

120− Map.HashMap FilePath

119+type Values = Map.HashMap (FilePath, Key) (Maybe Dynamic)

121− (Map.HashMap Key

122− (IdeResult Dynamic)

123− )

124−

125

120

126-- | Key type

121-- | Key type

127data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k

122data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k

@@ -198,13 +193,10 @@ setValues :: IdeRule k v

198 => Var Values

193 => Var Values

199 -> k

194 -> k

200 -> FilePath

195 -> FilePath

201− -> IdeResult v

196+ -> Maybe v

202− -> IO (Maybe [FileDiagnostic], [FileDiagnostic]) -- ^ (before, after)

197+ -> IO ()

203−setValues state key file val = modifyVar state $ \inVal -> do

198+setValues state key file val = modifyVar_ state $

204− let k = Key key

199+ pure . Map.insert (file, Key key) (fmap toDyn val)

205− outVal = Map.insertWith Map.union file (Map.singleton k $ second (fmap toDyn) val) inVal

206− f = concatMap fst . Map.elems

207− return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file))

208

200

209-- | The outer Maybe is Nothing if this function hasn't been computed before

201-- | The outer Maybe is Nothing if this function hasn't been computed before

210-- the inner Maybe is Nothing if the result of the previous computation failed to produce

202-- the inner Maybe is Nothing if the result of the previous computation failed to produce

@@ -213,9 +205,8 @@ getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe

213getValues state key file = do

205getValues state key file = do

214 vs <- readVar state

206 vs <- readVar state

215 return $ do

207 return $ do

216− f <- Map.lookup file vs

208+ v <- Map.lookup (file, Key key) vs

217− v <- Map.lookup (Key key) f

218− pure $ fmap (fromJust . fromDynamic @v) $ snd v

209+ pure $ fmap (fromJust . fromDynamic @v) v

219

210

220-- | Open a 'IdeState', should be shut using 'shakeShut'.

211-- | Open a 'IdeState', should be shut using 'shakeShut'.

221shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler

212shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler

@@ -223,8 +214,12 @@ shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler

223 -> ShakeOptions

214 -> ShakeOptions

224 -> Rules ()

215 -> Rules ()

225 -> IO IdeState

216 -> IO IdeState

226−shakeOpen diags shakeLogger opts rules = do

217+shakeOpen eventer logger opts rules = do

227− shakeExtras <- ShakeExtras diags shakeLogger <$> newVar Map.empty <*> newVar Map.empty

218+ shakeExtras <- do

219+ globals <- newVar Map.empty

220+ state <- newVar Map.empty

221+ diagnostics <- newVar emptyDiagnostics

222+ pure ShakeExtras{..}

228 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules

223 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules

229 shakeAbort <- newVar $ return ()

224 shakeAbort <- newVar $ return ()

230 shakeDb <- shakeDb

225 shakeDb <- shakeDb

@@ -263,20 +258,22 @@ useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =

263

258

264

259

265getAllDiagnostics :: IdeState -> IO [FileDiagnostic]

260getAllDiagnostics :: IdeState -> IO [FileDiagnostic]

266−getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do

261+getAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

267− val <- readVar state

262+ val <- readVar diagnostics

268− return $ concatMap (concatMap fst . Map.elems) $ Map.elems val

263+ return $ D.getAllDiagnostics val

269

264

270-- | FIXME: This function is temporary! Only required because the files of interest doesn't work

265-- | FIXME: This function is temporary! Only required because the files of interest doesn't work

271unsafeClearAllDiagnostics :: IdeState -> IO ()

266unsafeClearAllDiagnostics :: IdeState -> IO ()

272−unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = modifyVar_ state $

267+unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =

273− return . Map.map (Map.map (\(_, x) -> ([], x)))

268+ writeVar diagnostics emptyDiagnostics

274

269

275-- | Clear the results for all files that do not match the given predicate.

270-- | Clear the results for all files that do not match the given predicate.

276garbageCollect :: (FilePath -> Bool) -> Action ()

271garbageCollect :: (FilePath -> Bool) -> Action ()

277garbageCollect keep = do

272garbageCollect keep = do

278− ShakeExtras{state} <- getShakeExtras

273+ ShakeExtras{state, diagnostics} <- getShakeExtras

274+ liftIO $

279− liftIO $ modifyVar_ state $ return . Map.filterWithKey (\file _ -> keep file)

275+ do modifyVar_ state $ return . Map.filterWithKey (\(file, _) _ -> keep file)

276+ modifyVar_ diagnostics $ return . filterDiagnostics keep

280

277

281define

278define

282 :: IdeRule k v

279 :: IdeRule k v

@@ -354,7 +351,7 @@ defineEarlyCutoff

354 => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))

351 => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))

355 -> Rules ()

352 -> Rules ()

356defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do

353defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do

357− ShakeExtras{state} <- getShakeExtras

354+ extras@ShakeExtras{state} <- getShakeExtras

358 val <- case old of

355 val <- case old of

359 Just old | mode == RunDependenciesSame -> do

356 Just old | mode == RunDependenciesSame -> do

360 v <- liftIO $ getValues state key file

357 v <- liftIO $ getValues state key file

@@ -365,46 +362,39 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m

365 case val of

362 case val of

366 Just res -> return res

363 Just res -> return res

367 Nothing -> do

364 Nothing -> do

368− (bs, res) <- actionCatch

365+ (bs, (diags, res)) <- actionCatch

369 (do v <- op key file; liftIO $ evaluate $ force v) $

366 (do v <- op key file; liftIO $ evaluate $ force v) $

370 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

367 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

371− res <- return $ first (map $ \(_,d) -> (file,d)) res

372

368

373− (before, after) <- liftIO $ setValues state key file res

369+ liftIO $ setValues state key file res

374− updateFileDiagnostics file before after

370+ updateFileDiagnostics file (Key key) extras $ map snd diags

375 let eq = case (bs, fmap unwrap old) of

371 let eq = case (bs, fmap unwrap old) of

376 (Just a, Just (Just b)) -> a == b

372 (Just a, Just (Just b)) -> a == b

377 _ -> False

373 _ -> False

378 return $ RunResult

374 return $ RunResult

379 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

375 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

380 (wrap bs)

376 (wrap bs)

381− $ A (snd res) bs

377+ $ A res bs

382 where

378 where

383 wrap = maybe BS.empty (BS.cons '_')

379 wrap = maybe BS.empty (BS.cons '_')

384 unwrap x = if BS.null x then Nothing else Just $ BS.tail x

380 unwrap x = if BS.null x then Nothing else Just $ BS.tail x

385

381

386−

387updateFileDiagnostics ::

382updateFileDiagnostics ::

388 FilePath

383 FilePath

389− -> Maybe [FileDiagnostic] -- ^ previous results for this file

384+ -> Key

385+ -> ShakeExtras

390− -> [FileDiagnostic] -- ^ current results

386+ -> [Diagnostic] -- ^ current results

391 -> Action ()

387 -> Action ()

392−updateFileDiagnostics afp previousAll currentAll = do

388+updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do

393− -- TODO (MK) We canonicalize to make sure that the two files agree on use of

389+ (newDiags, oldDiags) <- liftIO $ do

394− -- / and \ and other shenanigans.

390+ modTime <- join <$> getValues state GetModificationTime fp

395− -- Once we have finished the migration to haskell-lsp we should make sure that

391+ modifyVar diagnostics $ \old -> do

396− -- this is no longer necessary.

392+ let oldDiags = getFileDiagnostics fp old

397− afp' <- liftIO $ canonicalizePath afp

393+ let newDiagsStore = setStageDiagnostics fp modTime k current old

398− let filtM diags = do

394+ let newDiags = getFileDiagnostics fp newDiagsStore

399− diags' <-

395+ pure (newDiagsStore, (newDiags, oldDiags))

400− filterM

396+ when (newDiags /= oldDiags) $

401− (\x -> fmap (== afp') (canonicalizePath $ fst x))

402− diags

403− pure (Set.fromList diags')

404− previous <- liftIO $ traverse filtM previousAll

405− current <- liftIO $ filtM currentAll

406− when (Just current /= previous) $

407− sendEvent $ EventFileDiagnostics $ (afp, map snd $ Set.toList current)

397+ sendEvent $ EventFileDiagnostics (fp, newDiags)

408

398

409

399

410setPriority :: (Enum a) => a -> Action ()

400setPriority :: (Enum a) => a -> Action ()

@@ -424,3 +414,11 @@ logDebug, logSeriousError

424 :: IdeState -> T.Text -> IO ()

414 :: IdeState -> T.Text -> IO ()

425logDebug = sl Logger.logDebug

415logDebug = sl Logger.logDebug

426logSeriousError = sl Logger.logSeriousError

416logSeriousError = sl Logger.logSeriousError

417+

418+data GetModificationTime = GetModificationTime

419+ deriving (Eq, Show, Generic)

420+instance Hashable GetModificationTime

421+instance NFData GetModificationTime

422+

423+-- | Get the modification time of a file.

424+type instance RuleResult GetModificationTime = UTCTime

src/Development/IDE/Types/Diagnostics.hs+77−42

@@ -27,12 +27,16 @@ module Development.IDE.Types.Diagnostics (

27 ideTryIOException,

28 showDiagnostics,

29 showDiagnosticsColored,

30− prettyDiagnosticStore,

31 defDiagnostic,

30 defDiagnostic,

32− addDiagnostics,

33− filterSeriousErrors,

34 filePathToUri,

31 filePathToUri,

35− getDiagnosticsFromStore

32+ uriToFilePath',

33+ ProjectDiagnostics,

34+ emptyDiagnostics,

35+ setStageDiagnostics,

36+ getAllDiagnostics,

37+ filterDiagnostics,

38+ getFileDiagnostics,

39+ prettyDiagnostics

36 ) where

40 ) where

38import Control.Exception

42import Control.Exception

@@ -40,14 +44,17 @@ import Data.Either.Combinators

40import Data.Maybe as Maybe

44import Data.Maybe as Maybe

41import Data.Foldable

45import Data.Foldable

42import qualified Data.Map as Map

46import qualified Data.Map as Map

47+import Data.Time.Clock

48+import Data.Time.Clock.POSIX

43import qualified Data.Text as T

49import qualified Data.Text as T

44import Data.Text.Prettyprint.Doc.Syntax

50import Data.Text.Prettyprint.Doc.Syntax

51+import qualified Data.SortedList as SL

45import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty

52import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty

53+import qualified Language.Haskell.LSP.Types as LSP

46−import Language.Haskell.LSP.Types as LSP (

54+import Language.Haskell.LSP.Types as LSP (

47 DiagnosticSeverity(..)

55 DiagnosticSeverity(..)

48 , Diagnostic(..)

56 , Diagnostic(..)

49 , filePathToUri

57 , filePathToUri

50− , uriToFilePath

51 , List(..)

58 , List(..)

52 , DiagnosticRelatedInformation(..)

59 , DiagnosticRelatedInformation(..)

53 , Uri(..)

60 , Uri(..)

@@ -56,6 +63,15 @@ import Language.Haskell.LSP.Diagnostics

57import Development.IDE.Types.Location

64import Development.IDE.Types.Location

66+-- | We use an empty string as a filepath when we don’t have a file.

67+-- However, haskell-lsp doesn’t support that in uriToFilePath and given

68+-- that it is not a valid filepath it does not make sense to upstream a fix.

69+-- So we have our own wrapper here that supports empty filepaths.

70+uriToFilePath' :: Uri -> Maybe FilePath

71+uriToFilePath' uri

72+ | uri == filePathToUri "" = Just ""

73+ | otherwise = LSP.uriToFilePath uri

74+

59ideErrorText :: FilePath -> T.Text -> FileDiagnostic

75ideErrorText :: FilePath -> T.Text -> FileDiagnostic

60ideErrorText fp = errorDiag fp "Ide Error"

76ideErrorText fp = errorDiag fp "Ide Error"

@@ -96,28 +112,6 @@ defDiagnostic _range _message = LSP.Diagnostic {

96 , _relatedInformation = Nothing

112 , _relatedInformation = Nothing

97 }

113 }

114

99−filterSeriousErrors ::

100− FilePath ->

101− [LSP.Diagnostic] ->

102− [LSP.Diagnostic]

103−filterSeriousErrors fp =

104− filter (maybe False hasSeriousErrors . LSP._relatedInformation)

105− where

106− hasSeriousErrors :: List DiagnosticRelatedInformation -> Bool

107− hasSeriousErrors (List a) = any ((/=) uri . _uri . _location) a

108− uri = LSP.filePathToUri fp

109−

110−addDiagnostics ::

111− FilePath ->

112− [LSP.Diagnostic] ->

113− DiagnosticStore -> DiagnosticStore

114−addDiagnostics fp diags ds =

115− updateDiagnostics

116− ds

117− (LSP.filePathToUri fp)

118− Nothing $

119− partitionBySource diags

120−

121ideTryIOException :: FilePath -> IO a -> IO (Either FileDiagnostic a)

115ideTryIOException :: FilePath -> IO a -> IO (Either FileDiagnostic a)

122ideTryIOException fp act =

116ideTryIOException fp act =

123 mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act

117 mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act

@@ -167,20 +161,61 @@ prettyDiagnostic (fp, LSP.Diagnostic{..}) =

167 where

161 where

168 sev = fromMaybe LSP.DsError _severity

162 sev = fromMaybe LSP.DsError _severity

169

163

170−prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass

171−prettyDiagnosticStore ds =

172− vcat $

173− map (\(uri, diags) -> prettyFileDiagnostics (fromMaybe noFilePath $ uriToFilePath uri, diags)) $

174− Map.assocs $

175− Map.map getDiagnosticsFromStore ds

176−

177−prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass

178−prettyFileDiagnostics (filePath, diags) =

179− slabel_ "Compiler error in" $ vcat

180− [ slabel_ "File:" $ pretty filePath

181− , slabel_ "Errors:" $ vcat $ map (prettyDiagnostic . (filePath,)) diags

182− ]

183−

184getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

164getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

185getDiagnosticsFromStore (StoreItem _ diags) =

165getDiagnosticsFromStore (StoreItem _ diags) =

186 toList =<< Map.elems diags

166 toList =<< Map.elems diags

167+

168+-- | This represents every diagnostic in a LSP project, the stage type variable is

169+-- the type of the compiler stages, in this project that is always the Key data

170+-- type found in Development.IDE.State.Shake

171+newtype ProjectDiagnostics stage = ProjectDiagnostics {getStore :: DiagnosticStore}

172+ deriving Show

173+

174+emptyDiagnostics :: ProjectDiagnostics stage

175+emptyDiagnostics = ProjectDiagnostics mempty

176+

177+-- | Sets the diagnostics for a file and compilation step

178+-- if you want to clear the diagnostics call this with an empty list

179+setStageDiagnostics ::

180+ Show stage =>

181+ FilePath ->

182+ Maybe UTCTime ->

183+ -- ^ the time that the file these diagnostics originate from was last edited

184+ stage ->

185+ [LSP.Diagnostic] ->

186+ ProjectDiagnostics stage ->

187+ ProjectDiagnostics stage

188+setStageDiagnostics fp timeM stage diags (ProjectDiagnostics ds) =

189+ ProjectDiagnostics $ updateDiagnostics ds uri posixTime diagsBySource

190+ where

191+ diagsBySource = Map.singleton (Just $ T.pack $ show stage) (SL.toSortedList diags)

192+ posixTime :: Maybe Int

193+ posixTime = fmap (fromEnum . utcTimeToPOSIXSeconds) timeM

194+ uri = filePathToUri fp

195+

196+fromUri :: LSP.Uri -> FilePath

197+fromUri = fromMaybe noFilePath . uriToFilePath'

198+

199+getAllDiagnostics ::

200+ ProjectDiagnostics stage ->

201+ [FileDiagnostic]

202+getAllDiagnostics =

203+ concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList . getStore

204+

205+getFileDiagnostics ::

206+ FilePath ->

207+ ProjectDiagnostics stage ->

208+ [LSP.Diagnostic]

209+getFileDiagnostics fp ds =

210+ maybe [] getDiagnosticsFromStore $

211+ Map.lookup (filePathToUri fp) $

212+ getStore ds

213+

214+filterDiagnostics ::

215+ (FilePath -> Bool) ->

216+ ProjectDiagnostics stage ->

217+ ProjectDiagnostics stage

218+filterDiagnostics keep =

219+ ProjectDiagnostics .

220+ Map.filterWithKey (\uri _ -> maybe True keep $ uriToFilePath' uri) .

221+ getStore