32b6a5f · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Changed Diagnostics to FileDiagnostics (#897)

32b6a5fDavidM-D7 years ago

BUILD.bazel−1

compare with master

unifiedsplit

@@ -22,7 +22,6 @@ da_haskell_library(

22 "hashable",

23 "haskell-lsp",

24 "haskell-lsp-types",

25− "lens",

26 "mtl",

25 "mtl",

27 "pretty",

26 "pretty",

28 "safe-exceptions",

27 "safe-exceptions",

src/Development/IDE/Functions/Compile.hs+9−9

@@ -123,14 +123,14 @@ parseModule

123 -> PackageState

124 -> FilePath

125 -> (UTCTime, SB.StringBuffer)

126− -> IO ([Diagnostic], Maybe ParsedModule)

126+ -> IO ([FileDiagnostic], Maybe ParsedModule)

127parseModule opt@CompileOpts{..} packageState file =

128 fmap (either (, Nothing) (second Just)) . Ex.runExceptT .

129 -- We need packages since imports fail to resolve otherwise.

130 runGhcSessionExcept opt Nothing packageState . parseFileContents optPreprocessor file

131

132computePackageDeps ::

133− CompileOpts -> PackageState -> InstalledUnitId -> IO (Either [Diagnostic] [InstalledUnitId])

133+ CompileOpts -> PackageState -> InstalledUnitId -> IO (Either [FileDiagnostic] [InstalledUnitId])

134computePackageDeps opts packageState iuid =

135 Ex.runExceptT $

136 runGhcSessionExcept opts Nothing packageState $

@@ -155,7 +155,7 @@ typecheckModule

155 -> [TcModuleResult]

156 -> [LoadPackageResult]

157 -> ParsedModule

158− -> IO ([Diagnostic], Maybe TcModuleResult)

158+ -> IO ([FileDiagnostic], Maybe TcModuleResult)

159typecheckModule opt mod packageState uniqSupply deps pkgs pm =

160 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $

161 runGhcSessionExcept opt (Just mod) packageState $

@@ -173,7 +173,7 @@ loadPackage ::

173 -> UniqSupply

174 -> [LoadPackageResult]

175 -> InstalledUnitId

176− -> IO (Either [Diagnostic] LoadPackageResult)

176+ -> IO (Either [FileDiagnostic] LoadPackageResult)

177loadPackage opt packageState us lps p =

178 Ex.runExceptT $

179 runGhcSessionExcept opt Nothing packageState $

@@ -202,7 +202,7 @@ compileModule

202 -> [TcModuleResult]

203 -> [LoadPackageResult]

204 -> TcModuleResult

205− -> IO ([Diagnostic], Maybe GhcModule)

205+ -> IO ([FileDiagnostic], Maybe GhcModule)

206compileModule opt mod packageState uniqSupply deps pkgs tmr =

207 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $

208 runGhcSessionExcept opt (Just mod) packageState $

@@ -406,7 +406,7 @@ getModSummaryFromBuffer

406 -> (SB.StringBuffer, UTCTime)

407 -> DynFlags

408 -> GHC.ParsedSource

409− -> Ex.ExceptT [Diagnostic] m ModSummary

409+ -> Ex.ExceptT [FileDiagnostic] m ModSummary

410getModSummaryFromBuffer fp (contents, fileDate) dflags parsed = do

411 (modName, imports) <- FindImports.getImportsParsed dflags parsed

412

@@ -445,7 +445,7 @@ parseFileContents

445 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))

446 -> FilePath -- ^ the filename (for source locations)

447 -> (UTCTime, SB.StringBuffer) -- ^ Haskell module source text (full Unicode is supported)

448− -> Ex.ExceptT [Diagnostic] m ([Diagnostic], ParsedModule)

448+ -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

449parseFileContents preprocessor filename (time, contents) = do

450 let loc = mkRealSrcLoc (mkFastString filename) 1 1

451 dflags <- parsePragmasIntoDynFlags filename contents

@@ -479,7 +479,7 @@ parsePragmasIntoDynFlags

