Merge pull request #635 from jneira/apply-refact-exts

Leverage last apply-refact improvements in hlint plugin (include getParsedModuleWithComments in ghcide)

Author: jneira

.github/workflows/bench.yml

@@ -26,11 +26,11 @@ jobs:
         path: |
           ~/.cabal/packages
           ~/.cabal/store
-        key: ${{ runner.os }}-${{ matrix.ghc }}-bench-${{ hashFiles('cabal.project') }}
+        key: v2-${{ runner.os }}-${{ matrix.ghc }}-bench-${{ hashFiles('cabal.project') }}
         restore-keys: |
-            ${{ runner.os }}-${{ matrix.ghc }}-build-${{ hashFiles('cabal.project') }}
-            ${{ runner.os }}-${{ matrix.ghc }}-bench-
-            ${{ runner.os }}-${{ matrix.ghc }}
+            v2-${{ runner.os }}-${{ matrix.ghc }}-build-${{ hashFiles('cabal.project') }}
+            v2-${{ runner.os }}-${{ matrix.ghc }}-bench-
+            v2-${{ runner.os }}-${{ matrix.ghc }}
 
     - run: cabal update
 

.github/workflows/test.yml

@@ -79,11 +79,11 @@ jobs:
           path: |
             ${{ env.CABAL_PKGS_DIR }}
             ${{ env.CABAL_STORE_DIR }}
-          key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ hashFiles('cabal.project') }}
+          key: v2-${{ runner.os }}-${{ matrix.ghc }}-build-${{ hashFiles('cabal.project') }}
           restore-keys: |
-            ${{ runner.os }}-${{ matrix.ghc }}-bench-${{ hashFiles('cabal.project') }}
-            ${{ runner.os }}-${{ matrix.ghc }}-build-
-            ${{ runner.os }}-${{ matrix.ghc }}
+            v2-${{ runner.os }}-${{ matrix.ghc }}-bench-${{ hashFiles('cabal.project') }}
+            v2-${{ runner.os }}-${{ matrix.ghc }}-build-
+            v2-${{ runner.os }}-${{ matrix.ghc }}
 
       - run: cabal update
 

cabal.project

@@ -13,6 +13,11 @@ packages:
          ./plugins/hls-haddock-comments-plugin
          ./plugins/hls-splice-plugin
 
+source-repository-package
+  type: git
+  location: https://github.com/mpickering/apply-refact.git
+  tag: 4fbd3a3a9b408bd31080848feb6b78e13c3eeb6d
+
 tests: true
 
 package *
@@ -25,7 +30,7 @@ package ghcide
 
 write-ghc-environment-files: never
 
-index-state: 2021-01-07T18:06:52Z
+index-state: 2021-01-14T12:49:26Z
 
 allow-newer:
 	active:base,

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -54,6 +54,10 @@ data LinkableType = ObjectLinkable | BCOLinkable
 -- | The parse tree for the file using GetFileContents
 type instance RuleResult GetParsedModule = ParsedModule
 
+-- | The parse tree for the file using GetFileContents,
+-- all comments included using Opt_KeepRawTokenStream
+type instance RuleResult GetParsedModuleWithComments = ParsedModule
+
 -- | The dependency information produced by following the imports recursively.
 -- This rule will succeed even if there is an error, e.g., a module could not be located,
 -- a module could not be parsed or an import cycle.
@@ -302,6 +306,12 @@ instance Hashable GetParsedModule
 instance NFData   GetParsedModule
 instance Binary   GetParsedModule
 
+data GetParsedModuleWithComments = GetParsedModuleWithComments
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetParsedModuleWithComments
+instance NFData   GetParsedModuleWithComments
+instance Binary   GetParsedModuleWithComments
+
 data GetLocatedImports = GetLocatedImports
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetLocatedImports

ghcide/src/Development/IDE/Core/Rules.hs

