hls-module-name-plugin 2.0.0.1 → 2.1.0.0
raw patch · 3 files changed
+47/−46 lines, 3 filesdep +containersdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependencies added: containers
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
Files
- hls-module-name-plugin.cabal +5/−4
- src/Ide/Plugin/ModuleName.hs +37/−37
- test/Main.hs +5/−5
hls-module-name-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-module-name-plugin-version: 2.0.0.1+version: 2.1.0.0 synopsis: Module name plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -30,10 +30,11 @@ build-depends: , aeson , base >=4.12 && <5+ , containers , directory , filepath- , ghcide == 2.0.0.1- , hls-plugin-api == 2.0.0.1+ , ghcide == 2.1.0.0+ , hls-plugin-api == 2.1.0.0 , lsp , text , transformers@@ -52,4 +53,4 @@ , base , filepath , hls-module-name-plugin- , hls-test-utils == 2.0.0.1+ , hls-test-utils == 2.1.0.0
src/Ide/Plugin/ModuleName.hs view
@@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}+ {-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -20,14 +22,14 @@ import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe-import Data.Aeson (Value (Null), toJSON)+import Data.Aeson (toJSON) import Data.Char (isLower)-import qualified Data.HashMap.Strict as HashMap import Data.List (intercalate, isPrefixOf, minimumBy) import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromMaybe, maybeToList)+import qualified Data.Map as Map import Data.Ord (comparing) import Data.String (IsString) import qualified Data.Text as T@@ -40,10 +42,9 @@ hscEnvWithImportPaths, logWith, realSrcSpanToRange,- runAction,- uriToFilePath',- useWithStale,- useWithStale_, (<+>))+ runAction, useWithStale,+ (<+>))+import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags,@@ -51,13 +52,12 @@ locA, moduleNameString, pattern RealSrcSpan, pm_parsed_source, unLoc)-import Development.IDE.Types.Logger (Pretty (..))+import Ide.Logger (Pretty (..))+import Ide.Plugin.Error import Ide.Types+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types import Language.LSP.Server-import Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start)) import Language.LSP.VFS (virtualFileText) import System.Directory (makeAbsolute) import System.FilePath (dropExtension, normalise,@@ -69,7 +69,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId)- { pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder)+ { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (codeLens recorder) , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)] } @@ -77,9 +77,10 @@ updateModuleNameCommand = "updateModuleName" -- | Generate code lenses-codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'TextDocumentCodeLens-codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} =- Right . List . maybeToList . (asCodeLens <$>) <$> action recorder state uri+codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens+codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do+ res <- action recorder state uri+ pure $ InL (asCodeLens <$> res) where asCodeLens :: Action -> CodeLens asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing@@ -93,10 +94,10 @@ forM_ actMaybe $ \Replace{..} -> let -- | Convert an Action to the corresponding edit operation- edit = WorkspaceEdit (Just . HashMap.singleton aUri $ List [TextEdit aRange aCode]) Nothing Nothing+ edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing in- void $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ()))- pure $ Right Null+ void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ()))+ pure $ InR Null -- | A source code change data Action = Replace@@ -108,41 +109,40 @@ deriving (Show) -- | Required action (that can be converted to either CodeLenses or CodeActions)-action :: Recorder (WithPriority Log) -> IdeState -> Uri -> LspM c (Maybe Action)-action recorder state uri =- runMaybeT $ do- nfp <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri- fp <- MaybeT . pure $ uriToFilePath' uri+action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]+action recorder state uri = do+ nfp <- getNormalizedFilePathE uri+ fp <- uriToFilePathE uri contents <- lift . getVirtualFile $ toNormalizedUri uri let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents - correctNames <- liftIO $ pathModuleNames recorder state nfp fp+ correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp logWith recorder Debug (CorrectNames correctNames)- bestName <- minimumBy (comparing T.length) <$> (MaybeT . pure $ NE.nonEmpty correctNames)+ let bestName = minimumBy (comparing T.length) <$> NE.nonEmpty correctNames logWith recorder Debug (BestName bestName) statedNameMaybe <- liftIO $ codeModuleName state nfp logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe)- case statedNameMaybe of- Just (nameRange, statedName)+ case (bestName, statedNameMaybe) of+ (Just bestName, Just (nameRange, statedName)) | statedName `notElem` correctNames ->- pure $ Replace uri nameRange ("Set module name to " <> bestName) bestName- Nothing+ pure [Replace uri nameRange ("Set module name to " <> bestName) bestName]+ (Just bestName, Nothing) | emptyModule -> let code = "module " <> bestName <> " where\n"- in pure $ Replace uri (Range (Position 0 0) (Position 0 0)) code code- _ -> MaybeT $ pure Nothing+ in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code]+ _ -> pure $ [] -- | Possible module names, as derived by the position of the module in the -- source directories. There may be more than one possible name, if the source -- directories are nested inside each other.-pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> IO [T.Text]+pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text] pathModuleNames recorder state normFilePath filePath | isLower . head $ takeFileName filePath = return ["Main"] | otherwise = do- session <- fst <$> (runAction "ModuleName.ghcSession" state $ useWithStale_ GhcSession normFilePath)- srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags+ (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath+ srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags logWith recorder Debug (SrcPaths srcPaths) -- Append a `pathSeparator` to make the path looks like a directory,@@ -151,7 +151,7 @@ let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- makeAbsolute filePath+ mdlPath <- liftIO $ makeAbsolute filePath logWith recorder Debug (AbsoluteFilePath mdlPath) let prefixes = filter (`isPrefixOf` mdlPath) paths@@ -174,7 +174,7 @@ data Log = CorrectNames [T.Text]- | BestName T.Text+ | BestName (Maybe T.Text) | ModuleName (Maybe T.Text) | SrcPaths [FilePath] | NormalisedPaths [FilePath]
test/Main.hs view
@@ -21,22 +21,22 @@ [ goldenWithModuleName "Add module header to empty module" "TEmptyModule" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c- void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)+ void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , goldenWithModuleName "Fix wrong module name" "TWrongModuleName" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c- void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)+ void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , goldenWithModuleName "Must infer module name as Main, if the file name starts with a lowercase" "mainlike" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c- void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)+ void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , goldenWithModuleName "Fix wrong module name in nested directory" "subdir/TWrongModuleName" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c- void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)+ void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , testCase "Should not show code lens if the module name is correct" $ runSessionWithServer moduleNamePlugin testDataDir $ do doc <- openDoc "CorrectName.hs" "haskell"@@ -47,7 +47,7 @@ , goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c- void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)+ void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , testCase "Keep stale lens even if parse failed" $ do runSessionWithServer moduleNamePlugin testDataDir $ do doc <- openDoc "Stale.hs" "haskell"