Skip to content

Commit 49e635d

Browse files
crtschincrtschin
committed
Add hls-export-plugin with the Export code action
Offered on `-Wunused-top-binds` diagnostics.
1 parent 0c3d0e9 commit 49e635d

9 files changed

Lines changed: 658 additions & 0 deletions

File tree

‎.github/workflows/test.yml‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -262,6 +262,10 @@ jobs:
262262
name: Test hls-signature-help-plugin test suite
263263
run: cabal test ${CABAL_ARGS} hls-signature-help-plugin-tests || cabal test ${CABAL_ARGS} hls-signature-help-plugin-tests
264264

265+
- if: matrix.test
266+
name: Test hls-export-plugin test suite
267+
run: cabal test ${CABAL_ARGS} hls-export-plugin-tests || cabal test ${CABAL_ARGS} hls-export-plugin-tests
268+
265269
test_post_job:
266270
if: always()
267271
runs-on: ubuntu-latest

‎haskell-language-server.cabal‎

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1778,6 +1778,61 @@ library hls-exactprint-utils
17781778
default-extensions:
17791779
CPP
17801780

1781+
flag export
1782+
description: Enable export plugin
1783+
default: True
1784+
manual: True
1785+
1786+
common export
1787+
if flag(export)
1788+
build-depends: haskell-language-server:hls-export-plugin
1789+
cpp-options: -Dhls_export
1790+
1791+
library hls-export-plugin
1792+
import: defaults, pedantic, warnings
1793+
if !flag(export)
1794+
buildable: False
1795+
exposed-modules:
1796+
Ide.Plugin.Export
1797+
other-modules:
1798+
Ide.Plugin.Export.Cursor
1799+
Ide.Plugin.Export.ExactPrint
1800+
Ide.Plugin.Export.Exports
1801+
Ide.Plugin.Export.Utils
1802+
hs-source-dirs: plugins/hls-export-plugin/src
1803+
default-language: GHC2021
1804+
build-depends:
1805+
, containers
1806+
, ghc
1807+
, ghc-exactprint
1808+
, ghcide == 2.14.0.0
1809+
, haskell-language-server:hls-exactprint-utils
1810+
, hls-plugin-api == 2.14.0.0
1811+
, lens
1812+
, lsp >=2.8
1813+
, stm
1814+
, text
1815+
default-extensions:
1816+
, DataKinds
1817+
, LambdaCase
1818+
, OverloadedStrings
1819+
1820+
test-suite hls-export-plugin-tests
1821+
import: defaults, pedantic, test-defaults, warnings
1822+
if !flag(export)
1823+
buildable: False
1824+
type: exitcode-stdio-1.0
1825+
hs-source-dirs: plugins/hls-export-plugin/test
1826+
main-is: Main.hs
1827+
build-depends:
1828+
, filepath
1829+
, haskell-language-server:hls-export-plugin
1830+
, hls-test-utils == 2.14.0.0
1831+
, lens
1832+
, lsp-types
1833+
, text
1834+
default-extensions: OverloadedStrings
1835+
17811836
----------------------------
17821837
----------------------------
17831838
-- HLS
@@ -1816,6 +1871,7 @@ library
18161871
, overloadedRecordDot
18171872
, semanticTokens
18181873
, notes
1874+
, export
18191875

18201876
exposed-modules:
18211877
Ide.Arguments

‎plugins/hls-export-plugin/README.md‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
# Export Plugin
2+
3+
The export plugin provides code actions for working with a module's export list. It provides code actions for:
4+
5+
- Export `...`: on top-level declaration symbols.
6+
7+
Actions are only offered when the module has an explicit export list.
8+
9+
## Known limitations
10+
11+
Not yet supported:
12+
- Class methods (`class C where { m :: ... }`)
13+
- Type and data families (standalone or associated)
14+
- Pattern synonyms (`pattern P :: ...`)
15+
- Module re-exports (`module M`)

