Skip to content

Commit f0796d1

Browse files
jneirajneira
authored
Merge branch 'master' into narrow-codeactions-to-range
2 parents ca92689 + 43b33a5 commit f0796d1

File tree

25 files changed

+372
-254
lines changed

25 files changed

+372
-254
lines changed

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

Lines changed: 17 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,9 @@ import HieDb.Types
9090
import HieDb.Utils
9191
import Maybes (MaybeT (runMaybeT))
9292

93+
-- | Bump this version number when making changes to the format of the data stored in hiedb
94+
hiedbDataVersion :: String
95+
hiedbDataVersion = "1"
9396

9497
data CacheDirs = CacheDirs
9598
{ hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
@@ -103,6 +106,11 @@ data SessionLoadingOptions = SessionLoadingOptions
103106
, getCacheDirs :: String -> [String] -> IO CacheDirs
104107
-- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
105108
, getInitialGhcLibDir :: IO (Maybe LibDir)
109+
, fakeUid :: InstalledUnitId
110+
-- ^ unit id used to tag the internal component built by ghcide
111+
-- To reuse external interface files the unit ids must match,
112+
-- thus make sure to build them with `--this-unit-id` set to the
113+
-- same value as the ghcide fake uid
106114
}
107115

108116
instance Default SessionLoadingOptions where
@@ -111,6 +119,7 @@ instance Default SessionLoadingOptions where
111119
,loadCradle = HieBios.loadCradle
112120
,getCacheDirs = getCacheDirsDefault
113121
,getInitialGhcLibDir = getInitialGhcLibDirDefault
122+
,fakeUid = toInstalledUnitId (stringToUnitId "main")
114123
}
115124

116125
getInitialGhcLibDirDefault :: IO (Maybe LibDir)
@@ -167,7 +176,7 @@ runWithDb fp k = do
167176

168177
getHieDbLoc :: FilePath -> IO FilePath
169178
getHieDbLoc dir = do
170-
let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb"
179+
let db = intercalate "-" [dirHash, takeBaseName dir, VERSION_ghc, hiedbDataVersion] <.> "hiedb"
171180
dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir
172181
cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
173182
createDirectoryIfMissing True cDir
@@ -277,7 +286,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
277286
new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
278287
-- Remove all inplace dependencies from package flags for
279288
-- components in this HscEnv
280-
let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
289+
let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags
281290
let prefix = show rawComponentUnitId
282291
-- See Note [Avoiding bad interface files]
283292
let hscComponents = sort $ map show uids
@@ -716,12 +725,15 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs
716725
-- There are several places in GHC (for example the call to hptInstances in
717726
-- tcRnImports) which assume that all modules in the HPT have the same unit
718727
-- ID. Therefore we create a fake one and give them all the same unit id.
719-
removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
720-
removeInplacePackages us df = (df { packageFlags = ps
728+
removeInplacePackages
729+
:: InstalledUnitId -- ^ fake uid to use for our internal component
730+
-> [InstalledUnitId]
731+
-> DynFlags
732+
-> (DynFlags, [InstalledUnitId])
733+
removeInplacePackages fake_uid us df = (df { packageFlags = ps
721734
, thisInstalledUnitId = fake_uid }, uids)
722735
where
723736
(uids, ps) = partitionEithers (map go (packageFlags df))
724-
fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
725737
go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
726738
then Left (toInstalledUnitId u)
727739
else Right p

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -571,7 +571,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
571571
LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $
572572
LSP.Report $ LSP.WorkDoneProgressReportParams
573573
{ _cancellable = Nothing
574-
, _message = Just $ T.pack (show srcPath) <> progress
574+
, _message = Just $ T.pack (fromNormalizedFilePath srcPath) <> progress
575575
, _percentage = Nothing
576576
}
577577

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -842,7 +842,7 @@ getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndInd
842842
Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err
843843
-- can just re-index the file we read from disk
844844
Right hf -> liftIO $ do
845-
L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (show f)
845+
L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f)
846846
indexHieFile se ms f hash hf
847847

848848
let fp = hiFileFingerPrint x

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

Lines changed: 37 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1195,6 +1195,11 @@ suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule
11951195
| msg <- unifySpaces _message
11961196
, Just thingMissing <- extractNotInScopeName msg
11971197
, qual <- extractQualifiedModuleName msg
1198+
, qual' <-
1199+
extractDoesNotExportModuleName msg
1200+
>>= (findImportDeclByModuleName hsmodImports . T.unpack)
1201+
>>= ideclAs . unLoc
1202+
<&> T.pack . moduleNameString . unLoc
11981203
, Just insertLine <- case hsmodImports of
11991204
[] -> case srcSpanStart $ getLoc (head hsmodDecls) of
12001205
RealSrcLoc s -> Just $ srcLocLine s - 1
@@ -1206,7 +1211,7 @@ suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule
12061211
, extendImportSuggestions <- matchRegexUnifySpaces msg
12071212
"Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
12081213
= [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
1209-
| imp <- sort $ constructNewImportSuggestions packageExportsMap (qual, thingMissing) extendImportSuggestions
1214+
| imp <- sort $ constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions
12101215
]
12111216
suggestNewImport _ _ _ = []
12121217

@@ -1272,6 +1277,37 @@ extractQualifiedModuleName x
12721277
| otherwise
12731278
= Nothing
12741279

1280+
-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules
1281+
-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier
1282+
-- from the imported one.
1283+
--
1284+
-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s):
1285+
-- 1.
1286+
-- import qualified Data.Text as T
1287+
--
1288+
-- Module ‘Data.Text’ does not export ‘putStrLn’.
1289+
--
1290+
-- 2.
1291+
-- import qualified Data.Text as T
1292+
-- import qualified Data.Functor as T
1293+
--
1294+
-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.
1295+
--
1296+
-- 3.
1297+
-- import qualified Data.Text as T
1298+
-- import qualified Data.Functor as T
1299+
-- import qualified Data.Function as T
1300+
--
1301+
-- Neither ‘Data.Function’,
1302+
-- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.
1303+
extractDoesNotExportModuleName :: T.Text -> Maybe T.Text
1304+
extractDoesNotExportModuleName x
1305+
| Just [m] <-
1306+
matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export"
1307+
<|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports"
1308+
= Just m
1309+
| otherwise
1310+
= Nothing
12751311
-------------------------------------------------------------------------------------------------
12761312

