mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-17 23:22:04 +03:00
New diagnostics implementation (#737)
* Switch to haskell-lsp * Fix build of data-default on Windows * Use ghc environment files to avoid overflowing CLI length limits
This commit is contained in:
DavidM-D
Moritz Kiefer
parent
3f6eabadf3
commit
c72b7344e2
@ -20,6 +20,9 @@ da_haskell_library(
|
||||
"ghc-lib",
|
||||
"ghc-lib-parser",
|
||||
"hashable",
|
||||
"haskell-lsp",
|
||||
"haskell-lsp-types",
|
||||
"lens",
|
||||
"mtl",
|
||||
"pretty",
|
||||
"safe-exceptions",
|
||||
|
||||
@ -80,8 +80,8 @@ locationsAtPoint pos = map srcSpanToLocation
|
||||
|
||||
spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
|
||||
spansAtPoint pos = filter atp where
|
||||
line = positionLine pos + 1
|
||||
cha = positionCharacter pos + 1
|
||||
line = _line pos + 1
|
||||
cha = _character pos + 1
|
||||
atp SpanInfo{..} = spaninfoStartLine <= line
|
||||
&& spaninfoEndLine >= line
|
||||
&& spaninfoStartCol <= cha
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
module Development.IDE.Functions.GHCError
|
||||
( mkDiag
|
||||
, toDiagnostics
|
||||
@ -26,6 +26,7 @@ module Development.IDE.Functions.GHCError
|
||||
, noSpan
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Development.IDE.Types.Diagnostics as D
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.UtilGHC()
|
||||
@ -36,6 +37,7 @@ import Data.Maybe
|
||||
import "ghc-lib-parser" ErrUtils
|
||||
import "ghc-lib-parser" SrcLoc
|
||||
import qualified "ghc-lib-parser" Outputable as Out
|
||||
import qualified Language.Haskell.LSP.Types as LSP
|
||||
|
||||
|
||||
|
||||
@ -48,18 +50,19 @@ mkDiag dflags src e =
|
||||
case toDSeverity $ errMsgSeverity e of
|
||||
Nothing -> Nothing
|
||||
Just bSeverity ->
|
||||
Just
|
||||
Just $ set dLocation (Just $ srcSpanToLocation $ errMsgSpan e)
|
||||
Diagnostic
|
||||
{ dFilePath = srcSpanToFilename $ errMsgSpan e
|
||||
, dRange = srcSpanToRange $ errMsgSpan e
|
||||
, dSeverity = bSeverity
|
||||
, dSource = src
|
||||
, dMessage = T.pack $ Out.showSDoc dflags (ErrUtils.pprLocErrMsg e)
|
||||
{ _range = srcSpanToRange $ errMsgSpan e
|
||||
, _severity = Just bSeverity
|
||||
, _source = Just src
|
||||
, _message = T.pack $ Out.showSDoc dflags (ErrUtils.pprLocErrMsg e)
|
||||
, _code = Nothing
|
||||
, _relatedInformation = Nothing
|
||||
}
|
||||
|
||||
-- | Convert a GHC SrcSpan to a DAML compiler Range
|
||||
srcSpanToRange :: SrcSpan -> Range
|
||||
srcSpanToRange (UnhelpfulSpan _) = lRange noLocation
|
||||
srcSpanToRange (UnhelpfulSpan _) = noRange
|
||||
srcSpanToRange (RealSrcSpan real) = realSrcSpanToRange real
|
||||
|
||||
realSrcSpanToRange :: RealSrcSpan -> Range
|
||||
@ -74,18 +77,19 @@ srcSpanToFilename (UnhelpfulSpan fs) = FS.unpackFS fs
|
||||
srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
|
||||
|
||||
srcSpanToLocation :: SrcSpan -> Location
|
||||
srcSpanToLocation src = Location (srcSpanToFilename src) (srcSpanToRange src)
|
||||
srcSpanToLocation src =
|
||||
Location (LSP.filePathToUri $ srcSpanToFilename src) (srcSpanToRange src)
|
||||
|
||||
-- | Convert a GHC severity to a DAML compiler Severity. Severities below
|
||||
-- "Warning" level are dropped (returning Nothing).
|
||||
toDSeverity :: GHC.Severity -> Maybe D.Severity
|
||||
toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity
|
||||
toDSeverity SevOutput = Nothing
|
||||
toDSeverity SevInteractive = Nothing
|
||||
toDSeverity SevDump = Nothing
|
||||
toDSeverity SevInfo = Nothing
|
||||
toDSeverity SevWarning = Just D.Warning
|
||||
toDSeverity SevError = Just Error
|
||||
toDSeverity SevFatal = Just Error
|
||||
toDSeverity SevInfo = Just DsInfo
|
||||
toDSeverity SevWarning = Just DsWarning
|
||||
toDSeverity SevError = Just DsError
|
||||
toDSeverity SevFatal = Just DsError
|
||||
|
||||
|
||||
-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
-- | A Shake implementation of the compiler service, built
|
||||
-- using the "Shaker" abstraction layer for in-memory use.
|
||||
@ -24,6 +25,7 @@ module Development.IDE.State.Rules(
|
||||
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Exception (evaluate)
|
||||
import Control.Lens (set)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Extra (whenJust)
|
||||
import qualified Development.IDE.Functions.Compile as Compile
|
||||
@ -239,12 +241,13 @@ reportImportCyclesRule =
|
||||
where cycleErrorInFile f (PartOfCycle imp fs)
|
||||
| f `elem` fs = Just (imp, fs)
|
||||
cycleErrorInFile _ _ = Nothing
|
||||
toDiag imp mods = Diagnostic
|
||||
{ dFilePath = lFilePath loc
|
||||
, dRange = lRange loc
|
||||
, dSeverity = Error
|
||||
, dSource = "Import cycle detection"
|
||||
, dMessage = "Cyclic module dependency between " <> showCycle mods
|
||||
toDiag imp mods = set dLocation (Just loc) $ Diagnostic
|
||||
{ _range = (_range :: Location -> Range) loc
|
||||
, _severity = Just DsError
|
||||
, _source = Just "Import cycle detection"
|
||||
, _message = "Cyclic module dependency between " <> showCycle mods
|
||||
, _code = Nothing
|
||||
, _relatedInformation = Nothing
|
||||
}
|
||||
where loc = srcSpanToLocation (getLoc imp)
|
||||
getModuleName file = do
|
||||
|
||||
@ -4,6 +4,8 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | A Shake implementation of the compiler service.
|
||||
--
|
||||
@ -59,9 +61,11 @@ import Development.IDE.Types.Diagnostics
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Exception
|
||||
import Control.DeepSeq
|
||||
import Control.Lens (view, set)
|
||||
import System.Time.Extra
|
||||
import Data.Typeable
|
||||
import Data.Tuple.Extra
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import qualified Development.Shake as Shake
|
||||
import Control.Monad.Extra
|
||||
@ -358,11 +362,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m
|
||||
(bs, res) <- actionCatch
|
||||
(do v <- op key file; liftIO $ evaluate $ force v) $
|
||||
\(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
|
||||
res <- return $ first (map $ fixDiagnostic file) res
|
||||
|
||||
let badErrors = filter (\d -> null file || dRange d == noRange) $ fst res
|
||||
when (badErrors /= []) $
|
||||
reportSeriousError $ "Bad errors found for " ++ show (key, file) ++ " got " ++ show badErrors
|
||||
res <- return $ first (map $ set dFilePath $ Just file) res
|
||||
|
||||
(before, after) <- liftIO $ setValues state key file res
|
||||
updateFileDiagnostics file before after
|
||||
@ -378,24 +378,27 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m
|
||||
unwrap x = if BS.null x then Nothing else Just $ BS.tail x
|
||||
|
||||
|
||||
-- | If any diagnostic has the wrong filename, generate a new diagnostic with the right file name
|
||||
fixDiagnostic :: FilePath -> Diagnostic -> Diagnostic
|
||||
fixDiagnostic x d
|
||||
| dFilePath d == x = d
|
||||
| otherwise = d{dFilePath = x, dRange = noRange, dMessage = T.pack ("Originally reported at " ++ dFilePath d ++ "\n") <> dMessage d}
|
||||
|
||||
|
||||
updateFileDiagnostics ::
|
||||
FilePath
|
||||
-> Maybe [Diagnostic] -- ^ previous results for this file
|
||||
-> [Diagnostic] -- ^ current results
|
||||
-> Action ()
|
||||
updateFileDiagnostics afp previousAll currentAll = do
|
||||
let filt = Set.fromList . filter (\x -> dFilePath x == afp)
|
||||
previous = fmap filt previousAll
|
||||
current = filt currentAll
|
||||
-- TODO (MK) We canonicalize to make sure that the two files agree on use of
|
||||
-- / and \ and other shenanigans.
|
||||
-- Once we have finished the migration to haskell-lsp we should make sure that
|
||||
-- this is no longer necessary.
|
||||
afp' <- liftIO $ canonicalizePath afp
|
||||
let filtM diags = do
|
||||
diags' <-
|
||||
filterM
|
||||
(\x -> fmap (== Just afp') (traverse canonicalizePath $ view dFilePath x))
|
||||
diags
|
||||
pure (Set.fromList diags')
|
||||
previous <- liftIO $ traverse filtM previousAll
|
||||
current <- liftIO $ filtM currentAll
|
||||
when (Just current /= previous) $
|
||||
sendEvent $ EventFileDiagnostics $ FileDiagnostics afp $ Set.toList current
|
||||
sendEvent $ EventFileDiagnostics $ (filePathToUri afp, Set.toList current)
|
||||
|
||||
|
||||
setPriority :: (Enum a) => a -> Action ()
|
||||
|
||||
@ -3,137 +3,234 @@
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
module Development.IDE.Types.Diagnostics (
|
||||
Diagnostic(..),
|
||||
FileDiagnostics(..),
|
||||
LSP.Diagnostic(..),
|
||||
FileDiagnostics,
|
||||
Location(..),
|
||||
Range(..),
|
||||
Severity(..),
|
||||
LSP.DiagnosticSeverity(..),
|
||||
Position(..),
|
||||
DiagnosticStore,
|
||||
DiagnosticRelatedInformation(..),
|
||||
List(..),
|
||||
StoreItem(..),
|
||||
Uri(..),
|
||||
noLocation,
|
||||
noRange,
|
||||
noFilePath,
|
||||
ideErrorText,
|
||||
ideErrorPretty,
|
||||
errorDiag,
|
||||
ideTryIOException,
|
||||
prettyFileDiagnostics,
|
||||
prettyDiagnostic
|
||||
prettyDiagnostic,
|
||||
prettyDiagnosticStore,
|
||||
defDiagnostic,
|
||||
addDiagnostics,
|
||||
filterSeriousErrors,
|
||||
dLocation,
|
||||
dFilePath,
|
||||
filePathToUri,
|
||||
getDiagnosticsFromStore
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Control.Lens (Lens', lens, set, view)
|
||||
import Data.Either.Combinators
|
||||
import Data.List.Extra
|
||||
import Data.Maybe as Maybe
|
||||
import Data.Foldable
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Prettyprint.Doc.Syntax
|
||||
import GHC.Generics
|
||||
import qualified Network.URI.Encode
|
||||
import Data.String (IsString(..))
|
||||
import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty
|
||||
import Language.Haskell.LSP.Types as LSP (
|
||||
DiagnosticSeverity(..)
|
||||
, Diagnostic(..)
|
||||
, filePathToUri
|
||||
, uriToFilePath
|
||||
, List(..)
|
||||
, DiagnosticRelatedInformation(..)
|
||||
, Uri(..)
|
||||
)
|
||||
import Language.Haskell.LSP.Diagnostics
|
||||
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
ideErrorText :: FilePath -> T.Text -> Diagnostic
|
||||
ideErrorText absFile = errorDiag absFile "Ide Error"
|
||||
ideErrorText :: FilePath -> T.Text -> LSP.Diagnostic
|
||||
ideErrorText fp = errorDiag fp "Ide Error"
|
||||
|
||||
ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> Diagnostic
|
||||
ideErrorPretty absFile = ideErrorText absFile . T.pack . Pretty.prettyShow
|
||||
ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> LSP.Diagnostic
|
||||
ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow
|
||||
|
||||
errorDiag :: FilePath -> T.Text -> T.Text -> Diagnostic
|
||||
errorDiag fp src msg =
|
||||
Diagnostic
|
||||
{ dFilePath = fp
|
||||
, dRange = noRange
|
||||
, dSeverity = Error
|
||||
, dSource = src
|
||||
, dMessage = msg
|
||||
errorDiag :: FilePath -> T.Text -> T.Text -> LSP.Diagnostic
|
||||
errorDiag fp src =
|
||||
set dFilePath (Just fp) . diagnostic noRange LSP.DsError src
|
||||
|
||||
-- | This is for compatibility with our old diagnostic type
|
||||
diagnostic :: Range
|
||||
-> LSP.DiagnosticSeverity
|
||||
-> T.Text -- ^ source
|
||||
-> T.Text -- ^ message
|
||||
-> LSP.Diagnostic
|
||||
diagnostic rng sev src msg
|
||||
= LSP.Diagnostic {
|
||||
_range = rng,
|
||||
_severity = Just sev,
|
||||
_code = Nothing,
|
||||
_source = Just src,
|
||||
_message = msg,
|
||||
_relatedInformation = Nothing
|
||||
}
|
||||
|
||||
-- | Any optional field is instantiated to Nothing
|
||||
defDiagnostic ::
|
||||
Range ->
|
||||
T.Text -> -- ^ error message
|
||||
LSP.Diagnostic
|
||||
defDiagnostic _range _message = LSP.Diagnostic {
|
||||
_range
|
||||
, _message
|
||||
, _severity = Nothing
|
||||
, _code = Nothing
|
||||
, _source = Nothing
|
||||
, _relatedInformation = Nothing
|
||||
}
|
||||
|
||||
ideTryIOException :: FilePath -> IO a -> IO (Either Diagnostic a)
|
||||
-- | setLocation but with no range information
|
||||
dFilePath ::
|
||||
Lens' LSP.Diagnostic (Maybe FilePath)
|
||||
dFilePath = lens g s where
|
||||
g :: LSP.Diagnostic -> Maybe FilePath
|
||||
g d = (uriToFilePath . _uri) =<< view dLocation d
|
||||
s :: LSP.Diagnostic -> Maybe FilePath -> LSP.Diagnostic
|
||||
s d@Diagnostic{..} fp = set dLocation
|
||||
(Location <$> (filePathToUri <$> fp) <*> pure _range) d
|
||||
|
||||
-- | This adds location information to the diagnostics but this is only used in
|
||||
-- the case of serious errors to give some context to what went wrong
|
||||
dLocation ::
|
||||
Lens' LSP.Diagnostic (Maybe Location)
|
||||
dLocation = lens g s where
|
||||
s :: LSP.Diagnostic -> Maybe Location -> LSP.Diagnostic
|
||||
s d = \case
|
||||
Just loc ->
|
||||
d {LSP._range=(_range :: Location -> Range) loc
|
||||
, LSP._relatedInformation = Just $ LSP.List [DiagnosticRelatedInformation loc "dLocation: Unknown error"]}
|
||||
Nothing -> d {LSP._range = noRange, LSP._relatedInformation = Nothing}
|
||||
g :: LSP.Diagnostic -> Maybe Location
|
||||
g Diagnostic{..} = case _relatedInformation of
|
||||
Just (List [DiagnosticRelatedInformation loc _]) -> Just loc
|
||||
Just (List xs) -> error $ "Diagnostic created, expected 1 related information but got" <> show xs
|
||||
Nothing -> Nothing
|
||||
|
||||
filterSeriousErrors ::
|
||||
FilePath ->
|
||||
[LSP.Diagnostic] ->
|
||||
[LSP.Diagnostic]
|
||||
filterSeriousErrors fp =
|
||||
filter (maybe False hasSeriousErrors . LSP._relatedInformation)
|
||||
where
|
||||
hasSeriousErrors :: List DiagnosticRelatedInformation -> Bool
|
||||
hasSeriousErrors (List a) = any ((/=) uri . _uri . _location) a
|
||||
uri = LSP.filePathToUri fp
|
||||
|
||||
addDiagnostics ::
|
||||
FilePath ->
|
||||
[LSP.Diagnostic] ->
|
||||
DiagnosticStore -> DiagnosticStore
|
||||
addDiagnostics fp diags ds =
|
||||
updateDiagnostics
|
||||
ds
|
||||
(LSP.filePathToUri fp)
|
||||
Nothing $
|
||||
partitionBySource diags
|
||||
|
||||
ideTryIOException :: FilePath -> IO a -> IO (Either LSP.Diagnostic a)
|
||||
ideTryIOException fp act =
|
||||
mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act
|
||||
|
||||
data Diagnostic = Diagnostic
|
||||
{ dFilePath :: !FilePath
|
||||
-- ^ Specific file that the diagnostic refers to.
|
||||
, dRange :: !Range
|
||||
-- ^ The range to which the diagnostic applies.
|
||||
, dSeverity :: !Severity
|
||||
-- ^ The severity of the diagnostic, such as 'SError' or 'SWarning'.
|
||||
, dSource :: !T.Text
|
||||
-- ^ Human-readable description for the source of the diagnostic,
|
||||
-- for example 'parser'.
|
||||
, dMessage :: !T.Text
|
||||
-- ^ The diagnostic's message.
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
instance NFData Diagnostic
|
||||
|
||||
-- | The diagnostic severity.
|
||||
data Severity
|
||||
= Error | Warning
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
instance NFData Severity
|
||||
|
||||
-- | Human readable diagnostics for a specific file.
|
||||
--
|
||||
-- This type packages a pretty printed, human readable error message
|
||||
-- along with the related source location so that we can display the error
|
||||
-- on either the console or in the IDE at the right source location.
|
||||
--
|
||||
data FileDiagnostics = FileDiagnostics
|
||||
{ fdFilePath :: !FilePath
|
||||
-- ^ Path of the module that we were trying to process.
|
||||
-- In a multi-module program this is the file that we started
|
||||
-- trying to compile, not necessarily the one in which we found the
|
||||
-- reported errors or warnings.
|
||||
, fdDiagnostics :: ![Diagnostic]
|
||||
-- ^ Diagnostics for the desired module,
|
||||
-- as well as any transitively imported modules.
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
type FileDiagnostics = (Uri, [Diagnostic])
|
||||
|
||||
instance FromJSON Diagnostic
|
||||
instance ToJSON Diagnostic
|
||||
prettyRange :: Range -> Doc SyntaxClass
|
||||
prettyRange Range{..} =
|
||||
label_ "Range" $ vcat
|
||||
[ label_ "Start:" $ prettyPosition _start
|
||||
, label_ "End: " $ prettyPosition _end
|
||||
]
|
||||
|
||||
instance FromJSON Severity
|
||||
instance ToJSON Severity
|
||||
|
||||
instance FromJSON FileDiagnostics
|
||||
instance ToJSON FileDiagnostics
|
||||
|
||||
prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass
|
||||
prettyFileDiagnostics (FileDiagnostics filePath diagnostics) =
|
||||
label_ "Compiler error in" $ vcat
|
||||
[ label_ "File:" $ pretty filePath
|
||||
, label_ "Errors:" $ vcat $ map prettyDiagnostic $ nubOrd diagnostics
|
||||
]
|
||||
prettyPosition :: Position -> Doc SyntaxClass
|
||||
prettyPosition Position{..} = label_ "Position" $ vcat
|
||||
[ label_ "Line:" $ pretty _line
|
||||
, label_ "Character:" $ pretty _character
|
||||
]
|
||||
|
||||
stringParagraphs :: T.Text -> Doc a
|
||||
stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines
|
||||
|
||||
prettyDiagnostic :: Diagnostic -> Doc SyntaxClass
|
||||
prettyDiagnostic (Diagnostic filePath range severity source msg) =
|
||||
prettyDiagnostic :: LSP.Diagnostic -> Doc SyntaxClass
|
||||
prettyDiagnostic LSP.Diagnostic{..} =
|
||||
vcat
|
||||
[ label_ "File: " $ pretty filePath
|
||||
, label_ "Range: "
|
||||
$ annotate (LinkSC uri title)
|
||||
$ pretty range
|
||||
, label_ "Source: " $ pretty source
|
||||
, label_ "Severity:" $ pretty $ show severity
|
||||
[label_ "Range: "
|
||||
$ prettyRange _range
|
||||
, label_ "Source: " $ pretty _source
|
||||
, label_ "Severity:" $ pretty $ show sev
|
||||
, label_ "Message: "
|
||||
$ case severity of
|
||||
Error -> annotate ErrorSC
|
||||
Warning -> annotate WarningSC
|
||||
$ stringParagraphs msg
|
||||
$ case sev of
|
||||
LSP.DsError -> annotate ErrorSC
|
||||
LSP.DsWarning -> annotate WarningSC
|
||||
LSP.DsInfo -> annotate InfoSC
|
||||
LSP.DsHint -> annotate HintSC
|
||||
$ stringParagraphs _message
|
||||
, label_ "Code:" $ pretty _code
|
||||
]
|
||||
where
|
||||
-- FIXME(JM): Move uri construction to DA.Pretty?
|
||||
Position sline _ = rangeStart range
|
||||
Position eline _ = rangeEnd range
|
||||
uri = "command:daml.revealLocation?"
|
||||
<> Network.URI.Encode.encodeText ("[\"file://" <> T.pack filePath <> "\","
|
||||
<> T.pack (show sline) <> ", " <> T.pack (show eline) <> "]")
|
||||
title = T.pack filePath
|
||||
sev = fromMaybe LSP.DsError _severity
|
||||
|
||||
prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass
|
||||
prettyDiagnosticStore ds =
|
||||
vcat $
|
||||
map prettyFileDiagnostics $
|
||||
Map.assocs $
|
||||
Map.map getDiagnosticsFromStore ds
|
||||
|
||||
prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass
|
||||
prettyFileDiagnostics (uri, diags) =
|
||||
label_ "Compiler error in" $ vcat
|
||||
[ label_ "File:" $ pretty filePath
|
||||
, label_ "Errors:" $ vcat $ map prettyDiagnostic diags
|
||||
] where
|
||||
|
||||
-- prettyFileDiags :: (FilePath, [(T.Text, [LSP.Diagnostic])]) -> Doc SyntaxClass
|
||||
-- prettyFileDiags (fp,stages) =
|
||||
-- label_ ("File: "<>fp) $ vcat $ map prettyStage stages
|
||||
|
||||
-- prettyStage :: (T.Text, [LSP.Diagnostic]) -> Doc SyntaxClass
|
||||
-- prettyStage (stage,diags) =
|
||||
-- label_ ("Stage: "<>T.unpack stage) $ vcat $ map prettyDiagnostic diags
|
||||
|
||||
filePath :: FilePath
|
||||
filePath = fromMaybe dontKnow $ uriToFilePath uri
|
||||
|
||||
-- storeContents ::
|
||||
-- (FilePath, [(T.Text, [LSP.Diagnostic])])
|
||||
-- -- ^ Source File, Stage Source, Diags
|
||||
-- storeContents = (fromMaybe dontKnow $ uriToFilePath uri, getDiags diags)
|
||||
|
||||
dontKnow :: IsString s => s
|
||||
dontKnow = "<unknown>"
|
||||
|
||||
-- getDiags :: DiagnosticsBySource -> [(T.Text, [LSP.Diagnostic])]
|
||||
-- getDiags = map (\(ds, diag) -> (fromMaybe dontKnow ds, toList diag)) . Map.assocs
|
||||
|
||||
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
|
||||
getDiagnosticsFromStore (StoreItem _ diags) =
|
||||
toList =<< Map.elems diags
|
||||
|
||||
@ -12,75 +12,25 @@ module Development.IDE.Types.Location
|
||||
, Location(..)
|
||||
, appendLocation
|
||||
, noLocation
|
||||
, noFilePath
|
||||
, noRange
|
||||
, Position(..)
|
||||
, Range(..)
|
||||
, appendRange
|
||||
) where
|
||||
|
||||
import Control.DeepSeq (NFData (..))
|
||||
import Data.Aeson.Types (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
|
||||
import Data.Binary (Binary)
|
||||
import Data.Data
|
||||
import Data.Text.Prettyprint.Doc.Syntax
|
||||
import GHC.Generics
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
--- Types
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- | Position in a text document expressed as zero-based line and
|
||||
-- character offset.
|
||||
data Position = Position
|
||||
{ positionLine :: {-# UNPACK #-} !Int
|
||||
-- ^ Zero-based line position in the document.
|
||||
, positionCharacter :: {-# UNPACK #-} !Int
|
||||
-- ^ Zero-based character offset on the line.
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Data)
|
||||
|
||||
instance NFData Position
|
||||
|
||||
instance Pretty Position where
|
||||
pretty pos =
|
||||
pretty (positionLine pos + 1) <> colon <> pretty (positionCharacter pos + 1)
|
||||
|
||||
|
||||
-- | A range in a text document expressed as inclusive start-position and an
|
||||
-- exclusive end-position.
|
||||
data Range = Range
|
||||
{ rangeStart :: {-# UNPACK #-} !Position
|
||||
-- ^ The start position of the range, which is considered to be part of
|
||||
-- the range.
|
||||
, rangeEnd :: {-# UNPACK #-} !Position
|
||||
-- ^ The end position of the range, which is not considered to be part
|
||||
-- of the range.
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Data)
|
||||
|
||||
instance NFData Range
|
||||
|
||||
instance Pretty Range where
|
||||
pretty range =
|
||||
pretty (rangeStart range) <> "-" <> pretty (rangeEnd range)
|
||||
|
||||
|
||||
-- | Represents a location inside a resource, such as a line inside a text file.
|
||||
data Location = Location
|
||||
{ lFilePath :: !FilePath
|
||||
-- ^ The uri of the document.
|
||||
, lRange :: !Range
|
||||
-- ^ The range within the document.
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Data)
|
||||
|
||||
instance NFData Location
|
||||
|
||||
import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..), Uri(..), filePathToUri)
|
||||
|
||||
-- | A dummy location to use when location information is missing.
|
||||
noLocation :: Location
|
||||
noLocation = Location
|
||||
{ lFilePath = "<unknown>"
|
||||
, lRange = noRange
|
||||
{ _uri = filePathToUri noFilePath
|
||||
, _range = noRange
|
||||
}
|
||||
|
||||
noFilePath :: FilePath
|
||||
noFilePath = "<unknown>"
|
||||
|
||||
-- A dummy range to use when range is unknown
|
||||
noRange :: Range
|
||||
noRange = Range (Position 0 0) (Position 100000 0)
|
||||
@ -90,14 +40,14 @@ noRange = Range (Position 0 0) (Position 100000 0)
|
||||
-- the code was generated.
|
||||
genLocation :: Location
|
||||
genLocation = Location
|
||||
{ lFilePath = "<generated>"
|
||||
, lRange = Range (Position 0 0) (Position 0 0)
|
||||
{ _uri = Uri "<generated>"
|
||||
, _range = Range (Position 0 0) (Position 0 0)
|
||||
}
|
||||
|
||||
|
||||
-- | Is a location generated.
|
||||
isGenLocation :: Location -> Bool
|
||||
isGenLocation x = lFilePath x == "<generated>"
|
||||
isGenLocation x = _uri x == Uri "<generated>"
|
||||
|
||||
|
||||
-- | Check if a position is inside a range.
|
||||
@ -116,27 +66,13 @@ inRangeClosed pos (Range start end) = start <= pos && pos <= end
|
||||
-- and the maximum position is the max of both.
|
||||
appendRange :: Range -> Range -> Range
|
||||
appendRange r1 r2
|
||||
= Range { rangeStart = min (rangeStart r1) (rangeStart r2)
|
||||
, rangeEnd = max (rangeEnd r1) (rangeEnd r2) }
|
||||
= Range { _start = min (_start r1) (_start r2)
|
||||
, _end = max (_end r1) (_end r2) }
|
||||
|
||||
|
||||
-- | Produce a new location where the ranges are the appended and we choose
|
||||
-- the file path of the second.
|
||||
appendLocation :: Location -> Location -> Location
|
||||
appendLocation l1 l2
|
||||
= Location { lFilePath = lFilePath l2
|
||||
, lRange = appendRange (lRange l1) (lRange l2) }
|
||||
|
||||
instance ToJSON Position
|
||||
instance FromJSON Position
|
||||
instance ToJSONKey Position
|
||||
instance FromJSONKey Position
|
||||
instance Binary Position
|
||||
|
||||
instance ToJSON Range
|
||||
instance FromJSON Range
|
||||
instance Binary Range
|
||||
|
||||
instance ToJSON Location
|
||||
instance FromJSON Location
|
||||
instance Binary Location
|
||||
= Location { _uri = _uri l2
|
||||
, _range = appendRange (_range l1) (_range l2) }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user