479 :: GhcMonad m

480 => FilePath

481 -> SB.StringBuffer

482− -> Ex.ExceptT [Diagnostic] m DynFlags

482+ -> Ex.ExceptT [FileDiagnostic] m DynFlags

483parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do

484 dflags0 <- getSessionDynFlags

485 let opts = Hdr.getOptions dflags0 contents fp

@@ -494,7 +494,7 @@ generatePackageState paths hideAllPkgs pkgImports = do

494

495-- | Run something in a Ghc monad and catch the errors (SourceErrors and

496-- compiler-internal exceptions like Panic or InstallationError).

497−catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [Diagnostic] m a

497+catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [FileDiagnostic] m a

498catchSrcErrors ghcM = do

499 dflags <- getDynFlags

500 Ex.ExceptT $

src/Development/IDE/Functions/FindImports.hs+3−3

@@ -39,7 +39,7 @@ data Import

39getImportsParsed :: Monad m =>

40 DynFlags ->

41 GHC.ParsedSource ->

42− Ex.ExceptT [Diagnostic] m

42+ Ex.ExceptT [FileDiagnostic] m

43 (M.ModuleName, [(Maybe FastString, Located M.ModuleName)])

44getImportsParsed dflags (L loc parsed) = do

45 let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed

@@ -82,7 +82,7 @@ locateModule

82 -> (FilePath -> m Bool)

83 -> Located ModuleName

84 -> Maybe FastString

85− -> m (Either [Diagnostic] Import)

85+ -> m (Either [FileDiagnostic] Import)

86locateModule dflags doesExist modName mbPkgName = do

87 case mbPkgName of

88 -- if a package name is given we only go look for a package

@@ -101,7 +101,7 @@ locateModule dflags doesExist modName mbPkgName = do

101 reason -> return $ Left $ notFoundErr dfs modName reason

102

103-- | Don't call this on a found module.

104−notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [Diagnostic]

104+notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic]

105notFoundErr dfs modName reason =

106 mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason

107 where

src/Development/IDE/Functions/GHCError.hs+9−8

@@ -5,6 +5,7 @@ module Development.IDE.Functions.GHCError

5 ( mkDiag

6 , toDiagnostics

7 , srcSpanToLocation

8+ , srcSpanToFilename

9 -- * Producing GHC ErrorMessages

10 -- * Producing GHC ErrorMessages

10 , mkErrors

11 , mkErrors

@@ -14,6 +15,7 @@ module Development.IDE.Functions.GHCError

15 -- * Handling errors in the GHC monad (SourceError, ErrorMessages)

16 -- * Handling errors in the GHC monad (SourceError, ErrorMessages)

16 , Diagnostic

17 , Diagnostic

18+ , FileDiagnostic

17 , ErrorMessages -- included in module export below

19 , ErrorMessages -- included in module export below

18 , ErrMsg

20 , ErrMsg

19 , errMsgSpan

21 , errMsgSpan

@@ -26,7 +28,6 @@ module Development.IDE.Functions.GHCError

26 , noSpan

28 , noSpan

27 ) where

29 ) where

29−import Control.Lens

30import Development.IDE.Types.Diagnostics as D

31import Development.IDE.Types.Diagnostics as D

31import qualified Data.Text as T

32import qualified Data.Text as T

32import Development.IDE.UtilGHC()

33import Development.IDE.UtilGHC()

@@ -41,16 +42,16 @@ import qualified Language.Haskell.LSP.Types as LSP

44−toDiagnostics :: DynFlags -> ErrorMessages -> [Diagnostic]

45+toDiagnostics :: DynFlags -> ErrorMessages -> [FileDiagnostic]

45toDiagnostics dflags = mapMaybe (mkDiag dflags $ T.pack "Compiler") . bagToList

46toDiagnostics dflags = mapMaybe (mkDiag dflags $ T.pack "Compiler") . bagToList

48−mkDiag :: DynFlags -> T.Text -> ErrMsg -> Maybe Diagnostic

