@@ -3,137 +3,234 @@
33
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE DuplicateRecordFields #-}
7+{-# LANGUAGE BlockArguments #-}
68module Development.IDE.Types.Diagnostics (
7− Diagnostic(..),
8− FileDiagnostics(..),
9+ LSP.Diagnostic(..),
10+ FileDiagnostics,
911 Location(..),
1012 Range(..),
11− Severity(..),
13+ LSP.DiagnosticSeverity(..),
1214 Position(..),
15+ DiagnosticStore,
16+ DiagnosticRelatedInformation(..),
17+ List(..),
18+ StoreItem(..),
19+ Uri(..),
1320 noLocation,
1421 noRange,
22+ noFilePath,
1523 ideErrorText,
1624 ideErrorPretty,
1725 errorDiag,
1826 ideTryIOException,
1927 prettyFileDiagnostics,
20− prettyDiagnostic
28+ prettyDiagnostic,
29+ prettyDiagnosticStore,
30+ defDiagnostic,
31+ addDiagnostics,
32+ filterSeriousErrors,
33+ dLocation,
34+ dFilePath,
35+ filePathToUri,
36+ getDiagnosticsFromStore
2137 ) where
2238
23−import Control.DeepSeq
2439import Control.Exception
25−import Data.Aeson (FromJSON, ToJSON)
40+import Control.Lens (Lens', lens, set, view)
2641import 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
2845import qualified Data.Text as T
2946import Data.Text.Prettyprint.Doc.Syntax
30−import GHC.Generics
31−import qualified Network.URI.Encode
47+import Data.String (IsString(..))
3248import 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
3359
3460import Development.IDE.Types.Location
3561
36−ideErrorText :: FilePath -> T.Text -> Diagnostic
37−ideErrorText absFile = errorDiag absFile "Ide Error"
38−
39−ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> Diagnostic
40−ideErrorPretty absFile = ideErrorText absFile . T.pack . Pretty.prettyShow
41−
42−errorDiag :: FilePath -> T.Text -> T.Text -> Diagnostic
43−errorDiag fp src msg =
44− Diagnostic
45− { dFilePath = fp
46− , dRange = noRange
47− , dSeverity = Error
48− , dSource = src
49− , dMessage = msg
62+ideErrorText :: FilePath -> T.Text -> LSP.Diagnostic
63+ideErrorText fp = errorDiag fp "Ide Error"
64+
65+ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> LSP.Diagnostic
66+ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow
67+
68+errorDiag :: FilePath -> T.Text -> T.Text -> LSP.Diagnostic
69+errorDiag fp src =
70+ set dFilePath (Just fp) . diagnostic noRange LSP.DsError src
71+
72+-- | This is for compatibility with our old diagnostic type
73+diagnostic :: Range
74+ -> LSP.DiagnosticSeverity
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
50100 }
51101
52−ideTryIOException :: FilePath -> IO a -> IO (Either Diagnostic a)
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+
151+ideTryIOException :: FilePath -> IO a -> IO (Either LSP.Diagnostic a)
53152ideTryIOException fp act =
54153 mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act
55154
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−
80155-- | Human readable diagnostics for a specific file.
81156--
82157-- This type packages a pretty printed, human readable error message
83158-- along with the related source location so that we can display the error
84159-- on either the console or in the IDE at the right source location.
85160--
86−data FileDiagnostics = FileDiagnostics
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
161+type FileDiagnostics = (Uri, [Diagnostic])
106162
107−prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass
108−prettyFileDiagnostics (FileDiagnostics filePath diagnostics) =
109− label_ "Compiler error in" $ vcat
110− [ label_ "File:" $ pretty filePath
111− , label_ "Errors:" $ vcat $ map prettyDiagnostic $ nubOrd diagnostics
112− ]
163+prettyRange :: Range -> Doc SyntaxClass
164+prettyRange Range{..} =
165+ label_ "Range" $ vcat
166+ [ label_ "Start:" $ prettyPosition _start
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
174+ ]
113175
114176stringParagraphs :: T.Text -> Doc a
115177stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines
116178
117−prettyDiagnostic :: Diagnostic -> Doc SyntaxClass
118−prettyDiagnostic (Diagnostic filePath range severity source msg) =
179+prettyDiagnostic :: LSP.Diagnostic -> Doc SyntaxClass
180+prettyDiagnostic LSP.Diagnostic{..} =
119181 vcat
120− [ label_ "File: " $ pretty filePath
121− , label_ "Range: "
122− $ annotate (LinkSC uri title)
123− $ pretty range
124− , label_ "Source: " $ pretty source
125− , label_ "Severity:" $ pretty $ show severity
182+ [label_ "Range: "
183+ $ prettyRange _range
184+ , label_ "Source: " $ pretty _source
185+ , label_ "Severity:" $ pretty $ show sev
126186 , label_ "Message: "
127− $ case severity of
128− Error -> annotate ErrorSC
129− Warning -> annotate WarningSC
130− $ stringParagraphs msg
187+ $ case sev of
188+ LSP.DsError -> annotate ErrorSC
189+ LSP.DsWarning -> annotate WarningSC
190+ LSP.DsInfo -> annotate InfoSC
191+ LSP.DsHint -> annotate HintSC
192+ $ stringParagraphs _message
193+ , label_ "Code:" $ pretty _code
131194 ]
132195 where
133− -- FIXME(JM): Move uri construction to DA.Pretty?
134− Position sline _ = rangeStart range
135− Position eline _ = rangeEnd range
136− uri = "command:daml.revealLocation?"
137− <> Network.URI.Encode.encodeText ("[\"file://" <> T.pack filePath <> "\","
138− <> T.pack (show sline) <> ", " <> T.pack (show eline) <> "]")
139− title = T.pack filePath
196+ sev = fromMaybe LSP.DsError _severity
197+
198+prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass
199+prettyDiagnosticStore ds =
200+ vcat $
201+ map prettyFileDiagnostics $
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