Create hls-export-plugin with Export '...' code action

.github/workflows/test.yml

@@ -262,6 +262,10 @@ jobs:
         name: Test hls-signature-help-plugin test suite
         run: cabal test ${CABAL_ARGS} hls-signature-help-plugin-tests || cabal test ${CABAL_ARGS} hls-signature-help-plugin-tests
 
+      - if: matrix.test
+        name: Test hls-export-plugin test suite
+        run: cabal test ${CABAL_ARGS} hls-export-plugin-tests || cabal test ${CABAL_ARGS} hls-export-plugin-tests
+
   test_post_job:
     if: always()
     runs-on: ubuntu-latest

ghcide/src/Development/IDE/GHC/Compat/Error.hs

@@ -32,6 +32,7 @@ module Development.IDE.GHC.Compat.Error (
   _TcRnPartialTypeSignatures,
   _TcRnMissingSignature,
   _TcRnSolverReport,
+  _TcRnUnusedTopBind,
   _TcRnMessageWithInfo,
   _TypeHole,
   _ConstraintHole,
@@ -82,6 +83,17 @@ _GhcDriverMessage = prism' GhcDriverMessage (\case
   GhcDriverMessage driverMsg -> Just driverMsg
   _ -> Nothing)
 
+-- | Focus an unused top-level binding warning (@-Wunused-top-binds@). Structured
+-- provenance for this only exists from GHC 9.8 (GHC #20115).
+_TcRnUnusedTopBind :: Fold GhcMessage ()
+#if MIN_VERSION_ghc(9,8,0)
+_TcRnUnusedTopBind = _TcRnMessage . folding (\case
+  TcRnUnusedName _ UnusedNameTopDecl -> Just ()
+  _                                  -> Nothing)
+#else
+_TcRnUnusedTopBind = ignored
+#endif
+
 -- | Some 'TcRnMessage's are nested in other constructors for additional context.
 -- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.
 -- However, in some occasions you don't need the additional context and you just want

haskell-language-server.cabal

@@ -1585,6 +1585,7 @@ library hls-refactor-plugin
     , ghc-boot
     , regex-tdfa
     , ghcide                == 2.14.0.0
+    , haskell-language-server:hls-exactprint-utils
     , hls-plugin-api        == 2.14.0.0
     , lsp
     , text
@@ -1762,6 +1763,77 @@ test-suite hls-notes-plugin-tests
     , hls-test-utils == 2.14.0.0
   default-extensions: OverloadedStrings
 
+-----------------------------
+-- export plugin
+-----------------------------
+
+library hls-exactprint-utils
+  import: defaults, pedantic, warnings
+  exposed-modules:
+    Development.IDE.GHC.ExactPrint.Annotation
+  hs-source-dirs:     hls-exactprint-utils/src
+  build-depends:
+    , ghc
+    , ghc-exactprint
+    , ghcide          == 2.14.0.0
+  default-extensions:
+      CPP
+
+flag export
+  description: Enable export plugin
+  default:     True
+  manual:      True
+
+common export
+  if flag(export)
+    build-depends: haskell-language-server:hls-export-plugin
+    cpp-options: -Dhls_export
+
+library hls-export-plugin
+  import: defaults, pedantic, warnings
+  if !flag(export)
+    buildable: False
+  exposed-modules:
+    Ide.Plugin.Export
+  other-modules:
+    Ide.Plugin.Export.Cursor
+    Ide.Plugin.Export.ExactPrint
+    Ide.Plugin.Export.Exports
+    Ide.Plugin.Export.Utils
+  hs-source-dirs:     plugins/hls-export-plugin/src
+  default-language:   GHC2021
+  build-depends:
+    , containers
+    , ghc
+    , ghc-exactprint
+    , ghcide          == 2.14.0.0
+    , haskell-language-server:hls-exactprint-utils
+    , hls-plugin-api  == 2.14.0.0
+    , lens
+    , lsp >=2.8
+    , stm
+    , text
+  default-extensions:
+    , DataKinds
+    , LambdaCase
+    , OverloadedStrings
+
+test-suite hls-export-plugin-tests
+  import:           defaults, pedantic, test-defaults, warnings
+  if !flag(export)
+    buildable: False
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   plugins/hls-export-plugin/test
+  main-is:          Main.hs
+  build-depends:
+    , filepath
+    , haskell-language-server:hls-export-plugin
+    , hls-test-utils == 2.14.0.0
+    , lens
+    , lsp-types
+    , text
+  default-extensions: OverloadedStrings
+
 ----------------------------
 ----------------------------
 -- HLS
@@ -1800,6 +1872,7 @@ library
                   , overloadedRecordDot
                   , semanticTokens
                   , notes
+                  , export
 
   exposed-modules:
     Ide.Arguments

hls-exactprint-utils/src/Development/IDE/GHC/ExactPrint/Annotation.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Version-agnostic primitives for ghc-exactprint annotations, shared by the
+-- refactor and export plugins.
+module Development.IDE.GHC.ExactPrint.Annotation
+  ( epl
+  , isCommaAnn
+  , trailingAnns
+  , overTrailingAnns
+  , removeTrailingCommaAnn
+  , ensureTrailingComma
+  , withTrailingComma
+  , modifyAnns
+  , addParens
+  , parenthesizeName
+  ) where
+
+import           Data.Bifunctor                  (first)
+import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Orphans     ()
+import           GHC                             (LocatedN)
+#if MIN_VERSION_ghc(9,11,0)
+import           GHC                             (DeltaPos (..), EpAnn (..),
+                                                  EpToken (..), EpaLocation,
+                                                  EpaLocation' (..),
+                                                  NameAdornment (..),
+                                                  SrcSpanAnnA, TrailingAnn (..))
+import           GHC.Types.SrcLoc                (UnhelpfulSpanReason (..))
+#elif MIN_VERSION_ghc(9,9,0)
+import           GHC                             (DeltaPos (..), EpAnn (..),
+                                                  EpaLocation,
+                                                  EpaLocation' (..),
+                                                  NameAdornment (..),
+                                                  SrcSpanAnnA, TrailingAnn (..))
+#else
+import           GHC                             (Anchor (..),
+                                                  AnchorOperation (..),
+                                                  DeltaPos (..), EpAnn (..),
+                                                  EpaLocation (..),
+                                                  NameAdornment (NameParens),
+                                                  SrcSpanAnn' (..), SrcSpanAnnA,
+                                                  TrailingAnn (..),
+                                                  emptyComments, realSrcSpan)
+import           GHC.Types.SrcLoc                (generatedSrcSpan)
+#endif
+import           Language.Haskell.GHC.ExactPrint (addComma)
+
+-- | An entry delta of @n@ spaces on the same line.
+epl :: Int -> EpaLocation
+#if MIN_VERSION_ghc(9,11,0)
+epl n = EpaDelta (UnhelpfulSpan UnhelpfulNoLocationInfo) (SameLine n) []
+#else
+epl n = EpaDelta (SameLine n) []
+#endif
+
+isCommaAnn :: TrailingAnn -> Bool
+isCommaAnn AddCommaAnn{} = True
+isCommaAnn _             = False
+
+trailingAnns :: SrcSpanAnnA -> [TrailingAnn]
+#if MIN_VERSION_ghc(9,9,0)
+trailingAnns (EpAnn _ (AnnListItem as) _) = as
+#else
+trailingAnns sa = case ann sa of
+  EpAnn _ (AnnListItem as) _ -> as
+  _                          -> []
+#endif
+
+-- | Map over an item's trailing annotations, hiding the version-specific 'AnnListItem' shape.
+overTrailingAnns :: ([TrailingAnn] -> [TrailingAnn]) -> SrcSpanAnnA -> SrcSpanAnnA
+#if MIN_VERSION_ghc(9,9,0)
+overTrailingAnns f (EpAnn anc (AnnListItem as) cs) = EpAnn anc (AnnListItem (f as)) cs
+#else
+overTrailingAnns _ it@(SrcSpanAnn EpAnnNotUsed _) = it
+overTrailingAnns f (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) =
+  SrcSpanAnn (EpAnn anc (AnnListItem (f as)) cs) l
+#endif
+
+removeTrailingCommaAnn :: SrcSpanAnnA -> SrcSpanAnnA
+removeTrailingCommaAnn = overTrailingAnns (filter (not . isCommaAnn))
+
+ensureTrailingComma :: SrcSpanAnnA -> SrcSpanAnnA
+ensureTrailingComma ann
+  | any isCommaAnn (trailingAnns ann) = ann
+  | otherwise = addComma ann
+
+-- | Replace an item's trailing comma with @c@, preserving its delta.
+withTrailingComma :: TrailingAnn -> SrcSpanAnnA -> SrcSpanAnnA
+withTrailingComma c = overTrailingAnns (\as -> filter (not . isCommaAnn) as ++ [c])
+
+modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast
+#if MIN_VERSION_ghc(9,9,0)
+modifyAnns x f = first (fmap f) x
+#else
+modifyAnns x f = first ((fmap . fmap) f) x
+#endif
+
+addParens :: Bool -> NameAnn -> NameAnn
+#if MIN_VERSION_ghc(9,11,0)
+addParens True it@NameAnn{} =
+  it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }
+addParens True it@NameAnnCommas{} =
+  it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }
+addParens True it@NameAnnOnly{} =
+  it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }
+addParens True it@NameAnnTrailing{} =
+  NameAnn{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)), nann_name = epl 0, nann_trailing = nann_trailing it}
+#else
+addParens True it@NameAnn{} =
+  it{nann_adornment = NameParens, nann_open=epl 0, nann_close=epl 0 }
+addParens True it@NameAnnCommas{} =
+  it{nann_adornment = NameParens, nann_open=epl 0, nann_close=epl 0 }
+addParens True it@NameAnnOnly{} =
+  it{nann_adornment = NameParens, nann_open=epl 0, nann_close=epl 0 }
+addParens True NameAnnTrailing{..} =
+  NameAnn{nann_adornment = NameParens, nann_open=epl 0, nann_close=epl 0, nann_name = epl 0, ..}
+#endif
+addParens _ it = it
+
+-- | Parenthesize an operator name for an export/import item, e.g. @(<|)@.
+parenthesizeName :: LocatedN RdrName -> LocatedN RdrName
+#if MIN_VERSION_ghc(9,9,0)
+parenthesizeName ln = modifyAnns ln (addParens True)
+#else
+-- A freshly built name carries EpAnnNotUsed pre-9.9, giving 'addParens' no
+-- NameAnn to act on, so install a concrete annotation first.
+parenthesizeName (L (SrcSpanAnn ann l) rdr) =
+    L (SrcSpanAnn (EpAnn anc (addParens True nameAnn) cs) l) rdr
+  where
+    (anc, nameAnn, cs) = case ann of
+      EpAnn a n c  -> (a, n, c)
+      EpAnnNotUsed -> (genAnchor0, NameAnnTrailing [], emptyComments)
+
+genAnchor0 :: Anchor
+genAnchor0 = Anchor (realSrcSpan generatedSrcSpan) (MovedAnchor (SameLine 0))
+#endif