49+mkDiag :: DynFlags -> T.Text -> ErrMsg -> Maybe FileDiagnostic

49mkDiag dflags src e =

50mkDiag dflags src e =

50 case toDSeverity $ errMsgSeverity e of

51 case toDSeverity $ errMsgSeverity e of

51 Nothing -> Nothing

52 Nothing -> Nothing

52 Just bSeverity ->

53 Just bSeverity ->

53− Just $ set dLocation (Just $ srcSpanToLocation $ errMsgSpan e)

54+ Just $ (srcSpanToFilename $ errMsgSpan e,)

54 Diagnostic

55 Diagnostic

55 { _range = srcSpanToRange $ errMsgSpan e

56 { _range = srcSpanToRange $ errMsgSpan e

56 , _severity = Just bSeverity

57 , _severity = Just bSeverity

@@ -94,15 +95,15 @@ toDSeverity SevFatal = Just DsError

95-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given

96-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given

96-- (optional) locations and message strings.

97-- (optional) locations and message strings.

97−mkErrors :: DynFlags -> [(SrcSpan, String)] -> [Diagnostic]

98+mkErrors :: DynFlags -> [(SrcSpan, String)] -> [FileDiagnostic]

98mkErrors dflags = concatMap (uncurry $ mkError dflags)

99mkErrors dflags = concatMap (uncurry $ mkError dflags)

100

100-- | Produce a GHC-style error from a source span and a message.

101-- | Produce a GHC-style error from a source span and a message.

101−mkError :: DynFlags -> SrcSpan -> String -> [Diagnostic]

102+mkError :: DynFlags -> SrcSpan -> String -> [FileDiagnostic]

102mkError dflags sp = toDiagnostics dflags . Bag.listToBag . pure . mkPlainErrMsg dflags sp . Out.text

103mkError dflags sp = toDiagnostics dflags . Bag.listToBag . pure . mkPlainErrMsg dflags sp . Out.text

103

104

104-- | Produce a GHC-style error from a source span and a message.

105-- | Produce a GHC-style error from a source span and a message.

105−mkErrorDoc :: DynFlags -> SrcSpan -> Out.SDoc -> [Diagnostic]

106+mkErrorDoc :: DynFlags -> SrcSpan -> Out.SDoc -> [FileDiagnostic]

106mkErrorDoc dflags sp = toDiagnostics dflags . Bag.listToBag . pure . mkPlainErrMsg dflags sp

107mkErrorDoc dflags sp = toDiagnostics dflags . Bag.listToBag . pure . mkPlainErrMsg dflags sp

107

108

109

@@ -123,7 +124,7 @@ realSpan = \case

123 UnhelpfulSpan _ -> Nothing

124 UnhelpfulSpan _ -> Nothing

124

125

126

126−mkErrorsGhcException :: DynFlags -> GhcException -> [Diagnostic]

127+mkErrorsGhcException :: DynFlags -> GhcException -> [FileDiagnostic]

127mkErrorsGhcException dflags exc = mkErrors dflags [(noSpan "<Internal>", showGHCE dflags exc)]

128mkErrorsGhcException dflags exc = mkErrors dflags [(noSpan "<Internal>", showGHCE dflags exc)]

128

129

129showGHCE :: DynFlags -> GhcException -> String

130showGHCE :: DynFlags -> GhcException -> String

src/Development/IDE/Functions/Warnings.hs+1−1

@@ -26,7 +26,7 @@ import Development.IDE.Functions.GHCError

26-- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640

27-- which basically says that log_action is taken from the ModSummary when GHC feels like it.

28-- The given argument lets you refresh a ModSummary log_action

29−withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([Diagnostic], a)

29+withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([FileDiagnostic], a)

30withWarnings phase action = do

31 warnings <- liftIO $ newVar []

32 oldFlags <- getDynFlags

src/Development/IDE/State/Rules.hs+10−10

@@ -25,7 +25,6 @@ module Development.IDE.State.Rules(

26import Control.Concurrent.Extra

27import Control.Exception (evaluate)

28−import Control.Lens (set)

29import Control.Monad.Except

28import Control.Monad.Except

30import Control.Monad.Extra (whenJust)

29import Control.Monad.Extra (whenJust)

31import qualified Development.IDE.Functions.Compile as Compile

30import qualified Development.IDE.Functions.Compile as Compile

@@ -56,11 +55,11 @@ import Development.IDE.State.Shake

57-- LEGACY STUFF ON THE OLD STYLE

56-- LEGACY STUFF ON THE OLD STYLE

59−toIdeResultNew :: Either [Diagnostic] v -> IdeResult v

58+toIdeResultNew :: Either [FileDiagnostic] v -> IdeResult v

60toIdeResultNew = either (, Nothing) (([],) . Just)

59toIdeResultNew = either (, Nothing) (([],) . Just)

62-- Convert to a legacy Ide result but dropping dependencies

61-- Convert to a legacy Ide result but dropping dependencies

63−toIdeResultSilent :: Maybe v -> Either [Diagnostic] v

62+toIdeResultSilent :: Maybe v -> Either [FileDiagnostic] v

64toIdeResultSilent val = maybe (Left []) Right val

63toIdeResultSilent val = maybe (Left []) Right val

@@ -116,17 +115,17 @@ getDefinition file pos = do

116

115

117useE

116useE

118 :: IdeRule k v

117 :: IdeRule k v

119− => k -> FilePath -> ExceptT [Diagnostic] Action v

118+ => k -> FilePath -> ExceptT [FileDiagnostic] Action v

120useE k = ExceptT . fmap toIdeResultSilent . use k

119useE k = ExceptT . fmap toIdeResultSilent . use k

121

120

122-- picks the first error

121-- picks the first error

123usesE

122usesE

124 :: IdeRule k v

123 :: IdeRule k v

125− => k -> [FilePath] -> ExceptT [Diagnostic] Action [v]

124+ => k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]

126usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k

125usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k

127

126

128-- | Generate the GHC Core for the supplied file and its dependencies.

127-- | Generate the GHC Core for the supplied file and its dependencies.

129−coresForFile :: FilePath -> ExceptT [Diagnostic] Action [CoreModule]

128+coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]

130coresForFile file = do

129coresForFile file = do

131 files <- transitiveModuleDeps <$> useE GetDependencies file

130 files <- transitiveModuleDeps <$> useE GetDependencies file

132 pms <- usesE GetParsedModule $ files ++ [file]

131 pms <- usesE GetParsedModule $ files ++ [file]

@@ -141,14 +140,14 @@ coresForFile file = do

141getAtPointForFile

140getAtPointForFile

142 :: FilePath

141 :: FilePath

143 -> Position

142 -> Position

144− -> ExceptT [Diagnostic] Action (Maybe (Maybe Range, [HoverText]))

143+ -> ExceptT [FileDiagnostic] Action (Maybe (Maybe Range, [HoverText]))

145getAtPointForFile file pos = do

144getAtPointForFile file pos = do

146 files <- transitiveModuleDeps <$> useE GetDependencies file

145 files <- transitiveModuleDeps <$> useE GetDependencies file

147 tms <- usesE TypeCheck (file : files)

146 tms <- usesE TypeCheck (file : files)

148 spans <- useE GetSpanInfo file

147 spans <- useE GetSpanInfo file

149 return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos

148 return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos

150

149

151−getDefinitionForFile :: FilePath -> Position -> ExceptT [Diagnostic] Action (Maybe Location)

150+getDefinitionForFile :: FilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)

