Skip to content

Commit 85f7881

Browse files
ozkutukpepeiborramichaelpj
authored
New plugin: Explicit record fields (#3304)
* Initial working version * Auto-add puns pragma, fix behavior with Hs98 fields * Patch pragma so it adds NamedFieldPuns instead of RecordPuns * Refactor big do block * Make it work with record construction * Convert to a rule based approach * Cleanup, remove dead code * Make it compile with all supported GHC versions * Add tests * Minor code reorganization * Move common pragma logic to same file * Remove strictness annotations * Improve documentation * Use interval map for efficient range filtering * Add external documentation * Add tests to GitHub CI * Add debug log for collected records * Add `getExtensions` to ghcide * Indicate that it doesn't work with GHC 9.4 #3304 (comment) * Relax version bounds on base * Add plugin to stack packages * Add GHC 8.10 support * Fix GHC 9.4 build failure * Make `conPatDetails` total * Revert "Indicate that it doesn't work with GHC 9.4" This reverts commit 57646d3. * Fix unused import caused by new compat exports * Fix ConPat construction in GHC 8.10 * Rename test-suite to make it shorter * Fix nix build by collecting latest hw-prim from Hackage Co-authored-by: Pepe Iborra <[email protected]> Co-authored-by: Michael Peyton Jones <[email protected]>
1 parent 5d56aa7 commit 85f7881

File tree

43 files changed

+854
-85
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

43 files changed

+854
-85
lines changed

‎.github/workflows/test.yml

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -250,6 +250,10 @@ jobs:
250250
name: Test hls-explicit-fixity-plugin test suite
251251
run: cabal test hls-explicit-fixity-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-explicit-fixity-plugin --test-options="$TEST_OPTS"
252252

253+
- if: matrix.test
254+
name: Test hls-explicit-record-fields-plugin test suite
255+
run: cabal test hls-explicit-record-fields-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-explicit-record-fields-plugin --test-options="$TEST_OPTS"
256+
253257
test_post_job:
254258
if: always()
255259
runs-on: ubuntu-latest

‎cabal.project

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ packages:
3333
./plugins/hls-stan-plugin
3434
./plugins/hls-gadt-plugin
3535
./plugins/hls-explicit-fixity-plugin
36+
./plugins/hls-explicit-record-fields-plugin
3637
./plugins/hls-refactor-plugin
3738

3839
-- Standard location for temporary packages needed for particular environments
@@ -55,6 +56,8 @@ constraints:
5556
entropy >= 0.4.1.10,
5657
-- For GHC 9.4
5758
basement >= 0.0.15,
59+
-- For GHC 9.4
60+
hw-prim >= 0.6.3.2,
5861
hyphenation +embed,
5962
-- remove this when hlint sets ghc-lib to true by default
6063
-- https://github.com/ndmitchell/hlint/issues/1376

‎docs/features.md

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -291,6 +291,16 @@ Convert a datatype to GADT syntax.
291291

292292
![Link to Docs](../plugins/hls-gadt-plugin/README.md)
293293

294+
### Expand record wildcard
295+
296+
Provided by: `hls-explicit-record-fields-plugin`
297+
298+
Code action kind: `refactor.rewrite`
299+
300+
Expand record wildcards, explicitly listing all record fields as field puns.
301+
302+
![Explicit Wildcard Demo](../plugins/hls-explicit-record-fields-plugin/wildcard.gif)
303+
294304
## Code lenses
295305

296306
### Add type signature

‎docs/support/plugin-support.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has
5050
| `hls-change-type-signature-plugin` | 2 | |
5151
| `hls-eval-plugin` | 2 | 9.4 |
5252
| `hls-explicit-fixity-plugin` | 2 | |
53+
| `hls-explicit-record-fields-plugin` | 2 | |
5354
| `hls-floskell-plugin` | 2 | 9.4 |
5455
| `hls-fourmolu-plugin` | 2 | 9.4 |
5556
| `hls-gadt-plugin` | 2 | 9.4 |

‎flake.lock

Lines changed: 13 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎flake.nix

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,10 @@
111111
url = "https://hackage.haskell.org/package/hiedb-0.4.2.0/hiedb-0.4.2.0.tar.gz";
112112
flake = false;
113113
};
114+
hw-prim = {
115+
url = "https://hackage.haskell.org/package/hw-prim-0.6.3.2/hw-prim-0.6.3.2.tar.gz";
116+
flake = false;
117+
};
114118
};
115119
outputs =
116120
inputs@{ self, nixpkgs, flake-compat, flake-utils, gitignore, all-cabal-hashes-unpacked, ... }:
@@ -182,6 +186,7 @@
182186

183187
entropy = hsuper.callCabal2nix "entropy" inputs.entropy {};
184188
hiedb = hsuper.callCabal2nix "hiedb" inputs.hiedb {};
189+
hw-prim = hsuper.callCabal2nix "hw-prim" inputs.hw-prim {};
185190

