Merge branch 'master' into narrow-codeactions-to-range

Author: jneira

ghcide/session-loader/Development/IDE/Session.hs

@@ -90,6 +90,9 @@ import           HieDb.Types
 import           HieDb.Utils
 import           Maybes                               (MaybeT (runMaybeT))
 
+-- | Bump this version number when making changes to the format of the data stored in hiedb
+hiedbDataVersion :: String
+hiedbDataVersion = "1"
 
 data CacheDirs = CacheDirs
   { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
@@ -103,6 +106,11 @@ data SessionLoadingOptions = SessionLoadingOptions
   , getCacheDirs        :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
   , getInitialGhcLibDir :: IO (Maybe LibDir)
+  , fakeUid             :: InstalledUnitId
+    -- ^ unit id used to tag the internal component built by ghcide
+    --   To reuse external interface files the unit ids must match,
+    --   thus make sure to build them with `--this-unit-id` set to the
+    --   same value as the ghcide fake uid
   }
 
 instance Default SessionLoadingOptions where
@@ -111,6 +119,7 @@ instance Default SessionLoadingOptions where
         ,loadCradle = HieBios.loadCradle
         ,getCacheDirs = getCacheDirsDefault
         ,getInitialGhcLibDir = getInitialGhcLibDirDefault
+        ,fakeUid = toInstalledUnitId (stringToUnitId "main")
         }
 
 getInitialGhcLibDirDefault :: IO (Maybe LibDir)
@@ -167,7 +176,7 @@ runWithDb fp k = do
 
 getHieDbLoc :: FilePath -> IO FilePath
 getHieDbLoc dir = do
-  let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb"
+  let db = intercalate "-" [dirHash, takeBaseName dir, VERSION_ghc, hiedbDataVersion] <.> "hiedb"
       dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir
   cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
   createDirectoryIfMissing True cDir
@@ -277,7 +286,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
               new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
                   -- Remove all inplace dependencies from package flags for
                   -- components in this HscEnv
-                  let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
+                  let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags
                   let prefix = show rawComponentUnitId
                   -- See Note [Avoiding bad interface files]
                   let hscComponents = sort $ map show uids
@@ -716,12 +725,15 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs
 -- There are several places in GHC (for example the call to hptInstances in
 -- tcRnImports) which assume that all modules in the HPT have the same unit
 -- ID. Therefore we create a fake one and give them all the same unit id.
-removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
-removeInplacePackages us df = (df { packageFlags = ps
+removeInplacePackages
+    :: InstalledUnitId     -- ^ fake uid to use for our internal component
+    -> [InstalledUnitId]
+    -> DynFlags
+    -> (DynFlags, [InstalledUnitId])
+removeInplacePackages fake_uid us df = (df { packageFlags = ps
                                   , thisInstalledUnitId = fake_uid }, uids)
   where
     (uids, ps) = partitionEithers (map go (packageFlags df))
-    fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
     go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
                                                   then Left (toInstalledUnitId u)
                                                   else Right p

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

@@ -571,7 +571,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
         LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $
           LSP.Report $ LSP.WorkDoneProgressReportParams
             { _cancellable = Nothing
-            , _message = Just $ T.pack (show srcPath) <> progress
+            , _message = Just $ T.pack (fromNormalizedFilePath srcPath) <> progress
             , _percentage = Nothing
             }
 

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

@@ -842,7 +842,7 @@ getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndInd
         Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err
         -- can just re-index the file we read from disk
         Right hf -> liftIO $ do
-          L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (show f)
+          L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f)
           indexHieFile se ms f hash hf
 
   let fp = hiFileFingerPrint x

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -1195,6 +1195,11 @@ suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule
   | msg <- unifySpaces _message
   , Just thingMissing <- extractNotInScopeName msg
   , qual <- extractQualifiedModuleName msg
+  , qual' <-
+      extractDoesNotExportModuleName msg
+        >>= (findImportDeclByModuleName hsmodImports . T.unpack)
+        >>= ideclAs . unLoc
+        <&> T.pack . moduleNameString . unLoc
   , Just insertLine <- case hsmodImports of
         [] -> case srcSpanStart $ getLoc (head hsmodDecls) of
           RealSrcLoc s -> Just $ srcLocLine s - 1
@@ -1206,7 +1211,7 @@ suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule
   , extendImportSuggestions <- matchRegexUnifySpaces msg
     "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
   = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
-    | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual, thingMissing) extendImportSuggestions
+    | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions
     ]
 suggestNewImport _ _ _ = []
 
