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: 1.0.2.0 +version: 1.1.0.0 synopsis: Module name plugin for Haskell Language Server description: Please see the README on GitHub at @@ -16,8 +16,11 @@ LICENSE test/testdata/**/*.yaml test/testdata/**/*.hs + test/testdata/**/*.cabal + test/testdata/**/*.project library + buildable: True exposed-modules: Ide.Plugin.ModuleName hs-source-dirs: src build-depends: @@ -25,8 +28,8 @@ , base >=4.12 && <5 , directory , filepath - , ghcide ^>=1.7 - , hls-plugin-api ^>=1.4 + , ghcide ^>=1.8 + , hls-plugin-api ^>=1.5 , lsp , text , transformers @@ -35,6 +38,7 @@ default-language: Haskell2010 test-suite tests + buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -44,4 +48,4 @@ , base , filepath , hls-module-name-plugin - , hls-test-utils ^>=1.3 + , hls-test-utils ^>=1.4 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 @@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {- | Keep the module name in sync with its file path. @@ -15,54 +16,62 @@ descriptor, ) where -import Control.Monad (forM_, void) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe -import Data.Aeson (Value (Null), 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 (maybeToList) -import Data.Ord (comparing) -import Data.String (IsString) -import qualified Data.Text as T -import Development.IDE (GetParsedModule (GetParsedModule), - GhcSession (GhcSession), IdeState, - evalGhcEnv, hscEnvWithImportPaths, - realSrcSpanToRange, runAction, - uriToFilePath', use, use_) -import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags, - hsmodName, importPaths, locA, - pattern RealSrcSpan, - pm_parsed_source, unLoc, moduleNameString) +import Data.Aeson (Value (Null), 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 (maybeToList) +import Data.Ord (comparing) +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + GhcSession (GhcSession), + IdeState, Pretty, + Priority (Debug, Info), Recorder, + WithPriority, colon, evalGhcEnv, + hscEnvWithImportPaths, logWith, + realSrcSpanToRange, runAction, + uriToFilePath', use, use_, (<+>)) +import Development.IDE.GHC.Compat (GenLocated (L), + getSessionDynFlags, hsmodName, + importPaths, locA, + moduleNameString, + pattern RealSrcSpan, + pm_parsed_source, unLoc) +import Development.IDE.Types.Logger (Pretty (..)) import Ide.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, splitDirectories, - takeFileName) +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, + pathSeparator, splitDirectories, + takeFileName) -- |Plugin descriptor -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLens - , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" command] + { pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder) + , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)] } updateModuleNameCommand :: IsString p => p updateModuleNameCommand = "updateModuleName" -- | Generate code lenses -codeLens :: PluginMethodHandler IdeState 'TextDocumentCodeLens -codeLens state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = - Right . List . maybeToList . (asCodeLens <$>) <$> action state uri +codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'TextDocumentCodeLens +codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = + Right . List . maybeToList . (asCodeLens <$>) <$> action recorder state uri where asCodeLens :: Action -> CodeLens asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing @@ -70,9 +79,9 @@ cmd = mkLspCommand pluginId updateModuleNameCommand aTitle (Just [toJSON aUri]) -- | (Quasi) Idempotent command execution: recalculate action to execute on command request -command :: CommandFunction IdeState Uri -command state uri = do - actMaybe <- action state uri +command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri +command recorder state uri = do + actMaybe <- action recorder state uri forM_ actMaybe $ \Replace{..} -> let -- | Convert an Action to the corresponding edit operation @@ -91,19 +100,22 @@ deriving (Show) -- | Required action (that can be converted to either CodeLenses or CodeActions) -action :: IdeState -> Uri -> LspM c (Maybe Action) -action state uri = - traceAs "action" <$> runMaybeT $ do +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 contents <- lift . getVirtualFile $ toNormalizedUri uri let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents - correctNames <- liftIO $ traceAs "correctNames" <$> pathModuleNames state nfp fp + correctNames <- liftIO $ pathModuleNames recorder state nfp fp + logWith recorder Debug (CorrectNames correctNames) bestName <- minimumBy (comparing T.length) <$> (MaybeT . pure $ NE.nonEmpty correctNames) + logWith recorder Info (BestName bestName) - statedNameMaybe <- liftIO $ traceAs "statedName" <$> codeModuleName state nfp + statedNameMaybe <- liftIO $ codeModuleName state nfp + logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe) case statedNameMaybe of Just (nameRange, statedName) | statedName `notElem` correctNames -> @@ -117,14 +129,23 @@ -- | 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 :: IdeState -> NormalizedFilePath -> String -> IO [T.Text] -pathModuleNames state normFilePath filePath +pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> IO [T.Text] +pathModuleNames recorder state normFilePath filePath | isLower . head $ takeFileName filePath = return ["Main"] | otherwise = do session <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags - paths <- mapM makeAbsolute srcPaths + logWith recorder Debug (SrcPaths srcPaths) + + -- Append a `pathSeparator` to make the path looks like a directory, + -- and then we can drop it uniformly. + -- See https://github.com/haskell/haskell-language-server/pull/3092 for details. + let paths = map (normalise . (<> pure pathSeparator)) srcPaths + logWith recorder Debug (NormalisedPaths paths) + mdlPath <- makeAbsolute filePath + logWith recorder Debug (AbsoluteFilePath mdlPath) + let prefixes = filter (`isPrefixOf` mdlPath) paths pure (map (moduleNameFrom mdlPath) prefixes) where @@ -132,7 +153,7 @@ T.pack . intercalate "." . splitDirectories - . drop (length prefix + 1) + . drop (length prefix) $ dropExtension mdlPath -- | The module name, as stated in the module @@ -142,8 +163,20 @@ L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm pure (realSrcSpanToRange l, T.pack $ moduleNameString m) --- traceAs :: Show a => String -> a -> a --- traceAs lbl a = trace (lbl ++ " = " ++ show a) a +data Log = + CorrectNames [T.Text] + | BestName T.Text + | ModuleName (Maybe T.Text) + | SrcPaths [FilePath] + | NormalisedPaths [FilePath] + | AbsoluteFilePath FilePath + deriving Show -traceAs :: b -> a -> a -traceAs _ a = a +instance Pretty Log where + pretty log = "ModuleName." <> case log of + CorrectNames log -> "CorrectNames" <> colon <+> pretty log + BestName log -> "BestName" <> colon <+> pretty log + ModuleName log -> "StatedNameMaybe" <> colon <+> pretty log + SrcPaths log -> "SrcPaths" <> colon <+> pretty log + NormalisedPaths log -> "NormalisedPaths" <> colon <+> pretty log + AbsoluteFilePath log -> "AbsoluteFilePath" <> colon <+> pretty log diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -13,7 +13,7 @@ main = defaultTestRunner tests moduleNamePlugin :: PluginDescriptor IdeState -moduleNamePlugin = ModuleName.descriptor "moduleName" +moduleNamePlugin = ModuleName.descriptor mempty "moduleName" tests :: TestTree tests = @@ -39,10 +39,15 @@ void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) , testCase "Should not show code lens if the module name is correct" $ runSessionWithServer moduleNamePlugin testDataDir $ do - doc <- openDoc "CorrectName.hs" "haskell" - lenses <- getCodeLenses doc - liftIO $ lenses @?= [] - closeDoc doc + doc <- openDoc "CorrectName.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ lenses @?= [] + closeDoc doc + -- https://github.com/haskell/haskell-language-server/issues/3047 + , goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) ] goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree diff --git a/test/testdata/cabal.project b/test/testdata/cabal.project new file mode 100644 --- /dev/null +++ b/test/testdata/cabal.project @@ -0,0 +1,1 @@ +packages: ./canonicalize diff --git a/test/testdata/canonicalize/Lib/A.expected.hs b/test/testdata/canonicalize/Lib/A.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/canonicalize/Lib/A.expected.hs @@ -0,0 +1,1 @@ +module Lib.A where diff --git a/test/testdata/canonicalize/Lib/A.hs b/test/testdata/canonicalize/Lib/A.hs new file mode 100644 --- /dev/null +++ b/test/testdata/canonicalize/Lib/A.hs diff --git a/test/testdata/canonicalize/canonicalize.cabal b/test/testdata/canonicalize/canonicalize.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/canonicalize/canonicalize.cabal @@ -0,0 +1,7 @@ +cabal-version: 2.4 +name: canonicalize +version: 0.1.0.0 + +library + build-depends: base + hs-source-dirs: ./ diff --git a/test/testdata/hie.yaml b/test/testdata/hie.yaml --- a/test/testdata/hie.yaml +++ b/test/testdata/hie.yaml @@ -1,8 +1,17 @@ cradle: - direct: - arguments: - - "-isubdir" - - "TEmptyModule" - - "TWrongModuleName" - - "mainlike" - - "CorrectName" + multi: + - path: "./" + config: + cradle: + direct: + arguments: + - "-isubdir" + - "TEmptyModule" + - "TWrongModuleName" + - "CorrectName" + - path: "./canonicalize" + config: + cradle: + cabal: + - path: "./" + component: "lib:canonicalize"