|
| 1 | +{-# LANGUAGE ViewPatterns #-} |
| 2 | +{-# LANGUAGE DeriveAnyClass #-} |
| 3 | +{-# LANGUAGE DeriveGeneric #-} |
| 4 | +{-# LANGUAGE DerivingStrategies #-} |
| 5 | +{-# LANGUAGE DuplicateRecordFields #-} |
| 6 | +{-# LANGUAGE LambdaCase #-} |
| 7 | +{-# LANGUAGE NamedFieldPuns #-} |
| 8 | +{-# LANGUAGE OverloadedStrings #-} |
| 9 | +{-# LANGUAGE RecordWildCards #-} |
| 10 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 11 | +module Ide.Plugin.ImportLens (descriptor) where |
| 12 | +import Control.Monad (forM) |
| 13 | +import Data.Aeson (ToJSON) |
| 14 | +import Data.Aeson (Value (Null)) |
| 15 | +import Data.Aeson (ToJSON (toJSON)) |
| 16 | +import Data.Aeson.Types (FromJSON) |
| 17 | +import qualified Data.HashMap.Strict as HashMap |
| 18 | +import Data.IORef (readIORef) |
| 19 | +import Data.Map (Map) |
| 20 | +import qualified Data.Map.Strict as Map |
| 21 | +import Data.Maybe (catMaybes, fromMaybe) |
| 22 | +import qualified Data.Text as T |
| 23 | +import Development.IDE.Core.RuleTypes (GhcSessionDeps (GhcSessionDeps), |
| 24 | + TcModuleResult (tmrModule), |
| 25 | + TypeCheck (TypeCheck)) |
| 26 | +import Development.IDE.Core.Shake (use, IdeState (..)) |
| 27 | +import Development.IDE.GHC.Compat |
| 28 | +import Development.IDE.GHC.Error (realSpan, realSrcSpanToRange) |
| 29 | +import Development.IDE.GHC.Util (HscEnvEq, hscEnv, prettyPrint) |
| 30 | +import GHC.Generics (Generic) |
| 31 | +import Ide.Plugin |
| 32 | +import Ide.Types |
| 33 | +import Language.Haskell.LSP.Types |
| 34 | +import PrelNames (pRELUDE) |
| 35 | +import RnNames (findImportUsage, |
| 36 | + getMinimalImports) |
| 37 | +import TcRnMonad (initTcWithGbl) |
| 38 | +import TcRnTypes (TcGblEnv (tcg_used_gres)) |
| 39 | +import Development.IDE.Core.Service (runAction) |
| 40 | +import Development.Shake (Action) |
| 41 | + |
| 42 | +importCommandId :: CommandId |
| 43 | +importCommandId = "ImportLensCommand" |
| 44 | + |
| 45 | +-- | The "main" function of a plugin |
| 46 | +descriptor :: PluginId -> PluginDescriptor |
| 47 | +descriptor plId = (defaultPluginDescriptor plId) { |
| 48 | + -- This plugin provides code lenses |
| 49 | + pluginCodeLensProvider = Just provider, |
| 50 | + -- This plugin provides a command handler |
| 51 | + pluginCommands = [ importLensCommand ] |
| 52 | +} |
| 53 | + |
| 54 | +-- | The command descriptor |
| 55 | +importLensCommand :: PluginCommand |
| 56 | +importLensCommand = |
| 57 | + PluginCommand importCommandId "Explicit import command" runImportCommand |
| 58 | + |
| 59 | +-- | The type of the parameters accepted by our command |
| 60 | +data ImportCommandParams = ImportCommandParams WorkspaceEdit |
| 61 | + deriving Generic |
| 62 | + deriving anyclass (FromJSON, ToJSON) |
| 63 | + |
| 64 | +-- | The actual command handler |
| 65 | +runImportCommand :: CommandFunction ImportCommandParams |
| 66 | +runImportCommand _lspFuncs _state (ImportCommandParams edit) = do |
| 67 | + -- This command simply triggers a workspace edit! |
| 68 | + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edit)) |
| 69 | + |
| 70 | +-- | For every implicit import statement, return a code lens of the corresponding explicit import |
| 71 | +-- Example - for the module below: |
| 72 | +-- |
| 73 | +-- > import Data.List |
| 74 | +-- > |
| 75 | +-- > f = intercalate " " . sortBy length |
| 76 | +-- |
| 77 | +-- the provider should produce one code lens associated to the import statement: |
| 78 | +-- |
| 79 | +-- > import Data.List (intercalate, sortBy) |
| 80 | +provider :: CodeLensProvider |
| 81 | +provider _lspFuncs -- LSP functions, not used |
| 82 | + state -- ghcide state, used to retrieve typechecking artifacts |
| 83 | + pId -- plugin Id |
| 84 | + CodeLensParams{_textDocument = TextDocumentIdentifier{_uri}} |
| 85 | + -- VSCode uses URIs instead of file paths |
| 86 | + -- haskell-lsp provides conversion functions |
| 87 | + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri |
| 88 | + = do |
| 89 | + -- Get the typechecking artifacts from the module |
| 90 | + tmr <- runIde state $ use TypeCheck nfp |
| 91 | + -- We also need a GHC session with all the dependencies |
| 92 | + hsc <- runIde state $ use GhcSessionDeps nfp |
| 93 | + -- Use the GHC api to extract the "minimal" imports |
| 94 | + (imports, mbMinImports) <- extractMinimalImports hsc tmr |
| 95 | + |
| 96 | + case mbMinImports of |
| 97 | + -- Implement the provider logic: |
| 98 | + -- for every import, if it's lacking a explicit list, generate a code lens |
| 99 | + Just minImports -> do |
| 100 | + let minImportsMap = |
| 101 | + Map.fromList [ (srcSpanStart l, i) | L l i <- minImports ] |
| 102 | + commands <- forM imports $ generateLens pId _uri minImportsMap |
| 103 | + return $ Right (List $ catMaybes commands) |
| 104 | + _ -> |
| 105 | + return $ Right (List []) |
| 106 | + |
| 107 | + | otherwise |
| 108 | + = return $ Right (List []) |
| 109 | + |
| 110 | +-- | Use the ghc api to extract a minimal, explicit set of imports for this module |
| 111 | +extractMinimalImports |
| 112 | + :: Maybe (HscEnvEq) |
| 113 | + -> Maybe (TcModuleResult) |
| 114 | + -> IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn]) |
| 115 | +extractMinimalImports (Just (hsc)) (Just (tmrModule -> TypecheckedModule{..})) = do |
| 116 | + -- extract the original imports and the typechecking environment |
| 117 | + let (tcEnv,_) = tm_internals_ |
| 118 | + Just (_, imports, _, _) = tm_renamed_source |
| 119 | + ParsedModule{ pm_parsed_source = L loc _} = tm_parsed_module |
| 120 | + span = fromMaybe (error "expected real") $ realSpan loc |
| 121 | + |
| 122 | + -- GHC is secretly full of mutable state |
| 123 | + gblElts <- readIORef (tcg_used_gres tcEnv) |
| 124 | + |
| 125 | + -- call findImportUsage does exactly what we need |
| 126 | + -- GHC is full of treats like this |
| 127 | + let usage = findImportUsage imports gblElts |
| 128 | + (_, minimalImports) <- initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage |
| 129 | + |
| 130 | + -- return both the original imports and the computed minimal ones |
| 131 | + return (imports, minimalImports) |
| 132 | + |
| 133 | +extractMinimalImports _ _ = return ([], Nothing) |
| 134 | + |
| 135 | +-- | Given an import declaration, generate a code lens unless it has an explicit import list |
| 136 | +generateLens :: PluginId -> Uri -> Map SrcLoc (ImportDecl GhcRn) -> LImportDecl GhcRn -> IO (Maybe CodeLens) |
| 137 | +generateLens pId uri minImports (L src imp) |
| 138 | + -- Explicit import list case |
| 139 | + | ImportDecl{ideclHiding = Just (False,_)} <- imp |
| 140 | + = return Nothing |
| 141 | + -- No explicit import list |
| 142 | + | RealSrcSpan l <- src |
| 143 | + , Just explicit <- Map.lookup (srcSpanStart src) minImports |
| 144 | + , L _ mn <- ideclName imp |
| 145 | + -- (almost) no one wants to see an explicit import list for Prelude |
| 146 | + , mn /= moduleName pRELUDE |
| 147 | + = do |
| 148 | + -- The title of the command is just the minimal explicit import decl |
| 149 | + let title = T.pack $ prettyPrint explicit |
| 150 | + -- the range of the code lens is the span of the original import decl |
| 151 | + _range :: Range = realSrcSpanToRange l |
| 152 | + -- the code lens has no extra data |
| 153 | + _xdata = Nothing |
| 154 | + -- an edit that replaces the whole declaration with the explicit one |
| 155 | + edit = WorkspaceEdit (Just editsMap) Nothing |
| 156 | + editsMap = HashMap.fromList [(uri, List [importEdit])] |
| 157 | + importEdit = TextEdit _range title |
| 158 | + -- the command argument is simply the edit |
| 159 | + _arguments = Just [toJSON $ ImportCommandParams edit] |
| 160 | + -- create the command |
| 161 | + _command <- Just <$> mkLspCommand pId importCommandId title _arguments |
| 162 | + -- create and return the code lens |
| 163 | + return $ Just CodeLens{..} |
| 164 | + | otherwise |
| 165 | + = return Nothing |
| 166 | + |
| 167 | +-- | A helper to run ide actions |
| 168 | +runIde :: IdeState -> Action a -> IO a |
| 169 | +runIde state = runAction "importLens" state |
0 commit comments