Skip to content

Commit 594bba1

Browse files
committed
preliminary, very basic working diagnostics
1 parent fc7ac76 commit 594bba1

File tree

6 files changed

+264
-125
lines changed

6 files changed

+264
-125
lines changed

haskell-language-server.cabal

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -339,6 +339,8 @@ library hls-cabal-project-plugin
339339
Ide.Plugin.CabalProject
340340
Ide.Plugin.CabalProject.Parse
341341
Ide.Plugin.CabalProject.Diagnostics
342+
Ide.Plugin.CabalProject.Types
343+
Ide.Plugin.CabalProject.Orphans
342344

343345
build-depends:
344346
, bytestring
@@ -365,7 +367,8 @@ library hls-cabal-project-plugin
365367
, aeson
366368
, Cabal
367369
, pretty
368-
, cabal-install
370+
, cabal-install
371+
, cabal-install-solver
369372

370373
hs-source-dirs: plugins/hls-cabal-project-plugin/src
371374

plugins/hls-cabal-project-plugin/src/Ide/Plugin/CabalProject.hs

Lines changed: 70 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE DuplicateRecordFields #-}
34
{-# LANGUAGE LambdaCase #-}
@@ -45,7 +46,10 @@ import Distribution.PackageDescription.Configuration (flattenPackageDe
4546
import Distribution.Parsec.Error
4647
import qualified Distribution.Parsec.Position as Syntax
4748
import GHC.Generics
48-
import Ide.Plugin.CabalProject.Parse (parseCabalProjectFileContents)
49+
import Ide.Plugin.CabalProject.Diagnostics as Diagnostics
50+
import Ide.Plugin.CabalProject.Orphans ()
51+
import Ide.Plugin.CabalProject.Parse as Parse
52+
import Ide.Plugin.CabalProject.Types as Types
4953
import Ide.Plugin.Error
5054
import Ide.Types
5155
import qualified Language.LSP.Protocol.Lens as JL
@@ -130,7 +134,7 @@ descriptor recorder plId =
130134

131135
parseAndPrint :: FilePath -> IO ()
132136
parseAndPrint file = do
133-
(warnings, res) <- parseCabalProjectFileContents file
137+
(warnings, res) <- Parse.parseCabalProjectFileContents file
134138

135139
mapM_ (putStrLn . ("[Cabal warning] " ++) . show) warnings
136140

@@ -143,6 +147,11 @@ descriptor recorder plId =
143147
putStrLn $
144148
"Cabal project parsed successfully:\n" ++ show project
145149

150+
bs <- BS.readFile file
151+
case Parse.readCabalProjectFields (toNormalizedFilePath' file) bs of
152+
Left diag -> putStrLn $ "readCabalProjectFields error:\n" ++ show diag
153+
Right flds -> putStrLn $ "readCabalProjectFields success:\n" ++ show flds
154+
146155
{- | Helper function to restart the shake session, specifically for modifying .cabal files.
147156
No special logic, just group up a bunch of functions you need for the base
148157
Notification Handlers.
@@ -160,30 +169,64 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d
160169

161170

162171
cabalRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
163-
cabalRules recorder _ = do
164-
-- Make sure we initialise the cabal files-of-interest.
165-
ofInterestRules recorder
166-
-- Rule to produce diagnostics for cabal files.
167-
define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFields file -> do
168-
config <- getPluginConfigAction plId
169-
if not (plcGlobalOn config && plcDiagnosticsOn config)
170-
then pure ([], Nothing)
171-
else do
172-
-- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
173-
-- we rerun this rule because this rule *depends* on GetModificationTime.
174-
(t, mCabalSource) <- use_ GetFileContents file
175-
log' Debug $ LogModificationTime file t
176-
contents <- case mCabalSource of
177-
Just sources ->
178-
pure $ Encoding.encodeUtf8 $ Rope.toText sources
179-
Nothing -> do
180-
liftIO $ BS.readFile $ fromNormalizedFilePath file
181-
182-
case Parse.readCabalProjectFields file contents of
183-
Left _ ->
184-
pure ([], Nothing)
185-
Right fields ->
186-
pure ([], Just fields)
172+
cabalRules recorder plId = do
173+
-- Make sure we initialise the cabal files-of-interest.
174+
ofInterestRules recorder
175+
-- Rule to produce diagnostics for cabal files.
176+
define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFields file -> do
177+
config <- getPluginConfigAction plId
178+
if not (plcGlobalOn config && plcDiagnosticsOn config)
179+
then pure ([], Nothing)
180+
else do
181+
-- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
182+
-- we rerun this rule because this rule *depends* on GetModificationTime.
183+
(t, mCabalSource) <- use_ GetFileContents file
184+
log' Debug $ LogModificationTime file t
185+
contents <- case mCabalSource of
186+
Just sources ->
187+
pure $ Encoding.encodeUtf8 $ Rope.toText sources
188+
Nothing -> do
189+
liftIO $ BS.readFile $ fromNormalizedFilePath file
190+
191+
case Parse.readCabalProjectFields file contents of
192+
Left _ ->
193+
pure ([], Nothing)
194+
Right fields ->
195+
pure ([], Just fields)
196+
197+
define (cmapWithPrio LogShake recorder) $ \ParseCabalProjectFile file -> do
198+
cfg <- getPluginConfigAction plId
199+
if not (plcGlobalOn cfg && plcDiagnosticsOn cfg)
200+
then pure ([], Nothing)
201+
else do
202+
-- 1. Grab file contents (virtual-file or disk)
203+
(_hash, mRope) <- use_ GetFileContents file
204+
bytes <- case mRope of
205+
Just rope -> pure (Encoding.encodeUtf8 (Rope.toText rope))
206+
Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath file)
207+
208+
-- 2. Run Cabal’s parser for cabal.project
209+
(pWarnings, pResult) <- liftIO $ Parse.parseCabalProjectFileContents (fromNormalizedFilePath file)
210+
211+
-- 3. Convert warnings
212+
let warnDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings
213+
214+
-- 4. Convert result or errors
215+
case pResult of
216+
Left (_specVer, pErrNE) -> do
217+
let errDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrNE
218+
pure (errDiags ++ warnDiags, Nothing)
219+
220+
Right projCfg -> do
221+
pure (warnDiags, Just projCfg)
222+
223+
action $ do
224+
-- Run the cabal kick. This code always runs when 'shakeRestart' is run.
225+
-- Must be careful to not impede the performance too much. Crucial to
226+
-- a snappy IDE experience.
227+
kick
228+
where
229+
log' = logWith recorder
187230

188231
{- | This is the kick function for the cabal plugin.
189232
We run this action, whenever we shake session us run/restarted, which triggers
@@ -195,6 +238,7 @@ function invocation.
195238
kick :: Action ()
196239
kick = do
197240
files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
241+
-- let keys = map Types.ParseCabalProjectFile files
198242
Shake.runWithSignal (Proxy @"kick/start/cabal-project") (Proxy @"kick/done/cabal-project") files Types.ParseCabalProjectFile
199243

200244

Lines changed: 86 additions & 92 deletions
Original file line numberDiff line numberDiff line change
@@ -1,99 +1,93 @@
1-
module Ide.Plugin.CabalProject.Diagnostics where
1+
{-# LANGUAGE DuplicateRecordFields #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
module Ide.Plugin.CabalProject.Diagnostics
4+
( errorDiagnostic
5+
, warningDiagnostic
6+
, positionFromCabalProjectPosition
7+
, fatalParseErrorDiagnostic
8+
-- * Re-exports
9+
, FileDiagnostic
10+
, Diagnostic(..)
11+
)
12+
where
213

3-
diagnostic = undefined
14+
import Control.Lens ((&), (.~))
15+
import qualified Data.Text as T
16+
import Development.IDE (FileDiagnostic)
17+
import Development.IDE.Types.Diagnostics (fdLspDiagnosticL,
18+
ideErrorWithSource)
19+
import Distribution.Fields (showPError, showPWarning)
20+
import qualified Distribution.Parsec as Syntax
21+
import Ide.PluginUtils (extendNextLine)
22+
import Language.LSP.Protocol.Lens (range)
23+
import Language.LSP.Protocol.Types (Diagnostic (..),
24+
DiagnosticSeverity (..),
25+
NormalizedFilePath,
26+
Position (Position),
27+
Range (Range),
28+
fromNormalizedFilePath)
429

5-
-- can use renderParseError: https://github.com/haskell/cabal/blob/master/cabal-install/src/Distribution/Client/Utils/Parsec.hs
30+
-- | Produce a diagnostic for a fatal Cabal parser error.
31+
fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic
32+
fatalParseErrorDiagnostic fp msg =
33+
mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg
634

7-
-- {-# LANGUAGE DuplicateRecordFields #-}
8-
-- {-# LANGUAGE OverloadedStrings #-}
9-
-- module Ide.Plugin.CabalProject.Diagnostics
10-
-- ( errorDiagnostic
11-
-- , warningDiagnostic
12-
-- , positionFromCabaProjectPosition
13-
-- , fatalParseErrorDiagnostic
14-
-- -- * Re-exports
15-
-- , FileDiagnostic
16-
-- , Diagnostic(..)
17-
-- )
18-
-- where
35+
-- | Produce a diagnostic from a Cabal parser error
36+
errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic
37+
errorDiagnostic fp err@(Syntax.PError pos _) =
38+
mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg
39+
where
40+
msg = T.pack $ showPError (fromNormalizedFilePath fp) err
1941

20-
-- import Control.Lens ((&), (.~))
21-
-- import qualified Data.Text as T
22-
-- import Development.IDE (FileDiagnostic)
23-
-- import Development.IDE.Types.Diagnostics (fdLspDiagnosticL,
24-
-- ideErrorWithSource)
25-
-- import Distribution.Fields (showPError, showPWarning)
26-
-- import qualified Distribution.Parsec as Syntax
27-
-- import Ide.PluginUtils (extendNextLine)
28-
-- import Language.LSP.Protocol.Lens (range)
29-
-- import Language.LSP.Protocol.Types (Diagnostic (..),
30-
-- DiagnosticSeverity (..),
31-
-- NormalizedFilePath,
32-
-- Position (Position),
33-
-- Range (Range),
34-
-- fromNormalizedFilePath)
42+
-- | Produce a diagnostic from a Cabal parser warning
43+
warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic
44+
warningDiagnostic fp warning@(Syntax.PWarning _ pos _) =
45+
mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg
46+
where
47+
msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning
3548

36-
-- -- | Produce a diagnostic for a fatal Cabal parser error.
37-
-- fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic
38-
-- fatalParseErrorDiagnostic fp msg =
39-
-- mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg
49+
-- | The Cabal parser does not output a _range_ for a warning/error,
50+
-- only a single source code 'Lib.Position'.
51+
-- We define the range to be _from_ this position
52+
-- _to_ the first column of the next line.
53+
toBeginningOfNextLine :: Syntax.Position -> Range
54+
toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos
55+
where
56+
pos = positionFromCabalProjectPosition cabalPos
4057

41-
-- -- | Produce a diagnostic from a Cabal parser error
42-
-- errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic
43-
-- errorDiagnostic fp err@(Syntax.PError pos _) =
44-
-- mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg
45-
-- where
46-
-- msg = T.pack $ showPError (fromNormalizedFilePath fp) err
58+
-- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands.
59+
--
60+
-- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based,
61+
-- while Cabal is one-based.
62+
--
63+
-- >>> positionFromCabalPosition $ Lib.Position 1 1
64+
-- Position 0 0
65+
positionFromCabalProjectPosition :: Syntax.Position -> Position
66+
positionFromCabalProjectPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col')
67+
where
68+
-- LSP is zero-based, Cabal is one-based
69+
-- Cabal can return line 0 for errors in the first line
70+
line' = if line <= 0 then 0 else line-1
71+
col' = if column <= 0 then 0 else column-1
4772

48-
-- -- | Produce a diagnostic from a Cabal parser warning
49-
-- warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic
50-
-- warningDiagnostic fp warning@(Syntax.PWarning _ pos _) =
51-
-- mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg
52-
-- where
53-
-- msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning
54-
55-
-- -- | The Cabal parser does not output a _range_ for a warning/error,
56-
-- -- only a single source code 'Lib.Position'.
57-
-- -- We define the range to be _from_ this position
58-
-- -- _to_ the first column of the next line.
59-
-- toBeginningOfNextLine :: Syntax.Position -> Range
60-
-- toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos
61-
-- where
62-
-- pos = positionFromCabalPosition cabalPos
63-
64-
-- -- | Convert a 'Lib.Position' from Cabal to a 'Range' that LSP understands.
65-
-- --
66-
-- -- Prefer this function over hand-rolled unpacking/packing, since LSP is zero-based,
67-
-- -- while Cabal is one-based.
68-
-- --
69-
-- -- >>> positionFromCabalPosition $ Lib.Position 1 1
70-
-- -- Position 0 0
71-
-- positionFromCabalPosition :: Syntax.Position -> Position
72-
-- positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col')
73-
-- where
74-
-- -- LSP is zero-based, Cabal is one-based
75-
-- -- Cabal can return line 0 for errors in the first line
76-
-- line' = if line <= 0 then 0 else line-1
77-
-- col' = if column <= 0 then 0 else column-1
78-
79-
-- -- | Create a 'FileDiagnostic'
80-
-- mkDiag
81-
-- :: NormalizedFilePath
82-
-- -- ^ Cabal file path
83-
-- -> T.Text
84-
-- -- ^ Where does the diagnostic come from?
85-
-- -> DiagnosticSeverity
86-
-- -- ^ Severity
87-
-- -> Range
88-
-- -- ^ Which source code range should the editor highlight?
89-
-- -> T.Text
90-
-- -- ^ The message displayed by the editor
91-
-- -> FileDiagnostic
92-
-- mkDiag file diagSource sev loc msg =
93-
-- ideErrorWithSource
94-
-- (Just diagSource)
95-
-- (Just sev)
96-
-- file
97-
-- msg
98-
-- Nothing
99-
-- & fdLspDiagnosticL . range .~ loc
73+
-- | Create a 'FileDiagnostic'
74+
mkDiag
75+
:: NormalizedFilePath
76+
-- ^ Cabal file path
77+
-> T.Text
78+
-- ^ Where does the diagnostic come from?
79+
-> DiagnosticSeverity
80+
-- ^ Severity
81+
-> Range
82+
-- ^ Which source code range should the editor highlight?
83+
-> T.Text
84+
-- ^ The message displayed by the editor
85+
-> FileDiagnostic
86+
mkDiag file diagSource sev loc msg =
87+
ideErrorWithSource
88+
(Just diagSource)
89+
(Just sev)
90+
file
91+
msg
92+
Nothing
93+
& fdLspDiagnosticL . range .~ loc
Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE StandaloneDeriving #-}
4+
{-# OPTIONS_GHC -Wno-orphans #-}
5+
6+
module Ide.Plugin.CabalProject.Orphans where
7+
8+
import Control.DeepSeq
9+
import Distribution.Fields.Field
10+
import Distribution.Parsec.Position
11+
-- import Control.DeepSeq (NFData)
12+
import qualified Distribution.Solver.Types.ProjectConfigPath as PCPath
13+
import GHC.Generics (Generic)
14+
15+
import qualified Distribution.Client.ProjectConfig.Types as PC
16+
17+
-- ----------------------------------------------------------------
18+
-- Cabal-syntax orphan instances we need sometimes
19+
-- ----------------------------------------------------------------
20+
21+
instance NFData (Field Position) where
22+
rnf (Field name fieldLines) = rnf name `seq` rnf fieldLines
23+
rnf (Section name sectionArgs fields) = rnf name `seq` rnf sectionArgs `seq` rnf fields
24+
25+
instance NFData (Name Position) where
26+
rnf (Name ann fName) = rnf ann `seq` rnf fName
27+
28+
instance NFData (FieldLine Position) where
29+
rnf (FieldLine ann bs) = rnf ann `seq` rnf bs
30+
31+
instance NFData (SectionArg Position) where
32+
rnf (SecArgName ann bs) = rnf ann `seq` rnf bs
33+
rnf (SecArgStr ann bs) = rnf ann `seq` rnf bs
34+
rnf (SecArgOther ann bs) = rnf ann `seq` rnf bs
35+
36+
-- Project Config Orphans
37+
38+
deriving instance NFData PCPath.ProjectConfigPath
39+
40+
instance NFData PC.ProjectConfig where
41+
rnf !_ = ()
42+

0 commit comments

Comments
 (0)