diff --git a/hls-module-name-plugin.cabal b/hls-module-name-plugin.cabal --- a/hls-module-name-plugin.cabal +++ b/hls-module-name-plugin.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/ModuleName.hs b/src/Ide/Plugin/ModuleName.hs --- a/src/Ide/Plugin/ModuleName.hs +++ b/src/Ide/Plugin/ModuleName.hs @@ -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] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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"