@@ -1272,6 +1277,37 @@ extractQualifiedModuleName x
   | otherwise
   = Nothing
 
+-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules
+-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier
+-- from the imported one.
+--
+-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s):
+-- 1.
+-- import qualified Data.Text as T
+--
+-- Module ‘Data.Text’ does not export ‘putStrLn’.
+--
+-- 2.
+-- import qualified Data.Text as T
+-- import qualified Data.Functor as T
+--
+-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.
+--
+-- 3.
+-- import qualified Data.Text as T
+-- import qualified Data.Functor as T
+-- import qualified Data.Function as T
+--
+-- Neither ‘Data.Function’,
+--         ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.
+extractDoesNotExportModuleName :: T.Text -> Maybe T.Text
+extractDoesNotExportModuleName x
+  | Just [m] <-
+    matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export"
+      <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports"
+  = Just m
+  | otherwise
+  = Nothing
 -------------------------------------------------------------------------------------------------
 
 

ghcide/test/exe/Main.hs

@@ -1559,6 +1559,19 @@ suggestImportTests = testGroup "suggest import actions"
     , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"
     , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"
     , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"
+    , test True 
+      ["qualified Data.Text as T"
+      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
+    , test True 
+      [ "qualified Data.Text as T"
+      , "qualified Data.Function as T"
+      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
+    , test True 
+      [ "qualified Data.Text as T"
+      , "qualified Data.Function as T"
+      , "qualified Data.Functor as T"
+      , "qualified Data.Data as T"
+      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
     ]
   ]
   where

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

@@ -53,13 +53,13 @@ library
     , transformers
     , unordered-containers
 
-  if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0))
+  if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc <9.0.0))
     build-depends: ghc ^>= 8.10
 
   else
     build-depends:
       , ghc
-      , ghc-lib            ^>= 8.10.2.20200916
+      , ghc-lib            ^>= 8.10.4.20210206
       , ghc-lib-parser-ex  ^>= 8.10
 
     cpp-options:   -DHLINT_ON_GHC_LIB

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

@@ -51,8 +51,6 @@ import           "ghc-lib-parser" GHC.LanguageExtensions            (Extension)
 import           "ghc" HscTypes                                     as RealGHC.HscTypes (hsc_dflags,
                                                                                          ms_hspp_opts)
 import           Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
-import           System.Environment                                 (setEnv,
-                                                                     unsetEnv)
 import           System.FilePath                                    (takeFileName)
 import           System.IO                                          (IOMode (WriteMode),
                                                                      hClose,
@@ -86,6 +84,8 @@ import qualified Language.LSP.Types.Lens                            as LSP
 import           GHC.Generics                                       (Generic)
 import           Text.Regex.TDFA.Text                               ()
 
+import           System.Environment                                 (setEnv,
+                                                                     unsetEnv)
 -- ---------------------------------------------------------------------
 
 descriptor :: PluginId -> PluginDescriptor IdeState
@@ -385,36 +385,27 @@ applyHint ide nfp mhint =
     oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent
     (modsum, _) <- liftIO $ runAction' $ use_ GetModSummary nfp
     let dflags = ms_hspp_opts modsum
+    -- Setting a environment variable with the libdir used by ghc-exactprint.
+    -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir
+    -- in ghc-exactprint that makes dependent executables non portables.
+    -- See https://github.com/alanz/ghc-exactprint/issues/96.
+    -- WARNING: this code is not thread safe, so if you try to apply several async refactorings
+    -- it could fail. That case is not very likely so we assume the risk.
+    let withRuntimeLibdir :: IO a -> IO a
+        withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
+            where key = "GHC_EXACTPRINT_GHC_LIBDIR"
     -- set Nothing as "position" for "applyRefactorings" because
     -- applyRefactorings expects the provided position to be _within_ the scope
     -- of each refactoring it will apply.
     -- But "Idea"s returned by HLint point to starting position of the expressions
     -- that contain refactorings, so they are often outside the refactorings' boundaries.
-    -- Example:
-    -- Given an expression "hlintTest = reid $ (myid ())"
-    -- Hlint returns an idea at the position (1,13)
-    -- That contains "Redundant brackets" refactoring at position (1,20):
-    --
-    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
-    --
-    -- 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 position = Nothing
 #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)
-    -- Setting a environment variable with the libdir used by ghc-exactprint.
-    -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir
-    -- in ghc-exactprint that makes dependent executables non portables.
-    -- See https://github.com/alanz/ghc-exactprint/issues/96.
-    -- WARNING: this code is not thread safe, so if you try to apply several async refactorings
-    -- it could fail. That case is not very likely so we assume the risk.
-    let withRuntimeLibdir :: IO a -> IO a
-        withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
-            where key = "GHC_EXACTPRINT_GHC_LIBDIR"
     res <-
         liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
             hClose h
@@ -424,7 +415,7 @@ applyHint ide nfp mhint =
             -- 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 <$> withRuntimeLibdir (applyRefactorings Nothing commands temp refactExts))