186191
implicit-hie-cradle = hself.callCabal2nix "implicit-hie-cradle" inputs.implicit-hie-cradle {};
187192
ghc-check = hself.callCabal2nix "ghc-check" inputs.ghc-check {};

‎ghcide/src/Development/IDE/GHC/Compat/Core.hs

Lines changed: 59 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -130,6 +130,8 @@ module Development.IDE.GHC.Compat.Core (
130130
),
131131
pattern FunTy,
132132
pattern ConPatIn,
133+
conPatDetails,
134+
mapConPatDetail,
133135
#if !MIN_VERSION_ghc(9,2,0)
134136
Development.IDE.GHC.Compat.Core.splitForAllTyCoVars,
135137
#endif
@@ -253,6 +255,7 @@ module Development.IDE.GHC.Compat.Core (
253255
SrcLoc.noSrcSpan,
254256
SrcLoc.noSrcLoc,
255257
SrcLoc.noLoc,
258+
SrcLoc.mapLoc,
256259
-- * Finder
257260
FindResult(..),
258261
mkHomeModLocation,
@@ -461,6 +464,18 @@ module Development.IDE.GHC.Compat.Core (
461464
module GHC.Unit.Finder.Types,
462465
module GHC.Unit.Env,
463466
module GHC.Driver.Phases,
467+
#endif
468+
# if !MIN_VERSION_ghc(9,4,0)
469+
pattern HsFieldBind,
470+
hfbAnn,
471+
hfbLHS,
472+
hfbRHS,
473+
hfbPun,
474+
#endif
475+
#if !MIN_VERSION_ghc_boot_th(9,4,1)
476+
Extension(.., NamedFieldPuns),
477+
#else
478+
Extension(..)
464479
#endif
465480
) where
466481

@@ -710,12 +725,12 @@ import TcRnMonad hiding (Applicative (..), IORef,
710725
allM, anyM, concatMapM, foldrM,
711726
mapMaybeM, (<$>))
712727
import TcRnTypes
713-
import TcType
728+
import TcType
714729
import qualified TcType
715730
import TidyPgm as GHC
716731
import qualified TyCoRep
717732
import TyCon
718-
import Type
733+
import Type
719734
import TysPrim
720735
import TysWiredIn
721736
import Unify
@@ -755,6 +770,11 @@ import qualified GHC.Driver.Finder as GHC
755770
import qualified Finder as GHC
756771
#endif
757772

773+
-- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it.
774+
-- Not the greatest solution, but gets the job done
775+
-- (until the CPP extension is actually needed).
776+
import GHC.LanguageExtensions.Type hiding (Cpp)
777+
758778

759779
mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation
760780
#if MIN_VERSION_ghc(9,3,0)
@@ -936,6 +956,25 @@ pattern ConPatIn con args = ConPat NoExtField con args
936956
#endif
937957
#endif
938958

959+
conPatDetails :: Pat p -> Maybe (HsConPatDetails p)
960+
#if MIN_VERSION_ghc(9,0,0)
961+
conPatDetails (ConPat _ _ args) = Just args
962+
conPatDetails _ = Nothing
963+
#else
964+
conPatDetails (ConPatIn _ args) = Just args
965+
conPatDetails _ = Nothing
966+
#endif
967+
968+
mapConPatDetail :: (HsConPatDetails p -> Maybe (HsConPatDetails p)) -> Pat p -> Maybe (Pat p)
969+
#if MIN_VERSION_ghc(9,0,0)
970+
mapConPatDetail f pat@(ConPat _ _ args) = (\args' -> pat { pat_args = args'}) <$> f args
971+
mapConPatDetail _ _ = Nothing
972+
#else
973+
mapConPatDetail f (ConPatIn ss args) = ConPatIn ss <$> f args
974+
mapConPatDetail _ _ = Nothing
975+
#endif
976+
977+
939978
initDynLinker, initObjLinker :: HscEnv -> IO ()
940979
initDynLinker =
941980
#if !MIN_VERSION_ghc(9,0,0)
@@ -1101,3 +1140,21 @@ driverNoStop =
11011140
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
11021141
hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) }
11031142
#endif
1143+
1144+
#if !MIN_VERSION_ghc(9,2,0)
1145+
match :: HsRecField' id arg -> ((), id, arg, Bool)
1146+
match (HsRecField lhs rhs pun) = ((), SrcLoc.unLoc lhs, rhs, pun)
1147+
1148+
pattern HsFieldBind :: () -> id -> arg -> Bool -> HsRecField' id arg
1149+
pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- (match -> (hfbAnn, hfbLHS, hfbRHS, hfbPun)) where
1150+
HsFieldBind _ lhs rhs pun = HsRecField (SrcLoc.noLoc lhs) rhs pun
1151+
#elif !MIN_VERSION_ghc(9,4,0)
1152+
pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg
1153+
pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where
1154+
HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun
1155+
#endif
1156+
1157+
#if !MIN_VERSION_ghc_boot_th(9,4,1)
1158+
pattern NamedFieldPuns :: Extension
1159+
pattern NamedFieldPuns = RecordPuns
1160+
#endif