‎plugins/hls-export-plugin/src/Ide/Plugin/Export.hs‎

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,81 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
4+
module Ide.Plugin.Export (descriptor) where
5+
6+
import Control.Concurrent.STM (atomically)
7+
import Control.Lens
8+
import Control.Monad.IO.Class (liftIO)
9+
import Data.Text (Text)
10+
import qualified Data.Text as T
11+
import Development.IDE
12+
import Development.IDE.Core.PluginUtils (runActionE, useE)
13+
import Development.IDE.Core.Shake (getDiagnostics)
14+
import Development.IDE.GHC.Compat
15+
import Development.IDE.GHC.Compat.Error (_TcRnMessage,
16+
msgEnvelopeErrorL)
17+
import GHC.Tc.Errors.Types (TcRnMessage (TcRnUnusedName),
18+
UnusedNameProv (UnusedNameTopDecl))
19+
import Ide.Plugin.Error (getNormalizedFilePathE)
20+
import Ide.Plugin.Export.Cursor
21+
import Ide.Plugin.Export.ExactPrint
22+
import Ide.Plugin.Export.Exports
23+
import Ide.Plugin.Export.Utils
24+
import Ide.Types
25+
import qualified Ide.Types as Ide
26+
import qualified Language.LSP.Protocol.Lens as L
27+
import Language.LSP.Protocol.Message (Method (..), SMethod (..))
28+
import Language.LSP.Protocol.Types
29+
30+
descriptor :: PluginId -> PluginDescriptor IdeState
31+
descriptor plId =
32+
let exportHandlers = mkPluginHandler SMethod_TextDocumentCodeAction quickCodeActionHandlers
33+
in (defaultPluginDescriptor plId "Code actions for module export lists")
34+
{ Ide.pluginHandlers = exportHandlers
35+
}
36+
37+
quickCodeActionHandlers :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
38+
quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do
39+
let uri = doc ^. L.uri
40+
nfp <- getNormalizedFilePathE uri
41+
pm <- runActionE "Export.GetParsedModuleWithComments" state (useE GetParsedModuleWithComments nfp)
42+
let ps = pm_parsed_source pm
43+
case (isExplicit ps, locateUnderCursor (range ^. L.start) ps) of
44+
(True, Just under) -> do
45+
-- The names GHC flags as defined-but-unused. Attach the action to the
46+
-- unused diagnostics as well.
47+
unusedDiags <- liftIO $ unusedTopBindDiagnostics state nfp
48+
pure . InL . map InR $
49+
[ ca
50+
| Just (verb, title, edits) <-
51+
[ addAction under ps
52+
]
53+
, let fixes = [ d | d <- unusedDiags, locateUnderCursor (d ^. L.range . L.start) ps == Just under ]
54+
ca = mkAction (verb <> " `" <> title <> "`")
55+
& L.edit ?~ singleFileEdit uri edits
56+
& L.diagnostics .~ (if null fixes then Nothing else Just fixes)
57+
]
58+
_ -> pure (InL [])
59+
60+
-- | The LSP diagnostics for names GHC reports as unused top-level definitions.
61+
unusedTopBindDiagnostics :: IdeState -> NormalizedFilePath -> IO [Diagnostic]
62+
unusedTopBindDiagnostics state nfp = do
63+
diags <- atomically $ getDiagnostics state
64+
pure [ fdLspDiagnostic d | d <- diags, fdFilePath d == nfp, isUnusedTopBind d ]
65+
where
66+
isUnusedTopBind d =
67+
case d ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
68+
Just (TcRnUnusedName _ UnusedNameTopDecl) -> True
69+
_ -> False
70+
71+
addAction :: UnderCursor -> ParsedSource -> Maybe (Text, Text, [TextEdit])
72+
addAction under ps = case under of
73+
Decl flavor n
74+
| n `isExported` ps -> Nothing
75+
| otherwise -> ("Export", T.pack (printRdrName n),) <$> addExport ps (mkExportIE flavor n)
76+
Constructor t c
77+
| c `isExported` ps -> Nothing
78+
| otherwise ->
79+
("Export", T.pack (printRdrName t) <> "(" <> T.pack (printRdrName c) <> ")",)
80+
<$> addConstructorExport t c ps
81+
Header -> Nothing

‎plugins/hls-export-plugin/src/Ide/Plugin/Export/Cursor.hs‎