+            (Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts))
                 `catches` errorHandlers
 #else
     mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
@@ -438,7 +429,7 @@ applyHint ide nfp mhint =
                 let rigidLayout = deltaOptions RigidLayout
                 (anns', modu') <-
                     ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
-                liftIO $ (Right <$> applyRefactorings' Nothing commands anns' modu')
+                liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu'))
                             `catches` errorHandlers
 #endif
     case res of

plugins/hls-tactics-plugin/README.md

@@ -0,0 +1,54 @@
+<p align="center">
+<img src="https://haskellwingman.dev/wingman.png" height="256" alt="Wingman for Haskell" title="Wingman for Haskell">
+</p>
+
+<p>&nbsp;</p>
+
+# Wingman for Haskell
+
+[![Hackage](https://img.shields.io/hackage/v/hls-tactics-plugin.svg?logo=haskell&label=hls-tactics-plugin)](https://hackage.haskell.org/package/hls-tactics-plugin)
+
+"Focus on the important stuff; delegate the rest"
+
+
+## Dedication
+
+> There's a lot of automation that can happen that isn't a replacement of
+> humans, but of mind-numbing behavior.
+>
+> --Stewart Butterfield
+
+
+## Overview
+
+Wingman writes the boring, auxiliary code, so you don't have to. Generate
+functions from type signatures, and intelligently complete holes.
+
+
+## Getting Started
+
+Wingman for Haskell is enabled by default in all [official release of Haskell
+Language Server.][hls] Just hover over a typed hole, run the "Attempt to
+fill hole" code action, *et voila!*
+
+[hls]: https://github.com/haskell/haskell-language-server/releases
+
+
+## Features
+
+* [Type-directed code synthesis][auto], including pattern matching and recursion
+* [Automatic case-splitting][case] --- just run the "Case split on <x>" code action
+* [Smart next actions][next], for those times it can't read your mind
+
+[auto]: https://haskellwingman.dev/foldr.gif
+[case]: https://haskellwingman.dev/case-split.gif
+[next]: https://haskellwingman.dev/intros.gif
+
+
+## Support
+
+Please consider [pledging on Patreon][patreon] to support the project and get
+access to cutting-edge features.
+
+[patreon]: https://www.patreon.com/wingman_for_haskell
+

plugins/hls-tactics-plugin/hls-tactics-plugin.cabal

@@ -2,16 +2,18 @@ cabal-version:      2.2
 category:           Development
 name:               hls-tactics-plugin
 version:            1.0.0.0
-synopsis:           Tactics plugin for Haskell Language Server
+synopsis:           Wingman plugin for Haskell Language Server
 description:        Please see README.md
 author:             Sandy Maguire, Reed Mullanix
 maintainer:         sandy@sandymaguire.me
 copyright:          Sandy Maguire, Reed Mullanix
+homepage:           https://haskellwingman.dev
+bug-reports:        https://github.com/haskell/haskell-language-server/issues
 license:            Apache-2.0
 license-file:       LICENSE
 build-type:         Simple
--- extra-source-files:
---   README.md
+extra-source-files:
+  README.md
 --   ChangeLog.md
 
 flag pedantic

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs

@@ -23,6 +23,7 @@ import           Data.Aeson
 import           Data.Bifunctor                                   (Bifunctor (bimap))
 import           Data.Bool                                        (bool)
 import           Data.Data                                        (Data)
+import           Data.Foldable (for_)
 import           Data.Generics.Aliases                            (mkQ)
 import           Data.Generics.Schemes                            (everything)
 import           Data.Maybe
@@ -144,6 +145,7 @@ mkWorkspaceEdits
     -> RunTacticResults
     -> Either ResponseError (Maybe WorkspaceEdit)
 mkWorkspaceEdits span dflags ccs uri pm rtr = do
+  for_ (rtr_other_solns rtr) $ traceMX "other solution"
   let g = graftHole (RealSrcSpan span) rtr
       response = transform dflags ccs uri g pm
    in case response of