plugins/hls-export-plugin/README.md

@@ -0,0 +1,15 @@
+# Export Plugin
+
+The export plugin provides code actions for working with a module's export list. It provides code actions for:
+
+- Export `...`: on top-level declaration symbols.
+
+Actions are only offered when the module has an explicit export list.
+
+## Known limitations
+
+Not yet supported:
+- Class methods (`class C where { m :: ... }`)
+- Type and data families (standalone or associated)
+- Pattern synonyms (`pattern P :: ...`)
+- Module re-exports (`module M`)

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

@@ -0,0 +1,76 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Ide.Plugin.Export (descriptor) where
+
+import           Control.Concurrent.STM           (atomically)
+import           Control.Lens
+import           Control.Monad.IO.Class           (liftIO)
+import           Data.Text                        (Text)
+import qualified Data.Text                        as T
+import           Development.IDE
+import           Development.IDE.Core.PluginUtils (runActionE, useE)
+import           Development.IDE.Core.Shake       (getDiagnostics)
+import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Compat.Error (_TcRnUnusedTopBind,
+                                                   msgEnvelopeErrorL)
+import           Ide.Plugin.Error                 (getNormalizedFilePathE)
+import           Ide.Plugin.Export.Cursor
+import           Ide.Plugin.Export.ExactPrint
+import           Ide.Plugin.Export.Exports
+import           Ide.Plugin.Export.Utils
+import           Ide.Types
+import qualified Ide.Types                        as Ide
+import qualified Language.LSP.Protocol.Lens       as L
+import           Language.LSP.Protocol.Message    (Method (..), SMethod (..))
+import           Language.LSP.Protocol.Types
+
+descriptor :: PluginId -> PluginDescriptor IdeState
+descriptor plId =
+  let exportHandlers = mkPluginHandler SMethod_TextDocumentCodeAction quickCodeActionHandlers
+  in (defaultPluginDescriptor plId "Code actions for module export lists")
+    { Ide.pluginHandlers = exportHandlers
+    }
+
+quickCodeActionHandlers :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
+quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do
+  let uri = doc ^. L.uri
+  nfp <- getNormalizedFilePathE uri
+  pm <- runActionE "Export.GetParsedModuleWithComments" state (useE GetParsedModuleWithComments nfp)
+  let ps = pm_parsed_source pm
+  case (isExplicit ps, locateUnderCursor (range ^. L.start) ps) of
+    (True, Just under) -> do
+      -- The names GHC flags as defined-but-unused. Attach the action to the
+      -- unused diagnostics as well.
+      unusedDiags <- liftIO $ unusedTopBindDiagnostics state nfp
+      pure . InL . map InR $
+        [ ca
+        | Just (verb, title, edits) <-
+            [ addAction under ps
+            ]
+        , let fixes = [ d | d <- unusedDiags, locateUnderCursor (d ^. L.range . L.start) ps == Just under ]
+              ca = mkAction (verb <> " `" <> title <> "`")
+                     & L.edit ?~ singleFileEdit uri edits
+                     & L.diagnostics .~ (if null fixes then Nothing else Just fixes)
+        ]
+    _ -> pure (InL [])
+
+-- | The LSP diagnostics for names GHC reports as unused top-level definitions.
+unusedTopBindDiagnostics :: IdeState -> NormalizedFilePath -> IO [Diagnostic]
+unusedTopBindDiagnostics state nfp = do
+  diags <- atomically $ getDiagnostics state
+  pure [ fdLspDiagnostic d | d <- diags, fdFilePath d == nfp, isUnusedTopBind d ]
+  where
+    isUnusedTopBind =
+      has (fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnUnusedTopBind)
+
+addAction :: UnderCursor -> ParsedSource -> Maybe (Text, Text, [TextEdit])
+addAction under ps = case under of
+  Decl flavor n
+    | n `isExported` ps -> Nothing
+    | otherwise -> ("Export", T.pack (printRdrName n),) <$> addExport ps (mkExportIE flavor n)
+  Constructor t c
+    | c `isExported` ps -> Nothing
+    | otherwise ->
+        ("Export", T.pack (printRdrName t) <> "(" <> T.pack (printRdrName c) <> ")",)
+          <$> addConstructorExport t c ps
+  Header -> Nothing