diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ab57fa79ea..3069d9200f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -687,6 +687,43 @@ test-suite hls-retrie-plugin-tests , hls-test-utils == 2.11.0.0 , text +----------------------------- +-- underlying-type plugin +----------------------------- + +flag underlyingType + description: Enable underlying-type plugin + default: True + manual: True + +common underlying-type + if flag(underlyingType) || flag(ignore-plugins-ghc-bounds) + build-depends: haskell-language-server:hls-underlying-type-plugin + cpp-options: -Dhls_underlyingType + +library hls-underlying-type-plugin + import: defaults, pedantic, warnings + if !(flag(underlyingType) || flag(ignore-plugins-ghc-bounds)) + buildable: True + exposed-modules: Ide.Plugin.UnderlyingType + hs-source-dirs: plugins/hls-underlying-type-plugin/src + build-depends: + , directory + , filepath + , ghcide == 2.11.0.0 + , hls-plugin-api == 2.11.0.0 + , lens + , lsp-types + , mtl + , process-extras + , text + , containers + , ghc + , aeson + + default-extensions: + DataKinds + ----------------------------- -- hlint plugin ----------------------------- @@ -1870,6 +1907,7 @@ library , overloadedRecordDot , semanticTokens , notes + , underlying-type exposed-modules: Ide.Arguments diff --git a/plugins/hls-underlying-type-plugin/src/Ide/Plugin/UnderlyingType.hs b/plugins/hls-underlying-type-plugin/src/Ide/Plugin/UnderlyingType.hs new file mode 100644 index 0000000000..c46bd7fd00 --- /dev/null +++ b/plugins/hls-underlying-type-plugin/src/Ide/Plugin/UnderlyingType.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.UnderlyingType where + +import Control.Lens ((^.)) +import Control.Monad (forM) +import Control.Monad.IO.Class +import Control.Monad.RWS (lift) +import qualified Data.Aeson as Aeson +import Data.Either (rights) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Shake (getShakeExtras) +import Development.IDE.GHC.Compat.Core (Name) +import Development.IDE.Spans.AtPoint (pointCommand) +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils (nodeInfo) +import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction), + SMethod (SMethod_TextDocumentCodeAction)) +import Language.LSP.Protocol.Types + +data Log + = LogPluginCalled Uri Range + | LogIdentifiersFound Position [Name] + | LogTypeLocationsFound [(Location, Identifier)] + | LogProcessingLocation Location Identifier + | LogActionCreated Name Name + +instance Pretty Log where + pretty = \case + LogPluginCalled uri range -> + "Plugin called for" <+> pretty (show uri) <+> "at range" <+> pretty (show range) + LogIdentifiersFound pos identifiers -> + "Found" <+> pretty (length identifiers) <+> "identifiers at" <+> pretty (show pos) <> ":" <+> + pretty (T.intercalate ", " (map printOutputable identifiers)) + LogTypeLocationsFound locations -> + "Found" <+> pretty (length locations) <+> "type locations" + LogProcessingLocation loc identifier -> + "Processing location" <+> pretty (show loc) <+> "for" <+> pretty (printOutputable identifier) + LogActionCreated varName typeName -> + "Created action for" <+> pretty (printOutputable varName) <+> "->" <+> pretty (printOutputable typeName) + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId "Generates actions for going to the underlying type's definition.") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (provider recorder) + } + +provider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +provider recorder state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do + logWith recorder Debug $ LogPluginCalled uri range + + nfp <- getNormalizedFilePathE uri + + (HAR _ hieAst _ _ hieKind, posMapping) <- + runActionE "GetHieAst" state $ + useWithStaleE GetHieAst nfp + + let position = fromMaybe (range ^. L.start) $ fromCurrentPosition posMapping (range ^. L.start) + namesAtPosition = mconcat $ pointCommand hieAst position (extractNamesAtPosition hieKind) + + logWith recorder Debug $ LogIdentifiersFound position namesAtPosition + + actions <- case namesAtPosition of + [] -> pure [] + identifiers -> do + typeActions <- forM identifiers $ \bindingName -> do + locationForIdentifierType <- runActionE "TypeCheck" state $ do + shakeExtras <- lift getShakeExtras + result <- liftIO $ runIdeAction "Get Type Definition" shakeExtras $ getTypeDefinition nfp position + pure $ fromMaybe [] result + + logWith recorder Debug $ LogTypeLocationsFound locationForIdentifierType + + typeDefActions <- forM locationForIdentifierType $ \(loc, identifier) -> do + logWith recorder Debug $ LogProcessingLocation loc identifier + + case identifier of + Left _moduleName -> pure Nothing + Right underlyingTypeName -> do + logWith recorder Debug $ LogActionCreated bindingName underlyingTypeName + pure $ Just $ createGoToTypeDefAction bindingName underlyingTypeName loc + + pure $ catMaybes typeDefActions + + pure $ mconcat typeActions + + pure $ InL actions + +extractNamesAtPosition :: HieKind a -> HieAST a -> [Name] +extractNamesAtPosition hieKind ast = + case hieKind of + HieFresh -> rights $ map fst $ M.toList $ nodeIdentifiers $ nodeInfo ast + HieFromDisk {} -> [] + +createGoToTypeDefAction :: Name -> Name -> Location -> (Command |? CodeAction) +createGoToTypeDefAction boundVarName underlyingTypeName loc = do + let defRange = loc ^. L.range + InR $ + CodeAction + ("Go to definition of " <> printOutputable underlyingTypeName <> " (inferred from " <> printOutputable boundVarName <> "'s type)") + (Just $ CodeActionKind_Custom "GoToUnderlyingTypeDefinition") + Nothing + Nothing + Nothing + Nothing + ( Just $ + Command + "Go to definition" + -- TODO: How to decouple this from VS code? + "vscode.open" + ( Just + [ Aeson.toJSON $ loc ^. L.uri, + Aeson.object + [ "selection" + Aeson..= Aeson.object + [ "start" + Aeson..= Aeson.object + [ "line" Aeson..= (defRange ^. L.start . L.line), + "character" Aeson..= (defRange ^. L.start . L.character) + ], + "end" + Aeson..= Aeson.object + [ "line" Aeson..= (defRange ^. L.end . L.line), + "character" Aeson..= (defRange ^. L.end . L.character) + ] + ] + ] + ] + ) + ) + Nothing diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 4c135fc48b..45dced8774 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -45,6 +45,10 @@ import qualified Ide.Plugin.Rename as Rename import qualified Ide.Plugin.Retrie as Retrie #endif +#if hls_underlyingType +import qualified Ide.Plugin.UnderlyingType as UnderlyingType +#endif + #if hls_hlint import qualified Ide.Plugin.Hlint as Hlint #endif @@ -187,6 +191,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if hls_retrie let pId = "retrie" in Retrie.descriptor (pluginRecorder pId) pId : #endif +#if hls_underlyingType + let pId = "underlying-type" in UnderlyingType.descriptor (pluginRecorder pId) pId : +#endif #if hls_callHierarchy CallHierarchy.descriptor "callHierarchy" : #endif