152getDefinitionForFile file pos = do

151getDefinitionForFile file pos = do

153 spans <- useE GetSpanInfo file

152 spans <- useE GetSpanInfo file

154 return $ AtPoint.gotoDefinition spans pos

153 return $ AtPoint.gotoDefinition spans pos

@@ -193,7 +192,7 @@ getLocatedImportsRule =

193

192

194-- | Given a target file path, construct the raw dependency results by following

193-- | Given a target file path, construct the raw dependency results by following

195-- imports recursively.

194-- imports recursively.

196−rawDependencyInformation :: FilePath -> ExceptT [Diagnostic] Action RawDependencyInformation

195+rawDependencyInformation :: FilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation

197rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty

196rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty

198 where go fs !modGraph !pkgs =

197 where go fs !modGraph !pkgs =

199 case Set.minView fs of

198 case Set.minView fs of

@@ -241,7 +240,7 @@ reportImportCyclesRule =

241 where cycleErrorInFile f (PartOfCycle imp fs)

240 where cycleErrorInFile f (PartOfCycle imp fs)

242 | f `elem` fs = Just (imp, fs)

241 | f `elem` fs = Just (imp, fs)

243 cycleErrorInFile _ _ = Nothing

242 cycleErrorInFile _ _ = Nothing

