Fix #3047 (#3092)

July541 · web-flow · commit 49373fd01465 · 2022-08-14T14:44:59.000Z
* Make path canonicalized

* Update extra-source-files

* Replace with normalise

* Change to a more detailed log

* Comment patch detail

* 2 spaces indent
diff --git a/exe/Plugins.hs b/exe/Plugins.hs
@@ -188,7 +188,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
       RefineImports.descriptor pluginRecorder "refineImports" :
 #endif
 #if hls_moduleName
-      ModuleName.descriptor "moduleName" :
+      ModuleName.descriptor pluginRecorder "moduleName" :
 #endif
 #if hls_hlint
       Hlint.descriptor pluginRecorder "hlint" :
diff --git a/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal b/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal
@@ -16,6 +16,8 @@ extra-source-files:
   LICENSE
   test/testdata/**/*.yaml
   test/testdata/**/*.hs
+  test/testdata/**/*.cabal
+  test/testdata/**/*.project
 
 library
   exposed-modules:  Ide.Plugin.ModuleName
diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/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,65 +16,72 @@ module Ide.Plugin.ModuleName (
     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,
-                                             moduleNameString,
-                                             pattern RealSrcSpan,
-                                             pm_parsed_source, unLoc)
+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
       where
         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
@@ -92,19 +100,22 @@ data Action = Replace
   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 ->
@@ -118,22 +129,31 @@ action state uri =
 -- | 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
     moduleNameFrom mdlPath prefix =
       T.pack
         . intercalate "."
         . splitDirectories
-        . drop (length prefix + 1)
+        . drop (length prefix)
         $ dropExtension mdlPath
 
 -- | The module name, as stated in the module
@@ -143,8 +163,20 @@ codeModuleName state nfp = runMaybeT $ do
   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
-
-traceAs :: b -> a -> a
-traceAs _ a = a
+data Log =
+    CorrectNames [T.Text]
+  | BestName T.Text
+  | ModuleName (Maybe T.Text)
+  | SrcPaths [FilePath]
+  | NormalisedPaths [FilePath]
+  | AbsoluteFilePath FilePath
+  deriving Show
+
+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/plugins/hls-module-name-plugin/test/Main.hs b/plugins/hls-module-name-plugin/test/Main.hs
@@ -13,7 +13,7 @@ main :: IO ()
 main = defaultTestRunner tests
 
 moduleNamePlugin :: PluginDescriptor IdeState
-moduleNamePlugin = ModuleName.descriptor "moduleName"
+moduleNamePlugin = ModuleName.descriptor mempty "moduleName"
 
 tests :: TestTree
 tests =
@@ -39,10 +39,15 @@ tests =
       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/plugins/hls-module-name-plugin/test/testdata/cabal.project b/plugins/hls-module-name-plugin/test/testdata/cabal.project
@@ -0,0 +1 @@
+packages: ./canonicalize
diff --git a/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs b/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs
@@ -0,0 +1 @@
+module Lib.A where
diff --git a/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs b/plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs
diff --git a/plugins/hls-module-name-plugin/test/testdata/canonicalize/canonicalize.cabal b/plugins/hls-module-name-plugin/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/plugins/hls-module-name-plugin/test/testdata/hie.yaml b/plugins/hls-module-name-plugin/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"