‎ghcide/src/Development/IDE/GHC/Util.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,10 +26,12 @@ module Development.IDE.GHC.Util(
2626
setHieDir,
2727
dontWriteHieFiles,
2828
disableWarningsAsErrors,
29-
printOutputable
29+
printOutputable,
30+
getExtensions
3031
) where
3132

3233
#if MIN_VERSION_ghc(9,2,0)
34+
import GHC.Data.EnumSet
3335
import GHC.Data.FastString
3436
import GHC.Data.StringBuffer
3537
import GHC.Driver.Env hiding (hscSetFlags)
@@ -73,7 +75,7 @@ import Development.IDE.Types.Location
7375
import Foreign.ForeignPtr
7476
import Foreign.Ptr
7577
import Foreign.Storable
76-
import GHC
78+
import GHC hiding (ParsedModule (..))
7779
import GHC.IO.BufferedIO (BufferedIO)
7880
import GHC.IO.Device as IODevice
7981
import GHC.IO.Encoding
@@ -295,3 +297,6 @@ printOutputable =
295297
-- More discussion at https://github.com/haskell/haskell-language-server/issues/3115.
296298
unescape . T.pack . printWithoutUniques
297299
{-# INLINE printOutputable #-}
300+
301+
getExtensions :: ParsedModule -> [Extension]
302+
getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary

‎ghcide/src/Development/IDE/Spans/Pragmas.hs

Lines changed: 26 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -6,19 +6,24 @@ module Development.IDE.Spans.Pragmas
66
( NextPragmaInfo(..)
77
, LineSplitTextEdits(..)
88
, getNextPragmaInfo
9-
, insertNewPragma ) where
9+
, insertNewPragma
10+
, getFirstPragma ) where
1011

1112
import Data.Bits (Bits (setBit))
1213
import Data.Function ((&))
1314
import qualified Data.List as List
1415
import qualified Data.Maybe as Maybe
1516
import Data.Text (Text, pack)
1617
import qualified Data.Text as Text
17-
import Development.IDE (srcSpanToRange)
18+
import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv)
1819
import Development.IDE.GHC.Compat
1920
import Development.IDE.GHC.Compat.Util
20-
import GHC.LanguageExtensions.Type (Extension)
2121
import qualified Language.LSP.Types as LSP
22+
import Control.Monad.IO.Class (MonadIO (..))
23+
import Control.Monad.Trans.Except (ExceptT)
24+
import Ide.Types (PluginId(..))
25+
import qualified Data.Text as T
26+
import Ide.PluginUtils (handleMaybeM)
2227

2328
getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo
2429
getNextPragmaInfo dynFlags sourceText =
@@ -31,13 +36,29 @@ getNextPragmaInfo dynFlags sourceText =
3136
| otherwise
3237
-> NextPragmaInfo 0 Nothing
3338

39+
-- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`
40+
-- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4
41+
-- GHC as well, hence the replacement.
42+
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156
43+
showExtension :: Extension -> Text
44+
showExtension NamedFieldPuns = "NamedFieldPuns"
45+
showExtension ext = pack (show ext)
46+
3447
insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit
35-
insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" } :: LSP.TextEdit
36-
insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n"
48+
insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" } :: LSP.TextEdit
49+
insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n"
3750
where
3851
pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0
3952
pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition
4053

54+
getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
55+
getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do
56+
ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp
57+
(_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp
58+
case ghcSession of
59+
Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents
60+
Nothing -> pure Nothing
61+
4162
-- Pre-declaration comments parser -----------------------------------------------------
4263

4364
-- | Each mode represents the "strongest" thing we've seen so far.

‎haskell-language-server.cabal

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -163,6 +163,11 @@ flag explicitFixity
163163
default: True
164164
manual: True
165165

166+
flag explicitFields
167+
description: Enable explicitFields plugin
168+
default: True
169+
manual: True
170+
166171
-- formatters
167172

168173
flag floskell
@@ -300,6 +305,11 @@ common explicitFixity
300305
build-depends: hls-explicit-fixity-plugin ^>= 1.0
301306
cpp-options: -DexplicitFixity
302307

308+
common explicitFields
309+
if flag(explicitFields)
310+
build-depends: hls-explicit-record-fields-plugin ^>= 1.0
311+
cpp-options: -DexplicitFields
312+
303313
-- formatters
304314

305315
common floskell
@@ -358,6 +368,7 @@ library
358368
, codeRange
359369
, gadt
360370
, explicitFixity
371+
, explicitFields
361372
, floskell
362373
, fourmolu
363374
, ormolu

0 commit comments

Comments
 (0)