244− toDiag imp mods = set dLocation (Just loc) $ Diagnostic

243+ toDiag imp mods = (fp ,) $ Diagnostic

245 { _range = (_range :: Location -> Range) loc

244 { _range = (_range :: Location -> Range) loc

246 , _severity = Just DsError

245 , _severity = Just DsError

247 , _source = Just "Import cycle detection"

246 , _source = Just "Import cycle detection"

@@ -250,6 +249,7 @@ reportImportCyclesRule =

250 , _relatedInformation = Nothing

249 , _relatedInformation = Nothing

251 }

250 }

252 where loc = srcSpanToLocation (getLoc imp)

251 where loc = srcSpanToLocation (getLoc imp)

252+ fp = srcSpanToFilename (getLoc imp)

253 getModuleName file = do

254 pm <- useE GetParsedModule file

255 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

src/Development/IDE/State/Service.hs+1−1

@@ -59,7 +59,7 @@ mkEnv options = do

59 , envUniqSupplyVar = uniqSupplyVar

60 }

62−getDiagnostics :: IdeState -> IO [Diagnostic]

62+getDiagnostics :: IdeState -> IO [FileDiagnostic]

63getDiagnostics = getAllDiagnostics

65unsafeClearDiagnostics :: IdeState -> IO ()

src/Development/IDE/State/Shake.hs+8−9

@@ -61,7 +61,6 @@ import Development.IDE.Types.Diagnostics

61import Control.Concurrent.Extra

62import Control.Exception

63import Control.DeepSeq

64−import Control.Lens (view, set)

65import System.Time.Extra

64import System.Time.Extra

66import Data.Typeable

65import Data.Typeable

67import Data.Tuple.Extra

66import Data.Tuple.Extra

@@ -149,7 +148,7 @@ instance Hashable Key where

149--

148--

150-- A rule on a file should only return diagnostics for that given file. It should

149-- A rule on a file should only return diagnostics for that given file. It should

151-- not propagate diagnostic errors through multiple phases.

150-- not propagate diagnostic errors through multiple phases.

152−type IdeResult v = ([Diagnostic], Maybe v)

151+type IdeResult v = ([FileDiagnostic], Maybe v)

153

152

154type IdeRule k v =

153type IdeRule k v =