Lines changed: 89 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,89 @@
1+
module Ide.Plugin.Export.Cursor
2+
( ExportFlavor (..)
3+
, UnderCursor (..)
4+
, locateUnderCursor
5+
) where
6+
7+
import Control.Applicative ((<|>))
8+
import Data.Foldable (toList)
9+
import Data.List (find)
10+
import Data.Maybe
11+
import Development.IDE
12+
import Development.IDE.GHC.Compat
13+
14+
-- | How a top-level entity is rendered in an export list.
15+
data ExportFlavor
16+
= ExportName -- ^ bare @x@. An operator is parenthesized with no @type@ keyword. Values and type synonyms.
17+
| ExportPattern -- ^ @pattern X@.
18+
| ExportFamily -- ^ bare @T@. An operator becomes @type (:<)@. Type and data families.
19+
| ExportAll -- ^ @T(..)@. An operator becomes @type (:<)(..)@. Data, newtype, and class.
20+
deriving Eq
21+
22+
data UnderCursor
23+
= Decl ExportFlavor RdrName
24+
| Constructor RdrName RdrName
25+
| Header
26+
deriving Eq
27+
28+
locateUnderCursor :: Position -> ParsedSource -> Maybe UnderCursor
29+
locateUnderCursor pos ps = classifyHeader pos (unLoc ps) <|> classifyInDecl
30+
where
31+
classifyInDecl = do
32+
L _ decl <- find (\(L l _) -> pos `isInsideSrcSpan` locA l) (hsmodDecls (unLoc ps))
33+
classifyDecl pos decl
34+
35+
-- | Match column-free so cursor anywhere on the @module ... where@ line counts.
36+
classifyHeader :: Position -> HsModule GhcPs -> Maybe UnderCursor
37+
classifyHeader pos mod = inName <|> inExports
38+
where
39+
isIn :: HasSrcSpan a => Maybe a -> Maybe UnderCursor
40+
isIn el = el >>= \n -> if pos `isInsideSrcSpanLines` getLoc n then Just Header else Nothing
41+
inName = isIn $ hsmodName mod
42+
inExports = isIn $ hsmodExports mod
43+
44+
-- | Line-based span containment, column-agnostic.
45+
isInsideSrcSpanLines :: Position -> SrcSpan -> Bool
46+
Position l _ `isInsideSrcSpanLines` r = case srcSpanToRange r of
47+
Just (Range (Position sl _) (Position el _)) -> sl <= l && l <= el
48+
_ -> False
49+
50+
-- | The exportable entities a top-level declaration defines, each with its
51+
-- export flavor and located name.
52+
declEntities :: HsDecl GhcPs -> [(ExportFlavor, LIdP GhcPs)]
53+
declEntities = \case
54+
ValD _ (PatSynBind _ PSB {psb_id = lname}) -> [(ExportPattern, lname)]
55+
ValD _ FunBind {fun_id = lname} -> [(ExportName, lname)]
56+
TyClD _ DataDecl {tcdLName = lname} -> [(ExportAll, lname)]
57+
TyClD _ ClassDecl {tcdLName = lname} -> [(ExportAll, lname)]
58+
TyClD _ SynDecl {tcdLName = lname} -> [(ExportName, lname)]
59+
TyClD _ FamDecl {tcdFam = fam} -> [(ExportFamily, fdLName fam)]
60+
_ -> []
61+
62+
classifyDecl :: Position -> HsDecl GhcPs -> Maybe UnderCursor
63+
classifyDecl pos decl =
64+
listToMaybe [Decl flavor (unLoc n) | (flavor, n) <- declEntities decl, onName n]
65+
<|> typeSigUnderCursor
66+
<|> constructorUnderDecl
67+
where
68+
onName (L l _) = pos `isInsideSrcSpan` locA l
69+
-- A signature is not a definition (so not in 'declEntities'), but its name
70+
-- is still a valid place to invoke the export action from.
71+
typeSigUnderCursor = case decl of
72+
SigD _ (TypeSig _ names _) -> Decl ExportName . unLoc <$> find onName names
73+
_ -> Nothing
74+
constructorUnderDecl = case decl of
75+
TyClD _ DataDecl {tcdLName = lname, tcdDataDefn = HsDataDefn {dd_cons = cons}}
76+
-> Constructor (unLoc lname) <$> constructorUnderCursor pos cons
77+
_ -> Nothing
78+
79+
constructorUnderCursor :: Position -> DataDefnCons (LConDecl GhcPs) -> Maybe RdrName
80+
constructorUnderCursor pos cons =
81+
listToMaybe . mapMaybe nameAt $ extract_cons cons
82+
where
83+
nameAt (L _ cd) =
84+
listToMaybe [n | L l n <- conDeclNames cd, pos `isInsideSrcSpan` locA l]
85+
86+
conDeclNames = \case
87+
ConDeclH98 {con_name = lname} -> [lname]
88+
ConDeclGADT {con_names = lnames} -> toList lnames
89+
_ -> []

0 commit comments

Comments
 (0)