c72b734 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

New diagnostics implementation (#737)

c72b734DavidM-D7 years ago

BUILD.bazel+3

compare with master

unifiedsplit

@@ -20,6 +20,9 @@ da_haskell_library(

20 "ghc-lib",

21 "ghc-lib-parser",

22 "hashable",

23+ "haskell-lsp",

24+ "haskell-lsp-types",

25+ "lens",

23 "mtl",

26 "mtl",

24 "pretty",

27 "pretty",

25 "safe-exceptions",

28 "safe-exceptions",

src/Development/IDE/Functions/AtPoint.hs+2−2

@@ -80,8 +80,8 @@ locationsAtPoint pos = map srcSpanToLocation

81spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]

82spansAtPoint pos = filter atp where

83− line = positionLine pos + 1

83+ line = _line pos + 1

84− cha = positionCharacter pos + 1

84+ cha = _character pos + 1

85 atp SpanInfo{..} = spaninfoStartLine <= line

86 && spaninfoEndLine >= line

87 && spaninfoStartCol <= cha

src/Development/IDE/Functions/GHCError.hs+18−14

@@ -1,6 +1,6 @@

2-- SPDX-License-Identifier: Apache-2.0

3−

3+{-# LANGUAGE DuplicateRecordFields #-}

4module Development.IDE.Functions.GHCError

5 ( mkDiag

6 , toDiagnostics

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

26 , noSpan

27 ) where

29+import Control.Lens

29import Development.IDE.Types.Diagnostics as D

30import Development.IDE.Types.Diagnostics as D

30import qualified Data.Text as T

31import qualified Data.Text as T

31import Development.IDE.UtilGHC()

32import Development.IDE.UtilGHC()

@@ -36,6 +37,7 @@ import Data.Maybe

36import "ghc-lib-parser" ErrUtils

37import "ghc-lib-parser" ErrUtils

37import "ghc-lib-parser" SrcLoc

38import "ghc-lib-parser" SrcLoc

38import qualified "ghc-lib-parser" Outputable as Out

39import qualified "ghc-lib-parser" Outputable as Out

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

@@ -48,18 +50,19 @@ mkDiag dflags src e =

48 case toDSeverity $ errMsgSeverity e of

50 case toDSeverity $ errMsgSeverity e of

49 Nothing -> Nothing

51 Nothing -> Nothing

50 Just bSeverity ->

52 Just bSeverity ->

51− Just

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

52 Diagnostic

54 Diagnostic

53− { dFilePath = srcSpanToFilename $ errMsgSpan e

54− , dRange = srcSpanToRange $ errMsgSpan e

55+ { _range = srcSpanToRange $ errMsgSpan e

55− , dSeverity = bSeverity

56+ , _severity = Just bSeverity

56− , dSource = src

57+ , _source = Just src

57− , dMessage = T.pack $ Out.showSDoc dflags (ErrUtils.pprLocErrMsg e)

58+ , _message = T.pack $ Out.showSDoc dflags (ErrUtils.pprLocErrMsg e)

59+ , _code = Nothing

60+ , _relatedInformation = Nothing

58 }

61 }

60-- | Convert a GHC SrcSpan to a DAML compiler Range

63-- | Convert a GHC SrcSpan to a DAML compiler Range

61srcSpanToRange :: SrcSpan -> Range

64srcSpanToRange :: SrcSpan -> Range

62−srcSpanToRange (UnhelpfulSpan _) = lRange noLocation

65+srcSpanToRange (UnhelpfulSpan _) = noRange

63srcSpanToRange (RealSrcSpan real) = realSrcSpanToRange real

66srcSpanToRange (RealSrcSpan real) = realSrcSpanToRange real

65realSrcSpanToRange :: RealSrcSpan -> Range

68realSrcSpanToRange :: RealSrcSpan -> Range

@@ -74,18 +77,19 @@ srcSpanToFilename (UnhelpfulSpan fs) = FS.unpackFS fs

74srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

77srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

76srcSpanToLocation :: SrcSpan -> Location

79srcSpanToLocation :: SrcSpan -> Location

80+srcSpanToLocation src =

77−srcSpanToLocation src = Location (srcSpanToFilename src) (srcSpanToRange src)

81+ Location (LSP.filePathToUri $ srcSpanToFilename src) (srcSpanToRange src)

79-- | Convert a GHC severity to a DAML compiler Severity. Severities below

83-- | Convert a GHC severity to a DAML compiler Severity. Severities below

80-- "Warning" level are dropped (returning Nothing).

84-- "Warning" level are dropped (returning Nothing).

81−toDSeverity :: GHC.Severity -> Maybe D.Severity

85+toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity

82toDSeverity SevOutput = Nothing

86toDSeverity SevOutput = Nothing

83toDSeverity SevInteractive = Nothing

87toDSeverity SevInteractive = Nothing

84toDSeverity SevDump = Nothing

88toDSeverity SevDump = Nothing

85−toDSeverity SevInfo = Nothing

89+toDSeverity SevInfo = Just DsInfo

86−toDSeverity SevWarning = Just D.Warning

90+toDSeverity SevWarning = Just DsWarning

87−toDSeverity SevError = Just Error

91+toDSeverity SevError = Just DsError

88−toDSeverity SevFatal = Just Error

92+toDSeverity SevFatal = Just DsError

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

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

src/Development/IDE/State/Rules.hs+9−6

@@ -4,6 +4,7 @@

4{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE DuplicateRecordFields #-}

8-- | A Shake implementation of the compiler service, built

9-- | A Shake implementation of the compiler service, built

9-- using the "Shaker" abstraction layer for in-memory use.

10-- using the "Shaker" abstraction layer for in-memory use.

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

25import Control.Concurrent.Extra

26import Control.Concurrent.Extra

26import Control.Exception (evaluate)

27import Control.Exception (evaluate)

28+import Control.Lens (set)

27import Control.Monad.Except

29import Control.Monad.Except

28import Control.Monad.Extra (whenJust)

30import Control.Monad.Extra (whenJust)

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

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

@@ -239,12 +241,13 @@ reportImportCyclesRule =

239 where cycleErrorInFile f (PartOfCycle imp fs)

241 where cycleErrorInFile f (PartOfCycle imp fs)

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

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

241 cycleErrorInFile _ _ = Nothing

243 cycleErrorInFile _ _ = Nothing

242− toDiag imp mods = Diagnostic

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

243− { dFilePath = lFilePath loc

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

244− , dRange = lRange loc

246+ , _severity = Just DsError

245− , dSeverity = Error

246− , dSource = "Import cycle detection"

247+ , _source = Just "Import cycle detection"

247− , dMessage = "Cyclic module dependency between " <> showCycle mods

248+ , _message = "Cyclic module dependency between " <> showCycle mods

249+ , _code = Nothing

250+ , _relatedInformation = Nothing

248 }

251 }

249 where loc = srcSpanToLocation (getLoc imp)

252 where loc = srcSpanToLocation (getLoc imp)

250 getModuleName file = do

253 getModuleName file = do

src/Development/IDE/State/Shake.hs+19−16

@@ -4,6 +4,8 @@

4{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE ConstraintKinds #-}

7+{-# LANGUAGE DuplicateRecordFields #-}

8+{-# LANGUAGE OverloadedStrings #-}

8-- | A Shake implementation of the compiler service.

10-- | A Shake implementation of the compiler service.

9--

11--

@@ -59,9 +61,11 @@ import Development.IDE.Types.Diagnostics

59import Control.Concurrent.Extra

61import Control.Concurrent.Extra

60import Control.Exception

62import Control.Exception

61import Control.DeepSeq

63import Control.DeepSeq

64+import Control.Lens (view, set)

62import System.Time.Extra

65import System.Time.Extra

63import Data.Typeable

66import Data.Typeable

64import Data.Tuple.Extra

67import Data.Tuple.Extra

68+import System.Directory

65import System.FilePath

69import System.FilePath

66import qualified Development.Shake as Shake

70import qualified Development.Shake as Shake

67import Control.Monad.Extra

71import Control.Monad.Extra

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

358 (bs, res) <- actionCatch

362 (bs, res) <- actionCatch

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

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

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

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

361− res <- return $ first (map $ fixDiagnostic file) res

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

362−

363− let badErrors = filter (\d -> null file || dRange d == noRange) $ fst res

364− when (badErrors /= []) $

365− reportSeriousError $ "Bad errors found for " ++ show (key, file) ++ " got " ++ show badErrors

366

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

368 updateFileDiagnostics file before after

@@ -378,24 +378,27 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m

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

379

380

381−-- | If any diagnostic has the wrong filename, generate a new diagnostic with the right file name

382−fixDiagnostic :: FilePath -> Diagnostic -> Diagnostic

383−fixDiagnostic x d

384− | dFilePath d == x = d

385− | otherwise = d{dFilePath = x, dRange = noRange, dMessage = T.pack ("Originally reported at " ++ dFilePath d ++ "\n") <> dMessage d}

386−

387−

388updateFileDiagnostics ::

381updateFileDiagnostics ::

389 FilePath

382 FilePath

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

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

391 -> [Diagnostic] -- ^ current results

384 -> [Diagnostic] -- ^ current results

392 -> Action ()

385 -> Action ()

393updateFileDiagnostics afp previousAll currentAll = do

386updateFileDiagnostics afp previousAll currentAll = do

394− let filt = Set.fromList . filter (\x -> dFilePath x == afp)

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

388+ -- / and \ and other shenanigans.

389+ -- Once we have finished the migration to haskell-lsp we should make sure that

390+ -- this is no longer necessary.

391+ afp' <- liftIO $ canonicalizePath afp

392+ let filtM diags = do

393+ diags' <-

394+ filterM

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

396+ diags

397+ pure (Set.fromList diags')

395− previous = fmap filt previousAll

398+ previous <- liftIO $ traverse filtM previousAll

396− current = filt currentAll

399+ current <- liftIO $ filtM currentAll

397 when (Just current /= previous) $

400 when (Just current /= previous) $

398− sendEvent $ EventFileDiagnostics $ FileDiagnostics afp $ Set.toList current

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

399

402

400

403

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

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

src/Development/IDE/Types/Diagnostics.hs+190−93

@@ -3,137 +3,234 @@

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE DuplicateRecordFields #-}

7+{-# LANGUAGE BlockArguments #-}

6module Development.IDE.Types.Diagnostics (

8module Development.IDE.Types.Diagnostics (

7− Diagnostic(..),

9+ LSP.Diagnostic(..),

8− FileDiagnostics(..),

10+ FileDiagnostics,

9 Location(..),

11 Location(..),

10 Range(..),

12 Range(..),

11− Severity(..),

13+ LSP.DiagnosticSeverity(..),

12 Position(..),

14 Position(..),

15+ DiagnosticStore,

16+ DiagnosticRelatedInformation(..),

17+ List(..),

18+ StoreItem(..),

19+ Uri(..),

13 noLocation,

20 noLocation,

14 noRange,

21 noRange,

22+ noFilePath,

15 ideErrorText,

23 ideErrorText,

16 ideErrorPretty,

24 ideErrorPretty,

17 errorDiag,

25 errorDiag,

18 ideTryIOException,

26 ideTryIOException,

19 prettyFileDiagnostics,

27 prettyFileDiagnostics,

20− prettyDiagnostic

28+ prettyDiagnostic,

29+ prettyDiagnosticStore,

30+ defDiagnostic,

31+ addDiagnostics,

32+ filterSeriousErrors,

33+ dLocation,

34+ dFilePath,

35+ filePathToUri,

36+ getDiagnosticsFromStore

21 ) where

37 ) where

23−import Control.DeepSeq

24import Control.Exception

39import Control.Exception

25−import Data.Aeson (FromJSON, ToJSON)

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

26import Data.Either.Combinators

41import Data.Either.Combinators

27−import Data.List.Extra

42+import Data.Maybe as Maybe

43+import Data.Foldable

44+import qualified Data.Map as Map

28import qualified Data.Text as T

45import qualified Data.Text as T

29import Data.Text.Prettyprint.Doc.Syntax

46import Data.Text.Prettyprint.Doc.Syntax

30−import GHC.Generics

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

31−import qualified Network.URI.Encode

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

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

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

50+ DiagnosticSeverity(..)

51+ , Diagnostic(..)

52+ , filePathToUri

53+ , uriToFilePath

54+ , List(..)

55+ , DiagnosticRelatedInformation(..)

56+ , Uri(..)

57+ )

58+import Language.Haskell.LSP.Diagnostics

34import Development.IDE.Types.Location

60import Development.IDE.Types.Location

36−ideErrorText :: FilePath -> T.Text -> Diagnostic

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

37−ideErrorText absFile = errorDiag absFile "Ide Error"

63+ideErrorText fp = errorDiag fp "Ide Error"

38−

64+

39−ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> Diagnostic

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

40−ideErrorPretty absFile = ideErrorText absFile . T.pack . Pretty.prettyShow

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

41−

67+

42−errorDiag :: FilePath -> T.Text -> T.Text -> Diagnostic

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

43−errorDiag fp src msg =

69+errorDiag fp src =

44− Diagnostic

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

45− { dFilePath = fp

71+

46− , dRange = noRange

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

47− , dSeverity = Error

73+diagnostic :: Range

48− , dSource = src

74+ -> LSP.DiagnosticSeverity

49− , dMessage = msg

75+ -> T.Text -- ^ source

76+ -> T.Text -- ^ message

77+ -> LSP.Diagnostic

78+diagnostic rng sev src msg

79+ = LSP.Diagnostic {

80+ _range = rng,

81+ _severity = Just sev,

82+ _code = Nothing,

83+ _source = Just src,

84+ _message = msg,

85+ _relatedInformation = Nothing

86+ }

87+

88+-- | Any optional field is instantiated to Nothing

89+defDiagnostic ::

90+ Range ->

91+ T.Text -> -- ^ error message

92+ LSP.Diagnostic

93+defDiagnostic _range _message = LSP.Diagnostic {

94+ _range

95+ , _message

96+ , _severity = Nothing

97+ , _code = Nothing

98+ , _source = Nothing

99+ , _relatedInformation = Nothing

50 }

100 }

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+

129+filterSeriousErrors ::

130+ FilePath ->

131+ [LSP.Diagnostic] ->

132+ [LSP.Diagnostic]

133+filterSeriousErrors fp =

134+ filter (maybe False hasSeriousErrors . LSP._relatedInformation)

135+ where

136+ hasSeriousErrors :: List DiagnosticRelatedInformation -> Bool

137+ hasSeriousErrors (List a) = any ((/=) uri . _uri . _location) a

138+ uri = LSP.filePathToUri fp

139+

140+addDiagnostics ::

141+ FilePath ->

142+ [LSP.Diagnostic] ->

143+ DiagnosticStore -> DiagnosticStore

144+addDiagnostics fp diags ds =

145+ updateDiagnostics

146+ ds

147+ (LSP.filePathToUri fp)

148+ Nothing $

149+ partitionBySource diags

150+

52−ideTryIOException :: FilePath -> IO a -> IO (Either Diagnostic a)

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

53ideTryIOException fp act =

152ideTryIOException fp act =

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

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

154

56−data Diagnostic = Diagnostic

57− { dFilePath :: !FilePath

58− -- ^ Specific file that the diagnostic refers to.

59− , dRange :: !Range

60− -- ^ The range to which the diagnostic applies.

61− , dSeverity :: !Severity

62− -- ^ The severity of the diagnostic, such as 'SError' or 'SWarning'.

63− , dSource :: !T.Text

64− -- ^ Human-readable description for the source of the diagnostic,

65− -- for example 'parser'.

66− , dMessage :: !T.Text

67− -- ^ The diagnostic's message.

68− }

69− deriving (Eq, Ord, Show, Generic)

70−

71−instance NFData Diagnostic

72−

73−-- | The diagnostic severity.

74−data Severity

75− = Error | Warning

76− deriving (Eq, Ord, Show, Generic)

77−

78−instance NFData Severity

79−

80-- | Human readable diagnostics for a specific file.

155-- | Human readable diagnostics for a specific file.

81--

156--

82-- This type packages a pretty printed, human readable error message

157-- This type packages a pretty printed, human readable error message

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

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

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

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

85--

160--

86−data FileDiagnostics = FileDiagnostics

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

87− { fdFilePath :: !FilePath

88− -- ^ Path of the module that we were trying to process.

89− -- In a multi-module program this is the file that we started

90− -- trying to compile, not necessarily the one in which we found the

91− -- reported errors or warnings.

92− , fdDiagnostics :: ![Diagnostic]

93− -- ^ Diagnostics for the desired module,

94− -- as well as any transitively imported modules.

95− }

96− deriving (Eq, Ord, Show, Generic)

97−

98−instance FromJSON Diagnostic

99−instance ToJSON Diagnostic

100−

101−instance FromJSON Severity

102−instance ToJSON Severity

103−

104−instance FromJSON FileDiagnostics

105−instance ToJSON FileDiagnostics

106

162

107−prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass

163+prettyRange :: Range -> Doc SyntaxClass

108−prettyFileDiagnostics (FileDiagnostics filePath diagnostics) =

164+prettyRange Range{..} =

109− label_ "Compiler error in" $ vcat

165+ label_ "Range" $ vcat

110− [ label_ "File:" $ pretty filePath

166+ [ label_ "Start:" $ prettyPosition _start

111− , label_ "Errors:" $ vcat $ map prettyDiagnostic $ nubOrd diagnostics

167+ , label_ "End: " $ prettyPosition _end

168+ ]

169+

170+prettyPosition :: Position -> Doc SyntaxClass

171+prettyPosition Position{..} = label_ "Position" $ vcat

172+ [ label_ "Line:" $ pretty _line

173+ , label_ "Character:" $ pretty _character

112− ]

174+ ]

113

175

114stringParagraphs :: T.Text -> Doc a

176stringParagraphs :: T.Text -> Doc a

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

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

116

178

117−prettyDiagnostic :: Diagnostic -> Doc SyntaxClass

179+prettyDiagnostic :: LSP.Diagnostic -> Doc SyntaxClass

118−prettyDiagnostic (Diagnostic filePath range severity source msg) =

180+prettyDiagnostic LSP.Diagnostic{..} =

119 vcat

181 vcat

120− [ label_ "File: " $ pretty filePath

121− , label_ "Range: "

182+ [label_ "Range: "

122− $ annotate (LinkSC uri title)

183+ $ prettyRange _range

123− $ pretty range

124− , label_ "Source: " $ pretty source

184+ , label_ "Source: " $ pretty _source

125− , label_ "Severity:" $ pretty $ show severity

185+ , label_ "Severity:" $ pretty $ show sev

126 , label_ "Message: "

186 , label_ "Message: "

127− $ case severity of

187+ $ case sev of

128− Error -> annotate ErrorSC

188+ LSP.DsError -> annotate ErrorSC

129− Warning -> annotate WarningSC

189+ LSP.DsWarning -> annotate WarningSC

190+ LSP.DsInfo -> annotate InfoSC

191+ LSP.DsHint -> annotate HintSC

130− $ stringParagraphs msg

192+ $ stringParagraphs _message

193+ , label_ "Code:" $ pretty _code

131 ]

194 ]

132 where

195 where

133− -- FIXME(JM): Move uri construction to DA.Pretty?

196+ sev = fromMaybe LSP.DsError _severity

134− Position sline _ = rangeStart range

197+

135− Position eline _ = rangeEnd range

198+prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass

136− uri = "command:daml.revealLocation?"

199+prettyDiagnosticStore ds =

137− <> Network.URI.Encode.encodeText ("[\"file://" <> T.pack filePath <> "\","

200+ vcat $

138− <> T.pack (show sline) <> ", " <> T.pack (show eline) <> "]")

201+ map prettyFileDiagnostics $

139− title = T.pack filePath

202+ Map.assocs $

203+ Map.map getDiagnosticsFromStore ds

204+

205+prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass

206+prettyFileDiagnostics (uri, diags) =

207+ label_ "Compiler error in" $ vcat

208+ [ label_ "File:" $ pretty filePath

209+ , label_ "Errors:" $ vcat $ map prettyDiagnostic diags

210+ ] where

211+

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

213+ -- prettyFileDiags (fp,stages) =

214+ -- label_ ("File: "<>fp) $ vcat $ map prettyStage stages

215+

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

217+ -- prettyStage (stage,diags) =

218+ -- label_ ("Stage: "<>T.unpack stage) $ vcat $ map prettyDiagnostic diags

219+

220+ filePath :: FilePath

221+ filePath = fromMaybe dontKnow $ uriToFilePath uri

222+

223+ -- storeContents ::

224+ -- (FilePath, [(T.Text, [LSP.Diagnostic])])

225+ -- -- ^ Source File, Stage Source, Diags

226+ -- storeContents = (fromMaybe dontKnow $ uriToFilePath uri, getDiags diags)

227+

228+ dontKnow :: IsString s => s

229+ dontKnow = "<unknown>"

230+

231+ -- getDiags :: DiagnosticsBySource -> [(T.Text, [LSP.Diagnostic])]

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

233+

234+getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

235+getDiagnosticsFromStore (StoreItem _ diags) =

236+ toList =<< Map.elems diags

src/Development/IDE/Types/Location.hs+14−78

@@ -12,75 +12,25 @@ module Development.IDE.Types.Location

12 , Location(..)

13 , appendLocation

14 , noLocation

15+ , noFilePath

15 , noRange

16 , noRange

16 , Position(..)

17 , Position(..)

17 , Range(..)

18 , Range(..)

18 , appendRange

19 , appendRange

19 ) where

20 ) where

21−import Control.DeepSeq (NFData (..))

22+import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..), Uri(..), filePathToUri)

22−import Data.Aeson.Types (FromJSON, FromJSONKey, ToJSON, ToJSONKey)

23−import Data.Binary (Binary)

24−import Data.Data

25−import Data.Text.Prettyprint.Doc.Syntax

26−import GHC.Generics

27−

28−------------------------------------------------------------------------------

29−--- Types

30−------------------------------------------------------------------------------

31−

32−-- | Position in a text document expressed as zero-based line and

33−-- character offset.

34−data Position = Position

35− { positionLine :: {-# UNPACK #-} !Int

36− -- ^ Zero-based line position in the document.

37− , positionCharacter :: {-# UNPACK #-} !Int

38− -- ^ Zero-based character offset on the line.

39− } deriving (Eq, Ord, Read, Show, Generic, Data)

40−

41−instance NFData Position

42−

43−instance Pretty Position where

44− pretty pos =

45− pretty (positionLine pos + 1) <> colon <> pretty (positionCharacter pos + 1)

46−

47−

48−-- | A range in a text document expressed as inclusive start-position and an

49−-- exclusive end-position.

50−data Range = Range

51− { rangeStart :: {-# UNPACK #-} !Position

52− -- ^ The start position of the range, which is considered to be part of

53− -- the range.

54− , rangeEnd :: {-# UNPACK #-} !Position

55− -- ^ The end position of the range, which is not considered to be part

56− -- of the range.

57− } deriving (Eq, Ord, Read, Show, Generic, Data)

58−

59−instance NFData Range

60−

61−instance Pretty Range where

62− pretty range =

63− pretty (rangeStart range) <> "-" <> pretty (rangeEnd range)

64−

65−

66−-- | Represents a location inside a resource, such as a line inside a text file.

67−data Location = Location

68− { lFilePath :: !FilePath

69− -- ^ The uri of the document.

70− , lRange :: !Range

71− -- ^ The range within the document.

72− } deriving (Eq, Ord, Read, Show, Generic, Data)

73−

74−instance NFData Location

75−

77-- | A dummy location to use when location information is missing.

24-- | A dummy location to use when location information is missing.

78noLocation :: Location

25noLocation :: Location

79noLocation = Location

26noLocation = Location

80− { lFilePath = "<unknown>"

27+ { _uri = filePathToUri noFilePath

81− , lRange = noRange

28+ , _range = noRange

82 }

29 }

31+noFilePath :: FilePath

32+noFilePath = "<unknown>"

33+

84-- A dummy range to use when range is unknown

34-- A dummy range to use when range is unknown

85noRange :: Range

35noRange :: Range

86noRange = Range (Position 0 0) (Position 100000 0)

36noRange = Range (Position 0 0) (Position 100000 0)

@@ -90,14 +40,14 @@ noRange = Range (Position 0 0) (Position 100000 0)

90-- the code was generated.

40-- the code was generated.

91genLocation :: Location

41genLocation :: Location

92genLocation = Location

42genLocation = Location

93− { lFilePath = "<generated>"

43+ { _uri = Uri "<generated>"

94− , lRange = Range (Position 0 0) (Position 0 0)

44+ , _range = Range (Position 0 0) (Position 0 0)

95 }

45 }

98-- | Is a location generated.

48-- | Is a location generated.

99isGenLocation :: Location -> Bool

49isGenLocation :: Location -> Bool

100−isGenLocation x = lFilePath x == "<generated>"

50+isGenLocation x = _uri x == Uri "<generated>"

101

102

103-- | Check if a position is inside a range.

53-- | Check if a position is inside a range.

@@ -116,27 +66,13 @@ inRangeClosed pos (Range start end) = start <= pos && pos <= end

116-- and the maximum position is the max of both.

66-- and the maximum position is the max of both.

117appendRange :: Range -> Range -> Range

67appendRange :: Range -> Range -> Range

118appendRange r1 r2

68appendRange r1 r2

119− = Range { rangeStart = min (rangeStart r1) (rangeStart r2)

69+ = Range { _start = min (_start r1) (_start r2)

120− , rangeEnd = max (rangeEnd r1) (rangeEnd r2) }

70+ , _end = max (_end r1) (_end r2) }

121

122

123-- | Produce a new location where the ranges are the appended and we choose

73-- | Produce a new location where the ranges are the appended and we choose

124-- the file path of the second.

74-- the file path of the second.

125appendLocation :: Location -> Location -> Location

75appendLocation :: Location -> Location -> Location

126appendLocation l1 l2

76appendLocation l1 l2

127− = Location { lFilePath = lFilePath l2

77+ = Location { _uri = _uri l2

128− , lRange = appendRange (lRange l1) (lRange l2) }

78+ , _range = appendRange (_range l1) (_range l2) }

129−

130−instance ToJSON Position

131−instance FromJSON Position

132−instance ToJSONKey Position

133−instance FromJSONKey Position

134−instance Binary Position

135−

136−instance ToJSON Range

137−instance FromJSON Range

138−instance Binary Range

139−

140−instance ToJSON Location

141−instance FromJSON Location

142−instance Binary Location