155 ( Shake.RuleResult k ~ v

154 ( Shake.RuleResult k ~ v

@@ -198,7 +197,7 @@ setValues :: IdeRule k v

198 -> k

197 -> k

199 -> FilePath

198 -> FilePath

200 -> IdeResult v

199 -> IdeResult v

201− -> IO (Maybe [Diagnostic], [Diagnostic]) -- ^ (before, after)

200+ -> IO (Maybe [FileDiagnostic], [FileDiagnostic]) -- ^ (before, after)

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

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

203 let k = Key key

202 let k = Key key

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

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

@@ -261,7 +260,7 @@ useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =

261 join <$> getValues state k fp

260 join <$> getValues state k fp

262

261

263

262

264−getAllDiagnostics :: IdeState -> IO [Diagnostic]

263+getAllDiagnostics :: IdeState -> IO [FileDiagnostic]

265getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do

264getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do

266 val <- readVar state

265 val <- readVar state

267 return $ concatMap (concatMap fst . Map.elems) $ Map.elems val

266 return $ concatMap (concatMap fst . Map.elems) $ Map.elems val

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

362 (bs, res) <- actionCatch

361 (bs, res) <- actionCatch

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

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

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

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

365− res <- return $ first (map $ set dFilePath $ Just file) res

364+ res <- return $ first (map $ \(_,d) -> (file,d)) res

366

365

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

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

368 updateFileDiagnostics file before after

367 updateFileDiagnostics file before after

@@ -380,8 +379,8 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m

380

379

381updateFileDiagnostics ::

380updateFileDiagnostics ::

382 FilePath

381 FilePath

383− -> Maybe [Diagnostic] -- ^ previous results for this file

382+ -> Maybe [FileDiagnostic] -- ^ previous results for this file

384− -> [Diagnostic] -- ^ current results

383+ -> [FileDiagnostic] -- ^ current results

385 -> Action ()

384 -> Action ()

386updateFileDiagnostics afp previousAll currentAll = do

385updateFileDiagnostics afp previousAll currentAll = do

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

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

@@ -392,13 +391,13 @@ updateFileDiagnostics afp previousAll currentAll = do

392 let filtM diags = do

391 let filtM diags = do

393 diags' <-

392 diags' <-

394 filterM

393 filterM

395− (\x -> fmap (== Just afp') (traverse canonicalizePath $ view dFilePath x))

394+ (\x -> fmap (== afp') (canonicalizePath $ fst x))

396 diags

395 diags

397 pure (Set.fromList diags')

396 pure (Set.fromList diags')

398 previous <- liftIO $ traverse filtM previousAll

397 previous <- liftIO $ traverse filtM previousAll

399 current <- liftIO $ filtM currentAll

398 current <- liftIO $ filtM currentAll

400 when (Just current /= previous) $

399 when (Just current /= previous) $

401− sendEvent $ EventFileDiagnostics $ (filePathToUri afp, Set.toList current)

400+ sendEvent $ EventFileDiagnostics $ (afp, map snd $ Set.toList current)

402

401

403

402

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

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

src/Development/IDE/Types/Diagnostics.hs+19−70

@@ -8,6 +8,7 @@

8module Development.IDE.Types.Diagnostics (

9 LSP.Diagnostic(..),

10 FileDiagnostics,

11+ FileDiagnostic,

11 Location(..),

12 Location(..),

12 Range(..),

13 Range(..),

13 LSP.DiagnosticSeverity(..),

14 LSP.DiagnosticSeverity(..),

@@ -30,21 +31,17 @@ module Development.IDE.Types.Diagnostics (

30 defDiagnostic,

31 defDiagnostic,

31 addDiagnostics,

32 addDiagnostics,

32 filterSeriousErrors,

33 filterSeriousErrors,

33− dLocation,

34− dFilePath,

35 filePathToUri,

34 filePathToUri,

36 getDiagnosticsFromStore

35 getDiagnosticsFromStore

37 ) where

36 ) where

39import Control.Exception

38import Control.Exception

40−import Control.Lens (Lens', lens, set, view)

41import Data.Either.Combinators

39import Data.Either.Combinators

42import Data.Maybe as Maybe

40import Data.Maybe as Maybe

43import Data.Foldable

41import Data.Foldable

44import qualified Data.Map as Map

42import qualified Data.Map as Map

45import qualified Data.Text as T

43import qualified Data.Text as T

46import Data.Text.Prettyprint.Doc.Syntax

44import Data.Text.Prettyprint.Doc.Syntax

47−import Data.String (IsString(..))

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

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

49import Language.Haskell.LSP.Types as LSP (

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

50 DiagnosticSeverity(..)

47 DiagnosticSeverity(..)

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

60import Development.IDE.Types.Location

57import Development.IDE.Types.Location

62−ideErrorText :: FilePath -> T.Text -> LSP.Diagnostic

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

63ideErrorText fp = errorDiag fp "Ide Error"

60ideErrorText fp = errorDiag fp "Ide Error"

65−ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> LSP.Diagnostic

62+ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> FileDiagnostic

66ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow

63ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow

68−errorDiag :: FilePath -> T.Text -> T.Text -> LSP.Diagnostic

65+errorDiag :: FilePath -> T.Text -> T.Text -> FileDiagnostic

69−errorDiag fp src =

66+errorDiag fp src msg =

70− set dFilePath (Just fp) . diagnostic noRange LSP.DsError src

67+ (fp, diagnostic noRange LSP.DsError src msg)

72-- | This is for compatibility with our old diagnostic type

69-- | This is for compatibility with our old diagnostic type

73diagnostic :: Range

70diagnostic :: Range

@@ -99,33 +96,6 @@ defDiagnostic _range _message = LSP.Diagnostic {

99 , _relatedInformation = Nothing

96 , _relatedInformation = Nothing

100 }

97 }

101

102−-- | setLocation but with no range information

103−dFilePath ::

104− Lens' LSP.Diagnostic (Maybe FilePath)

105−dFilePath = lens g s where

106− g :: LSP.Diagnostic -> Maybe FilePath

107− g d = (uriToFilePath . _uri) =<< view dLocation d

108− s :: LSP.Diagnostic -> Maybe FilePath -> LSP.Diagnostic

109− s d@Diagnostic{..} fp = set dLocation

110− (Location <$> (filePathToUri <$> fp) <*> pure _range) d

111−

112−-- | This adds location information to the diagnostics but this is only used in

113−-- the case of serious errors to give some context to what went wrong

114−dLocation ::

115− Lens' LSP.Diagnostic (Maybe Location)

116−dLocation = lens g s where

117− s :: LSP.Diagnostic -> Maybe Location -> LSP.Diagnostic

118− s d = \case

119− Just loc ->

120− d {LSP._range=(_range :: Location -> Range) loc

121− , LSP._relatedInformation = Just $ LSP.List [DiagnosticRelatedInformation loc "dLocation: Unknown error"]}

122− Nothing -> d {LSP._range = noRange, LSP._relatedInformation = Nothing}

123− g :: LSP.Diagnostic -> Maybe Location

124− g Diagnostic{..} = case _relatedInformation of

125− Just (List [DiagnosticRelatedInformation loc _]) -> Just loc

126− Just (List xs) -> error $ "Diagnostic created, expected 1 related information but got" <> show xs

127− Nothing -> Nothing

128−

129filterSeriousErrors ::

99filterSeriousErrors ::

130 FilePath ->

100 FilePath ->

131 [LSP.Diagnostic] ->

101 [LSP.Diagnostic] ->

@@ -148,7 +118,7 @@ addDiagnostics fp diags ds =

148 Nothing $

118 Nothing $

149 partitionBySource diags

119 partitionBySource diags

150

120

151−ideTryIOException :: FilePath -> IO a -> IO (Either LSP.Diagnostic a)

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

152ideTryIOException fp act =

122ideTryIOException fp act =

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

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

154

124

@@ -158,7 +128,8 @@ ideTryIOException fp act =

158-- along with the related source location so that we can display the error

128-- along with the related source location so that we can display the error

159-- on either the console or in the IDE at the right source location.

129-- on either the console or in the IDE at the right source location.

160--

130--

161−type FileDiagnostics = (Uri, [Diagnostic])

131+type FileDiagnostics = (FilePath, [Diagnostic])

132+type FileDiagnostic = (FilePath, Diagnostic)

162

133

163prettyRange :: Range -> Doc SyntaxClass

134prettyRange :: Range -> Doc SyntaxClass

164prettyRange Range{..} = f _start <> "-" <> f _end

135prettyRange Range{..} = f _start <> "-" <> f _end

@@ -167,20 +138,20 @@ prettyRange Range{..} = f _start <> "-" <> f _end

167stringParagraphs :: T.Text -> Doc a

138stringParagraphs :: T.Text -> Doc a

168stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines

139stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines

169

140

170−showDiagnostics :: [LSP.Diagnostic] -> T.Text

141+showDiagnostics :: [FileDiagnostic] -> T.Text

171showDiagnostics = srenderPlain . prettyDiagnostics

142showDiagnostics = srenderPlain . prettyDiagnostics

172

143

173−showDiagnosticsColored :: [LSP.Diagnostic] -> T.Text

144+showDiagnosticsColored :: [FileDiagnostic] -> T.Text

174showDiagnosticsColored = srenderColored . prettyDiagnostics

145showDiagnosticsColored = srenderColored . prettyDiagnostics

175

146

176

147

177−prettyDiagnostics :: [LSP.Diagnostic] -> Doc SyntaxClass

148+prettyDiagnostics :: [FileDiagnostic] -> Doc SyntaxClass

178prettyDiagnostics = vcat . map prettyDiagnostic

149prettyDiagnostics = vcat . map prettyDiagnostic

179

150

180−prettyDiagnostic :: LSP.Diagnostic -> Doc SyntaxClass

151+prettyDiagnostic :: FileDiagnostic -> Doc SyntaxClass

181−prettyDiagnostic d@LSP.Diagnostic{..} =

152+prettyDiagnostic (fp, LSP.Diagnostic{..}) =

182 vcat

153 vcat

183− [ slabel_ "File: " $ pretty $ view dFilePath d

154+ [ slabel_ "File: " $ pretty fp

184 , slabel_ "Range: " $ prettyRange _range

155 , slabel_ "Range: " $ prettyRange _range

185 , slabel_ "Source: " $ pretty _source

156 , slabel_ "Source: " $ pretty _source

186 , slabel_ "Severity:" $ pretty $ show sev

157 , slabel_ "Severity:" $ pretty $ show sev

@@ -199,38 +170,16 @@ prettyDiagnostic d@LSP.Diagnostic{..} =

199prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass

170prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass

200prettyDiagnosticStore ds =

171prettyDiagnosticStore ds =

201 vcat $

172 vcat $

202− map prettyFileDiagnostics $

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

203 Map.assocs $

174 Map.assocs $

204 Map.map getDiagnosticsFromStore ds

175 Map.map getDiagnosticsFromStore ds

205

176

206prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass

177prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass

207−prettyFileDiagnostics (uri, diags) =

178+prettyFileDiagnostics (filePath, diags) =

208 slabel_ "Compiler error in" $ vcat

179 slabel_ "Compiler error in" $ vcat

209 [ slabel_ "File:" $ pretty filePath

180 [ slabel_ "File:" $ pretty filePath

210− , slabel_ "Errors:" $ vcat $ map prettyDiagnostic diags

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

211− ] where

182+ ]

212−

213− -- prettyFileDiags :: (FilePath, [(T.Text, [LSP.Diagnostic])]) -> Doc SyntaxClass

214− -- prettyFileDiags (fp,stages) =

215− -- slabel_ ("File: "<>fp) $ vcat $ map prettyStage stages

216−

217− -- prettyStage :: (T.Text, [LSP.Diagnostic]) -> Doc SyntaxClass

218− -- prettyStage (stage,diags) =

219− -- slabel_ ("Stage: "<>T.unpack stage) $ vcat $ map prettyDiagnostic diags

220−

221− filePath :: FilePath

222− filePath = fromMaybe dontKnow $ uriToFilePath uri

223−

224− -- storeContents ::

225− -- (FilePath, [(T.Text, [LSP.Diagnostic])])

226− -- -- ^ Source File, Stage Source, Diags

227− -- storeContents = (fromMaybe dontKnow $ uriToFilePath uri, getDiags diags)

228−

229− dontKnow :: IsString s => s

230− dontKnow = "<unknown>"

231−

232− -- getDiags :: DiagnosticsBySource -> [(T.Text, [LSP.Diagnostic])]

233− -- getDiags = map (\(ds, diag) -> (fromMaybe dontKnow ds, toList diag)) . Map.assocs

234

183

235getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

184getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

236getDiagnosticsFromStore (StoreItem _ diags) =

185getDiagnosticsFromStore (StoreItem _ diags) =