Skip to content

Commit 429eed6

Browse files
runeksvendsenfendor
runeksvendsen
authored and
fendor
committed
hls-cabal-plugin: Add plugin
Add golden parse test for test/testdata/simple.cabal Add module Ide.Plugin.Cabal.Diag Also: add -Wall Add parseCabalFileContents Use VFS for cabal file contents Diagnostics * Parse and display Errors * Parse and display Warnings Code Actions * Code Action for License Field
1 parent e66b424 commit 429eed6

File tree

8 files changed

+341
-51
lines changed

8 files changed

+341
-51
lines changed

‎haskell-language-server.cabal

-7
Original file line numberDiff line numberDiff line change
@@ -240,13 +240,6 @@ common cabal
240240
build-depends: hls-cabal-plugin ^>= 0.1
241241
cpp-options: -Dcabal
242242

243-
244-
common cabal
245-
if flag(cabal)
246-
build-depends: hls-cabal-plugin ^>= 0.1
247-
cpp-options: -Dcabal
248-
249-
250243
common class
251244
if flag(class)
252245
build-depends: hls-class-plugin ^>= 1.0

‎plugins/hls-cabal-plugin/hls-cabal-plugin.cabal

+33-9
Original file line numberDiff line numberDiff line change
@@ -1,37 +1,60 @@
11
cabal-version: 3.0
22
name: hls-cabal-plugin
33
version: 0.1.0.0
4-
synopsis:
4+
synopsis: Cabal integration plugin with Haskell Language Server
5+
description:
6+
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>
7+
58
homepage:
69
license: MIT
710
license-file: LICENSE
811
author: Fendor
912
maintainer: [email protected]
1013
category: Development
11-
extra-source-files: CHANGELOG.md
14+
extra-source-files:
15+
CHANGELOG.md
16+
test/testdata/simple.cabal
17+
test/testdata/simple.cabal.golden.txt
18+
19+
common warnings
20+
ghc-options: -Wall
1221

1322
library
14-
exposed-modules: Ide.Plugin.Cabal
23+
import: warnings
24+
exposed-modules:
25+
Ide.Plugin.Cabal
26+
Ide.Plugin.Cabal.Diag
27+
Ide.Plugin.Cabal.LicenseSuggest
28+
Ide.Plugin.Cabal.Parse
29+
1530
build-depends:
1631
, aeson
17-
, base >=4.12 && <5
32+
, base >=4.12 && <5
33+
, bytestring
34+
, Cabal
1835
, czipwith
36+
, deepseq
37+
, directory
1938
, extra
2039
, filepath
2140
, ghc-exactprint
22-
, ghcide >=1.6 && <1.8
23-
, hls-plugin-api >=1.3 && <1.5
41+
, ghcide >=1.6 && <1.8
42+
, hashable
43+
, hls-plugin-api >=1.3 && <1.5
2444
, lens
45+
, lsp
2546
, lsp-types
47+
, regex-tdfa
48+
, stm
2649
, text
2750
, transformers
51+
, unordered-containers
2852

29-
-- see https://github.com/lspitzner/brittany/issues/364
30-
-- TODO: remove these when GH issue #2005 is resolved
3153
hs-source-dirs: src
3254
default-language: Haskell2010
3355

34-
test-suite hls-cabal-plugin-test
56+
test-suite tests
57+
import: warnings
3558
default-language: Haskell2010
3659
type: exitcode-stdio-1.0
3760
hs-source-dirs: test
@@ -43,4 +66,5 @@ test-suite hls-cabal-plugin-test
4366
, hls-test-utils ^>=1.3
4467
, lsp
4568
, lsp-types
69+
, tasty-hunit
4670
, text

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