@@ -29,11 +29,13 @@ module Development.IDE.Core.Rules(
     highlightAtPoint,
     getDependencies,
     getParsedModule,
+    getParsedModuleWithComments,
     getClientConfigAction,
     -- * Rules
     CompiledLinkables(..),
     IsHiFileStable(..),
     getParsedModuleRule,
+    getParsedModuleWithCommentsRule,
     getLocatedImportsRule,
     getDependencyInformationRule,
     reportImportCyclesRule,
@@ -268,9 +270,14 @@ getPackageHieFile ide mod file = do
                 _ -> MaybeT $ return Nothing
         _ -> MaybeT $ return Nothing
 
--- | Parse the contents of a daml file.
+-- | Parse the contents of a haskell file.
 getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
-getParsedModule file = use GetParsedModule file
+getParsedModule = use GetParsedModule
+
+-- | Parse the contents of a haskell file,
+-- ensuring comments are preserved in annotations
+getParsedModuleWithComments :: NormalizedFilePath -> Action (Maybe ParsedModule)
+getParsedModuleWithComments = use GetParsedModuleWithComments
 
 ------------------------------------------------------------
 -- Rules
@@ -285,12 +292,15 @@ priorityGenerateCore = Priority (-1)
 priorityFilesOfInterest :: Priority
 priorityFilesOfInterest = Priority (-2)
 
--- | IMPORTANT FOR HLINT INTEGRATION:
+-- | WARNING:
 -- We currently parse the module both with and without Opt_Haddock, and
 -- return the one with Haddocks if it -- succeeds. However, this may not work
--- for hlint, and we might need to save the one without haddocks too.
+-- for hlint or any client code that might need the parsed source with all
+-- annotations, including comments.
+-- For that use case you might want to use `getParsedModuleWithCommentsRule`
 -- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197
 -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490
+-- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations
 getParsedModuleRule :: Rules ()
 getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
     (ms, _) <- use_ GetModSummary file
@@ -333,8 +343,10 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
     pure res
 
 withOptHaddock :: ModSummary -> ModSummary
-withOptHaddock ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) Opt_Haddock}
+withOptHaddock = withOption Opt_Haddock
 
+withOption :: GeneralFlag -> ModSummary -> ModSummary
+withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt}
 
 -- | Given some normal parse errors (first) and some from Haddock (second), merge them.
 --   Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings.
@@ -348,6 +360,19 @@ mergeParseErrorsHaddock normal haddock = normal ++
     fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x
                  | otherwise = "Haddock: " <> x
 
+-- | This rule provides a ParsedModule preserving all annotations,
+-- including keywords, punctuation and comments.
+-- So it is suitable for use cases where you need a perfect edit.
+getParsedModuleWithCommentsRule :: Rules ()
+getParsedModuleWithCommentsRule = defineEarlyCutoff $ \GetParsedModuleWithComments file -> do
+    (ms, _) <- use_ GetModSummary file
+    sess <- use_ GhcSession file
+    opt <- getIdeOptions
+
+    let ms' = withOption Opt_KeepRawTokenStream ms
+
+    liftIO $ getParsedModuleDefinition (hscEnv sess) opt file ms'
+
 getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
 getParsedModuleDefinition packageState opt file ms = do
     let fp = fromNormalizedFilePath file
@@ -974,6 +999,7 @@ mainRule = do
     linkables <- liftIO $ newVar emptyModuleEnv
     addIdeGlobal $ CompiledLinkables linkables
     getParsedModuleRule
+    getParsedModuleWithCommentsRule
     getLocatedImportsRule
     getDependencyInformationRule
     reportImportCyclesRule

plugins/hls-hlint-plugin/hls-hlint-plugin.cabal

@@ -38,6 +38,7 @@ library
     , directory
     , extra
     , filepath
+    , ghc-exactprint
     , ghcide
     , hashable
     , haskell-lsp
@@ -61,7 +62,7 @@ library
       , ghc-lib            ^>= 8.10.2.20200916
       , ghc-lib-parser-ex  ^>= 8.10
 
-    cpp-options:   -DGHC_LIB
+    cpp-options:   -DHLINT_ON_GHC_LIB
 
   ghc-options:      -Wall -Wredundant-constraints -Wno-name-shadowing
 

plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
@@ -33,18 +34,25 @@ import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Typeable
 import Development.IDE