12771313

‎ghcide/test/exe/Main.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1559,6 +1559,19 @@ suggestImportTests = testGroup "suggest import actions"
15591559
, test True [] "f = (&) [] id" [] "import Data.Function ((&))"
15601560
, test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))"
15611561
, test True [] "f = (.|.)" [] "import Data.Bits ((.|.))"
1562+
, test True
1563+
["qualified Data.Text as T"
1564+
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
1565+
, test True
1566+
[ "qualified Data.Text as T"
1567+
, "qualified Data.Function as T"
1568+
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
1569+
, test True
1570+
[ "qualified Data.Text as T"
1571+
, "qualified Data.Function as T"
1572+
, "qualified Data.Functor as T"
1573+
, "qualified Data.Data as T"
1574+
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
15621575
]
15631576
]
15641577
where

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -53,13 +53,13 @@ library
5353
, transformers
5454
, unordered-containers
5555

56-
if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0))
56+
if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc <9.0.0))
5757
build-depends: ghc ^>= 8.10
5858

5959
else
6060
build-depends:
6161
, ghc
62-
, ghc-lib ^>= 8.10.2.20200916
62+
, ghc-lib ^>= 8.10.4.20210206
6363
, ghc-lib-parser-ex ^>= 8.10
6464

6565
cpp-options: -DHLINT_ON_GHC_LIB

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

