|
| 1 | +{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports #-} |
| 2 | +{-# LANGUAGE NamedFieldPuns #-} |
| 3 | +{-# LANGUAGE NoMonomorphismRestriction #-} |
| 4 | +{-# LANGUAGE OverloadedStrings #-} |
| 5 | +{-# LANGUAGE RecordWildCards #-} |
| 6 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 7 | + |
| 8 | +-- |Keep the module name in sync with its file path. |
| 9 | +module Ide.Plugin.ModuleName |
| 10 | + |
| 11 | + ( descriptor |
| 12 | + ) |
| 13 | +where |
| 14 | + |
| 15 | +import Control.Monad (join) |
| 16 | +import Control.Monad.IO.Class (MonadIO (liftIO)) |
| 17 | +import Control.Monad.Trans.Maybe () |
| 18 | +import Data.Aeson (ToJSON (toJSON), Value (Null)) |
| 19 | +import qualified Data.HashMap.Strict as Map |
| 20 | +import Data.List (isPrefixOf) |
| 21 | +import Data.List.Extra (replace) |
| 22 | +import Data.Maybe (listToMaybe) |
| 23 | +import Data.String (IsString) |
| 24 | +import Data.Text (Text) |
| 25 | +import qualified Data.Text as T |
| 26 | +import Development.IDE (GetParsedModule (GetParsedModule), |
| 27 | + GhcSession (GhcSession), |
| 28 | + HscEnvEq (hscEnv), IdeState, |
| 29 | + List (..), NormalizedFilePath, |
| 30 | + Position (Position), Range (Range), |
| 31 | + evalGhcEnv, realSrcSpanToRange, |
| 32 | + runAction, toNormalizedUri, |
| 33 | + uriToFilePath', use, use_) |
| 34 | +import Development.IDE.Plugin (getPid) |
| 35 | +import GHC (DynFlags (importPaths), |
| 36 | + GenLocated (L), |
| 37 | + GhcMonad (getSession), |
| 38 | + HsModule (hsmodName), |
| 39 | + ParsedModule (pm_parsed_source), |
| 40 | + SrcSpan (RealSrcSpan), unLoc) |
| 41 | +import GhcPlugins (HscEnv (hsc_IC), |
| 42 | + InteractiveContext (ic_dflags)) |
| 43 | +import Ide.Types (CommandFunction, CommandId (..), |
| 44 | + PluginCommand (..), |
| 45 | + PluginDescriptor (..), |
| 46 | + PluginId (..), |
| 47 | + defaultPluginDescriptor) |
| 48 | +import Language.Haskell.LSP.Core (LspFuncs, getVirtualFileFunc) |
| 49 | +import Language.Haskell.LSP.Types (ApplyWorkspaceEditParams (..), |
| 50 | + CAResult (CACodeAction), |
| 51 | + CodeAction (CodeAction), |
| 52 | + CodeActionKind (CodeActionQuickFix), |
| 53 | + CodeLens (CodeLens), |
| 54 | + CodeLensParams (CodeLensParams), |
| 55 | + Command (Command), |
| 56 | + ServerMethod (..), |
| 57 | + TextDocumentIdentifier (TextDocumentIdentifier), |
| 58 | + TextEdit (TextEdit), Uri, |
| 59 | + WorkspaceEdit (..), |
| 60 | + uriToNormalizedFilePath) |
| 61 | +import Language.Haskell.LSP.VFS (virtualFileText) |
| 62 | +import System.FilePath (dropExtension) |
| 63 | + |
| 64 | +-- |Plugin descriptor |
| 65 | +descriptor :: PluginId -> PluginDescriptor |
| 66 | +descriptor plId = |
| 67 | + (defaultPluginDescriptor plId) |
| 68 | + { pluginId = plId, |
| 69 | + pluginCodeLensProvider = Just codeLens |
| 70 | + ,pluginCommands = [PluginCommand editCommandName editCommandName editCmd] |
| 71 | + -- pluginCodeActionProvider = Just codeAction |
| 72 | + } |
| 73 | + |
| 74 | +-- | Generate code lenses |
| 75 | +codeLens :: LspFuncs c -> IdeState -> PluginId -> CodeLensParams -> IO (Either a2 (List CodeLens)) |
| 76 | +codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = do |
| 77 | + pid <- getPid |
| 78 | + actions (asCodeLens (mkLspCmdId pid pluginId editCommandName)) lsp state uri |
| 79 | + |
| 80 | +-- | Generate code actions. |
| 81 | +-- NOTE: Not invoked on an empty module (but codeLens is, why?) |
| 82 | +codeAction :: LspFuncs c -> IdeState -> p1 -> TextDocumentIdentifier -> p2 -> p3 -> IO (Either a (List CAResult)) |
| 83 | +codeAction lsp state _plId (TextDocumentIdentifier uri) _range _ = actions asCodeAction lsp state uri |
| 84 | + |
| 85 | +-- Copied from "Ide.Plugin" |
| 86 | +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text |
| 87 | +mkLspCmdId pid (PluginId plid) (CommandId cid) |
| 88 | + = pid <> ":" <> plid <> ":" <> cid |
| 89 | + |
| 90 | +editCommandName :: IsString p => p |
| 91 | +editCommandName = "edit" |
| 92 | + |
| 93 | +-- | Generic command to apply a group of edits |
| 94 | +editCmd :: CommandFunction WorkspaceEdit |
| 95 | +editCmd _lf _ide workspaceEdits = return (Right Null, Just $ (WorkspaceApplyEdit,ApplyWorkspaceEditParams workspaceEdits)) |
| 96 | + |
| 97 | +-- | Required actions (actually, at most one) that can be converted to either CodeLenses or CodeActions |
| 98 | +actions :: Show a1 => (Action -> a1) -> LspFuncs c -> IdeState -> Uri -> IO (Either a2 (List a1)) |
| 99 | +actions convert lsp state uri = do |
| 100 | + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri |
| 101 | + let Just fp = uriToFilePath' uri |
| 102 | + |
| 103 | + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri |
| 104 | + let emptyModule = maybe True ((==0) . T.length . T.strip . virtualFileText) contents |
| 105 | + |
| 106 | + correctNameMaybe <- pathModuleName state nfp fp |
| 107 | + statedNameMaybe <- codeModuleName state nfp |
| 108 | + |
| 109 | + let act = Action uri |
| 110 | + let actions = case (correctNameMaybe,statedNameMaybe) of |
| 111 | + (Just correctName,Just (nameRange,statedName)) | correctName /= statedName -> [convert $ act nameRange ("Set module name to " <> correctName) correctName] |
| 112 | + (Just correctName,_) | emptyModule -> let code = T.unwords ["module",correctName,"where\n"] in [convert $ act (Range (Position 0 0) (Position 0 0)) code code] |
| 113 | + _ -> [] |
| 114 | + |
| 115 | + out ["actions",show actions] |
| 116 | + pure . Right . List $ actions |
| 117 | + |
| 118 | +-- | The module name, as derived by the position of the module in its source directory |
| 119 | +pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text) |
| 120 | +pathModuleName state nfp fp = do |
| 121 | + session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession nfp |
| 122 | + paths <- evalGhcEnv (hscEnv session) $ do |
| 123 | + env <- getSession |
| 124 | + let df = ic_dflags . hsc_IC $ env |
| 125 | + return $ importPaths df |
| 126 | + out ["import paths",show paths] |
| 127 | + let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths |
| 128 | + out ["prefix",show maybePrefix] |
| 129 | + let maybeMdlName = (\prefix -> replace "/" "." . drop (length prefix+1) $ dropExtension fp) <$> maybePrefix |
| 130 | + out ["mdlName",show maybeMdlName] |
| 131 | + return $ T.pack <$> maybeMdlName |
| 132 | + |
| 133 | +-- | The module name, as stated in the module |
| 134 | +codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text)) |
| 135 | +codeModuleName state nfp = ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l,T.pack . show $ m)) <$>) . join . (hsmodName . unLoc . pm_parsed_source <$>) <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp) |
| 136 | + |
| 137 | +-- | A source code change |
| 138 | +data Action = Action {aUri::Uri,aRange::Range,aTitle::Text,aCode::Text} deriving Show |
| 139 | + |
| 140 | +-- | Convert an Action to a CodeLens |
| 141 | +asCodeLens :: Text -> Action -> CodeLens |
| 142 | +asCodeLens cid act@Action{..} = CodeLens aRange (Just $ Command aTitle cid (Just (List [toJSON $ asEdit act]))) Nothing |
| 143 | + |
| 144 | +-- | Convert an Action to a CodeAction |
| 145 | +asCodeAction :: Action -> CAResult |
| 146 | +asCodeAction act@Action{..} = CACodeAction $ CodeAction aTitle (Just CodeActionQuickFix) (Just $ List []) (Just $ asEdit act) Nothing |
| 147 | +-- -- [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] |
| 148 | + |
| 149 | +asEdit :: Action -> WorkspaceEdit |
| 150 | +asEdit act@Action{..} = WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act) ) Nothing |
| 151 | + |
| 152 | +asTextEdits :: Action -> [TextEdit] |
| 153 | +asTextEdits Action{..} = [TextEdit aRange aCode] |
| 154 | + |
| 155 | +out :: [String] -> IO () |
| 156 | +out = print . unwords . ("Plugin ModuleName " :) |
| 157 | +-- out _ = return () |
0 commit comments