-import Development.IDE.Core.Rules (defineNoFile)
+import Development.IDE.Core.Rules (getParsedModuleWithComments, defineNoFile)
 import Development.IDE.Core.Shake (getDiagnostics)
 
-#ifdef GHC_LIB
+#ifdef HLINT_ON_GHC_LIB
 import Data.List (nub)
-import "ghc-lib" GHC hiding (DynFlags(..))
+import "ghc-lib" GHC hiding (DynFlags(..), ms_hspp_opts)
+import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
 import "ghc" GHC as RealGHC (DynFlags(..))
-import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags)
+import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, ms_hspp_opts)
 import qualified "ghc" EnumSet as EnumSet
 import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
+import System.FilePath (takeFileName)
+import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose)
+import System.IO.Temp
 #else
 import Development.IDE.GHC.Compat hiding (DynFlags(..))
+import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
+import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
+import Language.Haskell.GHC.ExactPrint.Types (Rigidity(..))
 #endif
 
 import Ide.Logger
@@ -53,12 +61,12 @@ import Ide.Plugin.Config
 import Ide.PluginUtils
 import Language.Haskell.HLint as Hlint
 import Language.Haskell.LSP.Core
+    ( LspFuncs(withIndefiniteProgress),
+      ProgressCancellable(Cancellable) )
 import Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Types      as LSP
 import qualified Language.Haskell.LSP.Types.Lens as LSP
-import System.FilePath (takeFileName)
-import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose)
-import System.IO.Temp
+
 import Text.Regex.TDFA.Text()
 import GHC.Generics (Generic)
 
@@ -176,7 +184,14 @@ getIdeas nfp = do
   fmap applyHints' (moduleEx flags)
 
   where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
-#ifdef GHC_LIB
+#ifndef HLINT_ON_GHC_LIB
+        moduleEx _flags = do
+          mbpm <- getParsedModule nfp
+          return $ createModule <$> mbpm
+          where createModule pm = Right (createModuleEx anns modu)
+                  where anns = pm_annotations pm
+                        modu = pm_parsed_source pm
+#else
         moduleEx flags = do
           mbpm <- getParsedModule nfp
           -- If ghc was not able to parse the module, we disable hlint diagnostics
@@ -190,20 +205,21 @@ getIdeas nfp = do
                      Just <$> (liftIO $ parseModuleEx flags' fp contents')
 
         setExtensions flags = do
-          hsc <- hscEnv <$> use_ GhcSession nfp
-          let dflags = hsc_dflags hsc
-          let hscExts = EnumSet.toList (extensionFlags dflags)
-          let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts
-          let hlintExts = nub $ enabledExtensions flags ++ hscExts'
+          hlintExts <- getExtensions flags nfp
           logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts
           return $ flags { enabledExtensions = hlintExts }
-#else
-        moduleEx _flags = do
-          mbpm <- getParsedModule nfp
-          return $ createModule <$> mbpm
-          where createModule pm = Right (createModuleEx anns modu)
-                  where anns = pm_annotations pm
-                        modu = pm_parsed_source pm
+
+getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension]
+getExtensions pflags nfp = do
+    dflags <- getFlags
+    let hscExts = EnumSet.toList (extensionFlags dflags)
+    let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts
+    let hlintExts = nub $ enabledExtensions pflags ++ hscExts'
+    return hlintExts
+  where getFlags :: Action DynFlags
+        getFlags = do
+          (modsum, _) <- use_ GetModSummary nfp
+          return $ ms_hspp_opts modsum
 #endif
 
 -- ---------------------------------------------------------------------
@@ -334,10 +350,18 @@ applyOneCmd lf ide (AOP uri pos title) = do
 applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
 applyHint ide nfp mhint =
   runExceptT $ do
-    ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp
+    let runAction' :: Action a -> IO a
+        runAction' = runAction "applyHint" ide
+    let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException)))
+                        , Handler $ \e -> return (Left (show (e :: ErrorCall)))
+                        ]
+    ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas nfp
     let ideas' = maybe ideas (`filterIdeas` ideas) mhint