Lines changed: 14 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -51,8 +51,6 @@ import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
5151
import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags,
5252
ms_hspp_opts)
5353
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
54-
import System.Environment (setEnv,
55-
unsetEnv)
5654
import System.FilePath (takeFileName)
5755
import System.IO (IOMode (WriteMode),
5856
hClose,
@@ -86,6 +84,8 @@ import qualified Language.LSP.Types.Lens as LSP
8684
import GHC.Generics (Generic)
8785
import Text.Regex.TDFA.Text ()
8886

87+
import System.Environment (setEnv,
88+
unsetEnv)
8989
-- ---------------------------------------------------------------------
9090

9191
descriptor :: PluginId -> PluginDescriptor IdeState
@@ -385,36 +385,27 @@ applyHint ide nfp mhint =
385385
oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent
386386
(modsum, _) <- liftIO $ runAction' $ use_ GetModSummary nfp
387387
let dflags = ms_hspp_opts modsum
388+
-- Setting a environment variable with the libdir used by ghc-exactprint.
389+
-- It is a workaround for an error caused by the use of a hadcoded at compile time libdir
390+
-- in ghc-exactprint that makes dependent executables non portables.
391+
-- See https://github.com/alanz/ghc-exactprint/issues/96.
392+
-- WARNING: this code is not thread safe, so if you try to apply several async refactorings
393+
-- it could fail. That case is not very likely so we assume the risk.
394+
let withRuntimeLibdir :: IO a -> IO a
395+
withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
396+
where key = "GHC_EXACTPRINT_GHC_LIBDIR"
388397
-- set Nothing as "position" for "applyRefactorings" because
389398
-- applyRefactorings expects the provided position to be _within_ the scope
390399
-- of each refactoring it will apply.
391400
-- But "Idea"s returned by HLint point to starting position of the expressions
392401
-- that contain refactorings, so they are often outside the refactorings' boundaries.
393-
-- Example:
394-
-- Given an expression "hlintTest = reid $ (myid ())"
395-
-- Hlint returns an idea at the position (1,13)
396-
-- That contains "Redundant brackets" refactoring at position (1,20):
397-
--
398-
-- [("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"}])]
399-
--
400-
-- If we provide "applyRefactorings" with "Just (1,13)" then
401-
-- the "Redundant bracket" hint will never be executed
402-
-- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
402+
let position = Nothing
403403
#ifdef HLINT_ON_GHC_LIB
404404
let writeFileUTF8NoNewLineTranslation file txt =
405405
withFile file WriteMode $ \h -> do
406406
hSetEncoding h utf8
407407
hSetNewlineMode h noNewlineTranslation
408408
hPutStr h (T.unpack txt)
409-
-- Setting a environment variable with the libdir used by ghc-exactprint.
410-
-- It is a workaround for an error caused by the use of a hadcoded at compile time libdir
411-
-- in ghc-exactprint that makes dependent executables non portables.
412-
-- See https://github.com/alanz/ghc-exactprint/issues/96.
413-
-- WARNING: this code is not thread safe, so if you try to apply several async refactorings
414-
-- it could fail. That case is not very likely so we assume the risk.
415-
let withRuntimeLibdir :: IO a -> IO a
416-
withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
417-
where key = "GHC_EXACTPRINT_GHC_LIBDIR"
418409
res <-
419410
liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
420411
hClose h
@@ -424,7 +415,7 @@ applyHint ide nfp mhint =
424415
-- We have to reparse extensions to remove the invalid ones
425416
let (enabled, disabled, _invalid) = parseExtensions $ map show exts
426417
let refactExts = map show $ enabled ++ disabled
427-
(Right <$> withRuntimeLibdir (applyRefactorings Nothing commands temp refactExts))
418+
(Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts))
428419
`catches` errorHandlers
429420
#else
430421
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
@@ -438,7 +429,7 @@ applyHint ide nfp mhint =
438429
let rigidLayout = deltaOptions RigidLayout
439430
(anns', modu') <-
440431
ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
441-
liftIO $ (Right <$> applyRefactorings' Nothing commands anns' modu')
432+
liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu'))
442433
`catches` errorHandlers
443434
#endif
444435
case res of

‎plugins/hls-tactics-plugin/README.md

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
<p align="center">
2+
<img src="https://haskellwingman.dev/wingman.png" height="256" alt="Wingman for Haskell" title="Wingman for Haskell">
3+
</p>
4+
5+
<p>&nbsp;</p>
6+
7+
# Wingman for Haskell
8+
9+
[![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)
10+
11+
"Focus on the important stuff; delegate the rest"
12+
13+
14+
## Dedication
15+
16+
> There's a lot of automation that can happen that isn't a replacement of
17+
> humans, but of mind-numbing behavior.
18+
>
19+
> --Stewart Butterfield
20+
21+
22+
## Overview
23+
24+
Wingman writes the boring, auxiliary code, so you don't have to. Generate
25+
functions from type signatures, and intelligently complete holes.
26+
27+
28+
## Getting Started
29+
30+
Wingman for Haskell is enabled by default in all [official release of Haskell
31+
Language Server.][hls] Just hover over a typed hole, run the "Attempt to
32+
fill hole" code action, *et voila!*
33+
34+
[hls]: https://github.com/haskell/haskell-language-server/releases
35+
36+
37+
## Features
38+
39+
* [Type-directed code synthesis][auto], including pattern matching and recursion
40+
* [Automatic case-splitting][case] --- just run the "Case split on <x>" code action
41+
* [Smart next actions][next], for those times it can't read your mind
42+
43+
[auto]: https://haskellwingman.dev/foldr.gif
44+
[case]: https://haskellwingman.dev/case-split.gif
45+
[next]: https://haskellwingman.dev/intros.gif
46+
47+
48+
## Support
49+
50+
Please consider [pledging on Patreon][patreon] to support the project and get
51+
access to cutting-edge features.
52+
53+
[patreon]: https://www.patreon.com/wingman_for_haskell
54+

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

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,18 @@ cabal-version: 2.2
22
category: Development
33
name: hls-tactics-plugin
44
version: 1.0.0.0
5-
synopsis: Tactics plugin for Haskell Language Server
5+
synopsis: Wingman plugin for Haskell Language Server
66
description: Please see README.md
77
author: Sandy Maguire, Reed Mullanix
88
maintainer: sandy@sandymaguire.me
99
copyright: Sandy Maguire, Reed Mullanix
10+
homepage: https://haskellwingman.dev
11+
bug-reports: https://github.com/haskell/haskell-language-server/issues
1012
license: Apache-2.0
1113
license-file: LICENSE
1214
build-type: Simple
13-
-- extra-source-files:
14-
-- README.md
15+
extra-source-files:
16+
README.md
1517
-- ChangeLog.md
1618

1719
flag pedantic

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import Data.Aeson
2323
import Data.Bifunctor (Bifunctor (bimap))
2424
import Data.Bool (bool)
2525
import Data.Data (Data)
26+
import Data.Foldable (for_)
2627
import Data.Generics.Aliases (mkQ)
2728
import Data.Generics.Schemes (everything)
2829
import Data.Maybe
@@ -144,6 +145,7 @@ mkWorkspaceEdits
144145
-> RunTacticResults
145146
-> Either ResponseError (Maybe WorkspaceEdit)
146147
mkWorkspaceEdits span dflags ccs uri pm rtr = do
148+
for_ (rtr_other_solns rtr) $ traceMX "other solution"
147149
let g = graftHole (RealSrcSpan span) rtr
148150
response = transform dflags ccs uri g pm
149151
in case response of

0 commit comments

Comments
 (0)