+100-34
Original file line numberDiff line numberDiff line change
@@ -1,59 +1,125 @@
11
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DeriveAnyClass #-}
32
{-# LANGUAGE DeriveGeneric #-}
43
{-# LANGUAGE DuplicateRecordFields #-}
54
{-# LANGUAGE FlexibleContexts #-}
65
{-# LANGUAGE FlexibleInstances #-}
76
{-# LANGUAGE LambdaCase #-}
7+
{-# LANGUAGE NamedFieldPuns #-}
88
{-# LANGUAGE OverloadedStrings #-}
9-
{-# LANGUAGE RecordWildCards #-}
10-
{-# LANGUAGE TupleSections #-}
119
{-# LANGUAGE TypeFamilies #-}
12-
{-# LANGUAGE ViewPatterns #-}
1310

1411
module Ide.Plugin.Cabal where
1512

13+
import Control.Concurrent.STM
14+
import Control.DeepSeq (NFData)
15+
import Control.Monad.Extra
1616
import Control.Monad.IO.Class
17-
import Data.Aeson
18-
import qualified Data.Text as T
19-
import Development.IDE as D
17+
import qualified Data.ByteString as BS
18+
import Data.Hashable
19+
import qualified Data.List.NonEmpty as NE
20+
import Data.Maybe (catMaybes)
21+
import qualified Data.Text as T
22+
import qualified Data.Text.Encoding as Encoding
23+
import Data.Typeable
24+
import Development.IDE as D
25+
import Development.IDE.Core.Shake (restartShakeSession)
26+
import qualified Development.IDE.Core.Shake as Shake
2027
import GHC.Generics
21-
import Ide.PluginUtils
28+
import qualified Ide.Plugin.Cabal.Diag as Diag
29+
import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
30+
import qualified Ide.Plugin.Cabal.Parse as Parse
31+
import Ide.Plugin.Config (Config)
2232
import Ide.Types
33+
import Language.LSP.Server (LspM)
2334
import Language.LSP.Types
35+
import qualified Language.LSP.Types as LSP
36+
import qualified Language.LSP.VFS as VFS
2437

25-
26-
newtype Log = LogText T.Text deriving Show
38+
data Log
39+
= LogText T.Text
40+
| LogShake Shake.Log deriving Show
2741

2842
instance Pretty Log where
2943
pretty = \case
30-
LogText log -> pretty log
44+
LogShake log' -> pretty log'
45+
LogText log' -> pretty log'
3146

3247
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
3348
descriptor recorder plId = (defaultCabalPluginDescriptor plId)
34-
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder)
35-
}
49+
{ pluginRules = exampleRules recorder
50+
, pluginHandlers = mkPluginHandler STextDocumentCodeAction licenseSuggest
51+
, pluginNotificationHandlers = mconcat
52+
[ mkPluginNotificationHandler LSP.STextDocumentDidOpen $
53+
\ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do
54+
whenUriFile _uri $ \file -> do
55+
logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri
56+
join $ atomically $ Shake.recordDirtyKeys (shakeExtras ide) GetModificationTime [file]
57+
restartShakeSession (shakeExtras ide) (VFSModified vfs) (fromNormalizedFilePath file ++ " (opened)") [Shake.mkDelayedAction "cabal parse open" Info $ void $ use Example file]
58+
join $ Shake.shakeEnqueue (shakeExtras ide) $ Shake.mkDelayedAction "cabal parse modified" Info $ void $ use Example file
3659

37-
-- ---------------------------------------------------------------------
38-
39-
codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeLens
40-
codeLens recorder _ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do
41-
log Debug $ LogText "ExampleCabal.codeLens entered (ideLogger)"
42-
case uriToFilePath' uri of
43-
Just (toNormalizedFilePath -> _filePath) -> do
44-
let
45-
title = "Add TODO Item via Code Lens"
46-
range = Range (Position 3 0) (Position 4 0)
47-
let cmdParams = AddTodoParams uri "do abc"
48-
cmd = mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams])
49-
pure $ Right $ List [ CodeLens range (Just cmd) Nothing ]
50-
Nothing -> pure $ Right $ List []
51-
where
52-
log = logWith recorder
53-
-- ---------------------------------------------------------------------
60+
, mkPluginNotificationHandler LSP.STextDocumentDidChange $
61+
\ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do
62+
whenUriFile _uri $ \file -> do
63+
logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri
64+
logDebug (ideLogger ide) $ "VFS State: " <> T.pack (show vfs)
65+
join $ atomically $ Shake.recordDirtyKeys (shakeExtras ide) GetModificationTime [file]
66+
restartShakeSession (shakeExtras ide) (VFSModified vfs) (fromNormalizedFilePath file ++ " (modified)") [Shake.mkDelayedAction "cabal parse modified" Info $ void $ use Example file]
67+
join $ Shake.shakeEnqueue (shakeExtras ide) $ Shake.mkDelayedAction "cabal parse modified" Info $ void $ use Example file
5468

55-
data AddTodoParams = AddTodoParams
56-
{ file :: Uri -- ^ Uri of the file to add the pragma to
57-
, todoText :: T.Text
69+
, mkPluginNotificationHandler LSP.STextDocumentDidSave $
70+
\ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do
71+
whenUriFile _uri $ \file -> do
72+
logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri
73+
join $ atomically $ Shake.recordDirtyKeys (shakeExtras ide) GetModificationTime [file]
74+
restartShakeSession (shakeExtras ide) (VFSModified vfs) (fromNormalizedFilePath file ++ " (saved)") [Shake.mkDelayedAction "cabal parse saved" Info $ void $ use Example file]
75+
join $ Shake.shakeEnqueue (shakeExtras ide) $ Shake.mkDelayedAction "cabal parse modified" Info $ void $ use Example file
76+
77+
, mkPluginNotificationHandler LSP.STextDocumentDidClose $
78+
\ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do
79+
whenUriFile _uri $ \file -> do
80+
let msg = "Closed text document: " <> getUri _uri
81+
logDebug (ideLogger ide) msg
82+
join $ atomically $ Shake.recordDirtyKeys (shakeExtras ide) GetModificationTime [file]
83+
restartShakeSession (shakeExtras ide) (VFSModified vfs) (fromNormalizedFilePath file ++ " (closed)") [Shake.mkDelayedAction "cabal parse closed" Info $ void $ use Example file]
84+
join $ Shake.shakeEnqueue (shakeExtras ide) $ Shake.mkDelayedAction "cabal parse modified" Info $ void $ use Example file
85+
]
5886
}
59-
deriving (Show, Eq, Generic, ToJSON, FromJSON)
87+
where
88+
whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
89+
whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
90+
licenseSuggest
91+
:: IdeState
92+
-> PluginId
93+
-> CodeActionParams
94+
-> LspM Config (Either ResponseError (ResponseResult 'TextDocumentCodeAction))
95+
licenseSuggest _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List diags}) =
96+
pure $ Right $ List $ catMaybes $ map (fmap InR . LicenseSuggest.licenseErrorAction uri) diags
97+
98+
data Example = Example
99+
deriving (Eq, Show, Typeable, Generic)
100+
instance Hashable Example
101+
instance NFData Example
102+
103+
type instance RuleResult Example = ()
104+
105+
exampleRules :: Recorder (WithPriority Log) -> Rules ()
106+
exampleRules recorder = do
107+
define (cmapWithPrio LogShake recorder) $ \Example file -> do
108+
t <- use GetModificationTime file
109+
logWith recorder Debug $ LogText $ "Parse: " <> T.pack (show file) <> " " <> T.pack (show t)
110+
mVirtualFile <- Shake.getVirtualFile file
111+
contents <- case mVirtualFile of
112+
Just vfile -> pure $ Encoding.encodeUtf8 $ VFS.virtualFileText vfile
113+
Nothing -> do
114+
liftIO $ BS.readFile $ fromNormalizedFilePath file
115+
116+
_pm <- liftIO $ Parse.parseCabalFileContents contents
117+
liftIO $ log' Debug $ LogText $ T.pack $ "Parsed file: " <> fromNormalizedFilePath file <> ". Result: " <> show _pm
118+
let diagLst = case _pm of
119+
(_, Left (_, pErrorNE)) ->
120+
NE.toList $ NE.map (Diag.errorDiag file) pErrorNE
121+
_ -> []
122+
logWith recorder Debug $ LogText $ "Diagnostics: " <> T.pack (show diagLst)
123+
return (diagLst, Just ())
124+
where
125+
log' = logWith recorder

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diag.hs

+72
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# LANGUAGE DuplicateRecordFields #-}
2+
{-# LANGUAGE TupleSections #-}
3+
module Ide.Plugin.Cabal.Diag
4+
( errorDiag
5+
-- * Re-exports
6+
, FileDiagnostic
7+
, Diagnostic(..)
8+
)
9+
where
10+
11+
import qualified Data.Text as T
12+
import Development.IDE (FileDiagnostic,
13+
ShowDiagnostic (ShowDiag))
14+
import Distribution.Fields (showPError, showPWarning)
15+
import qualified Ide.Plugin.Cabal.Parse as Lib
16+
import Language.LSP.Types (Diagnostic (..),
17+
DiagnosticSeverity (..),
18+
DiagnosticSource, NormalizedFilePath,
19+
Position (Position), Range (Range),
20+
fromNormalizedFilePath)
21+
22+
-- | Produce a diagnostic from a Cabal parser error
23+
errorDiag :: NormalizedFilePath -> Lib.PError -> FileDiagnostic
24+
errorDiag fp err@(Lib.PError pos _) =
25+
mkDiag fp (T.pack "parsing") DsError (toBeginningOfNextLine pos) msg
26+
where
27+
msg = T.pack $ showPError (fromNormalizedFilePath fp) err
28+
29+
-- | Produce a diagnostic from a Cabal parser warning
30+
warningDiag :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic
31+
warningDiag fp warning@(Lib.PWarning _ pos _) =
32+
mkDiag fp (T.pack "parsing") DsWarning (toBeginningOfNextLine pos) msg
33+
where
34+
msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning
35+
36+
-- The Cabal parser does not output a _range_ for a warning/error,
37+
-- only a single source code 'Lib.Position'.
38+
-- We define the range to be _from_ this position
39+
-- _to_ the first column of the next line.
40+
toBeginningOfNextLine :: Lib.Position -> Range
41+
toBeginningOfNextLine (Lib.Position line column) =
42+
Range
43+
(Position (fromIntegral line') (fromIntegral col'))
44+
(Position (fromIntegral $ line' + 1) 0)
45+
where
46+
-- LSP is zero-based, Cabal is one-based
47+
line' = line-1
48+
col' = column-1
49+
50+
-- | Create a 'FileDiagnostic'
51+
mkDiag
52+
:: NormalizedFilePath
53+
-- ^ Cabal file path
54+
-> DiagnosticSource
55+
-- ^ Where does the diagnostic come from?
56+
-> DiagnosticSeverity
57+
-- ^ Severity
58+
-> Range
59+
-- ^ Which source code range should the editor highlight?
60+
-> T.Text
61+
-- ^ The message displayed by the editor
62+
-> FileDiagnostic
63+
mkDiag file diagSource sev loc msg = (file, ShowDiag,)
64+
Diagnostic
65+
{ _range = loc
66+
, _severity = Just sev
67+
, _source = Just diagSource
68+
, _message = msg
69+
, _code = Nothing
70+
, _tags = Nothing
71+
, _relatedInformation = Nothing
72+
}

‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs

+73
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,73 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE ExplicitNamespaces #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
module Ide.Plugin.Cabal.LicenseSuggest
7+
( licenseErrorSuggestion
8+
, licenseErrorAction
9+
-- * Re-exports
10+
, T.Text
11+
, Diagnostic(..)
12+
)
13+
where
14+
15+
import qualified Data.HashMap.Strict as Map
16+
import qualified Data.Text as T
17+
import Language.LSP.Types (CodeAction (CodeAction),
18+
CodeActionKind (CodeActionQuickFix),
19+
Diagnostic (..), List (List),
20+
Position (Position), Range (Range),
21+
TextEdit (TextEdit), Uri,
22+
WorkspaceEdit (WorkspaceEdit))
23+
import Text.Regex.TDFA
24+
25+
-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiag',
26+
-- if it represents an "Unknown SPDX license identifier"-error along
27+
-- with a suggestion, then return a 'CodeAction' for replacing the
28+
-- the incorrect license identifier with the suggestion.
29+
licenseErrorAction
30+
:: Uri
31+
-- ^ File for which the diagnostic was generated
32+
-> Diagnostic
33+
-- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiag'
34+
-> Maybe CodeAction
35+
licenseErrorAction uri diag =
36+
mkCodeAction <$> licenseErrorSuggestion diag
37+
where
38+
mkCodeAction (original, suggestion) =
39+
let
40+
-- The Cabal parser does not output the _range_ of the incorrect license identifier,
41+
-- only a single source code position. Consequently, in 'Ide.Plugin.Cabal.Diag.errorDiag'
42+
-- we define the range to be from the returned position the first column of the next line.
43+
-- Since the "replace" code action replaces this range, we need to modify the range to
44+
-- start at the first character of the invalid license identifier. We achieve this by
45+
-- subtracting the length of the identifier from the beginning of the range.
46+
adjustRange (Range (Position line col) rangeTo) =
47+
Range (Position line (col - fromIntegral (T.length original))) rangeTo
48+
title = "Replace with " <> suggestion
49+
-- We must also add a newline character to the replacement since the range returned by
50+
-- 'Ide.Plugin.Cabal.Diag.errorDiag' ends at the beginning of the following line.
51+
tedit = [TextEdit (adjustRange $ _range diag) (suggestion <> "\n")]
52+
edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
53+
in CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing
54+
55+
-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiag',
56+
-- if it represents an "Unknown SPDX license identifier"-error along
57+
-- with a suggestion then return the suggestion (after the "Do you mean"-text)
58+
-- along with the incorrect identifier.
59+
licenseErrorSuggestion
60+
:: Diagnostic
61+
-- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiag'
62+
-> Maybe (T.Text, T.Text)
63+
-- ^ (Original (incorrect) license identifier, suggested replacement)
64+
licenseErrorSuggestion diag =
65+
mSuggestion (_message diag) >>= \case
66+
[original, suggestion] -> Just (original, suggestion)
67+
_ -> Nothing
68+
where
69+
regex :: T.Text
70+
regex = "Unknown SPDX license identifier: '(.*)' Do you mean (.*)\\?"
71+
mSuggestion msg = getMatch <$> (msg :: T.Text) =~~ regex
72+
getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text]
73+
getMatch (_, _, _, results) = results

0 commit comments

Comments
 (0)