-    let commands = map (show &&& ideaRefactoring) ideas'
+    let commands = map ideaRefactoring ideas'
     liftIO $ logm $ "applyHint:apply=" ++ show commands
+    let fp = fromNormalizedFilePath nfp
+    (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp
+    oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent
     -- set Nothing as "position" for "applyRefactorings" because
     -- applyRefactorings expects the provided position to be _within_ the scope
     -- of each refactoring it will apply.
@@ -353,27 +377,48 @@ applyHint ide nfp mhint =
     -- If we provide "applyRefactorings" with "Just (1,13)" then
     -- the "Redundant bracket" hint will never be executed
     -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
-    let fp = fromNormalizedFilePath nfp
-    (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp
-    oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent
-    -- We need to save a file with last edited contents cause `apply-refact`
-    -- doesn't expose a function taking directly contents instead a file path.
-    -- Ideally we should try to expose that function upstream and remove this.
-    res <- liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
+#ifdef HLINT_ON_GHC_LIB
+    let writeFileUTF8NoNewLineTranslation file txt =
+            withFile file WriteMode $ \h -> do
+                hSetEncoding h utf8
+                hSetNewlineMode h noNewlineTranslation
+                hPutStr h (T.unpack txt)
+    res <-
+        liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
             hClose h
             writeFileUTF8NoNewLineTranslation temp oldContent
-            (Right <$> applyRefactorings Nothing commands temp) `catches`
-                    [ Handler $ \e -> return (Left (show (e :: IOException)))
-                    , Handler $ \e -> return (Left (show (e :: ErrorCall)))
-                    ]
+            (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings
+            exts <- runAction' $ getExtensions pflags nfp
+            -- We have to reparse extensions to remove the invalid ones
+            let (enabled, disabled, _invalid) = parseExtensions $ map show exts
+            let refactExts = map show $ enabled ++ disabled
+            (Right <$> applyRefactorings Nothing commands temp refactExts)
+                `catches` errorHandlers
+#else
+    mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
+    res <-
+        case mbParsedModule of
+            Nothing -> throwE "Apply hint: error parsing the module"
+            Just pm -> do
+                let anns = pm_annotations pm
+                let modu = pm_parsed_source pm
+                (modsum, _) <- liftIO $ runAction' $ use_ GetModSummary nfp
+                let dflags = ms_hspp_opts modsum
+                -- apply-refact uses RigidLayout
+                let rigidLayout = deltaOptions RigidLayout
+                (anns', modu') <-
+                    ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
+                liftIO $ (Right <$> applyRefactorings' Nothing commands anns' modu')
+                            `catches` errorHandlers
+#endif
     case res of
       Right appliedFile -> do
         let uri = fromNormalizedUri (filePathToUri' nfp)
         let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions
         liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit
         ExceptT $ return (Right wsEdit)
       Left err ->
-        throwE (show err)
+        throwE err
     where
           -- | If we are only interested in applying a particular hint then
           -- let's filter out all the irrelevant ideas
@@ -396,10 +441,3 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
   h (Left e)  = Left (f e)
   h (Right a) = Right (g a)
 {-# INLINE bimapExceptT #-}
-
-writeFileUTF8NoNewLineTranslation :: FilePath -> T.Text -> IO()
-writeFileUTF8NoNewLineTranslation file txt =
-  withFile file WriteMode $ \h -> do
-    hSetEncoding h utf8
-    hSetNewlineMode h noNewlineTranslation
-    hPutStr h (T.unpack txt)

stack-8.10.1.yaml

@@ -19,12 +19,15 @@ ghc-options:
   "$everything": -haddock
 
 extra-deps:
+  - git: https://github.com/mpickering/apply-refact.git
+    commit: 4fbd3a3a9b408bd31080848feb6b78e13c3eeb6d
   - brittany-0.13.1.0
   - Cabal-3.0.2.0
   - clock-0.7.2
   - data-tree-print-0.1.0.2@rev:2
   - floskell-0.10.4
   - fourmolu-0.3.0.0
+  - ghc-exactprint-0.6.3.3
   - ghc-lib-8.10.3.20201220
   - ghc-lib-parser-8.10.3.20201220
   - heapsize-0.3.0