diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 6a11cb2edc..6993c86ae6 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -250,6 +250,10 @@ jobs: name: Test hls-explicit-fixity-plugin test suite 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" + - if: matrix.test + name: Test hls-explicit-record-fields-plugin test suite + 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" + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/cabal.project b/cabal.project index 4950a95f3a..6220f564a8 100644 --- a/cabal.project +++ b/cabal.project @@ -33,6 +33,7 @@ packages: ./plugins/hls-stan-plugin ./plugins/hls-gadt-plugin ./plugins/hls-explicit-fixity-plugin + ./plugins/hls-explicit-record-fields-plugin ./plugins/hls-refactor-plugin -- Standard location for temporary packages needed for particular environments @@ -55,6 +56,8 @@ constraints: entropy >= 0.4.1.10, -- For GHC 9.4 basement >= 0.0.15, + -- For GHC 9.4 + hw-prim >= 0.6.3.2, hyphenation +embed, -- remove this when hlint sets ghc-lib to true by default -- https://github.com/ndmitchell/hlint/issues/1376 diff --git a/docs/features.md b/docs/features.md index ef4ae8a88e..efb892b1c9 100644 --- a/docs/features.md +++ b/docs/features.md @@ -291,6 +291,16 @@ Convert a datatype to GADT syntax. ![Link to Docs](../plugins/hls-gadt-plugin/README.md) +### Expand record wildcard + +Provided by: `hls-explicit-record-fields-plugin` + +Code action kind: `refactor.rewrite` + +Expand record wildcards, explicitly listing all record fields as field puns. + +![Explicit Wildcard Demo](../plugins/hls-explicit-record-fields-plugin/wildcard.gif) + ## Code lenses ### Add type signature diff --git a/docs/support/plugin-support.md b/docs/support/plugin-support.md index 4aa8530cf2..5dd9f97aaf 100644 --- a/docs/support/plugin-support.md +++ b/docs/support/plugin-support.md @@ -50,6 +50,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has | `hls-change-type-signature-plugin` | 2 | | | `hls-eval-plugin` | 2 | 9.4 | | `hls-explicit-fixity-plugin` | 2 | | +| `hls-explicit-record-fields-plugin` | 2 | | | `hls-floskell-plugin` | 2 | 9.4 | | `hls-fourmolu-plugin` | 2 | 9.4 | | `hls-gadt-plugin` | 2 | 9.4 | diff --git a/flake.lock b/flake.lock index ec20499ad0..0f74f76d26 100644 --- a/flake.lock +++ b/flake.lock @@ -232,6 +232,18 @@ "url": "https://hackage.haskell.org/package/hlint-3.4/hlint-3.4.tar.gz" } }, + "hw-prim": { + "flake": false, + "locked": { + "narHash": "sha256-++rg/bx4TjWUDyHSWKm/8ITwQLonPRLXHPLlnhJy8ik=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/hw-prim-0.6.3.2/hw-prim-0.6.3.2.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/hw-prim-0.6.3.2/hw-prim-0.6.3.2.tar.gz" + } + }, "implicit-hie-cradle": { "flake": false, "locked": { @@ -340,6 +352,7 @@ "hiedb": "hiedb", "hlint": "hlint", "hlint-34": "hlint-34", + "hw-prim": "hw-prim", "implicit-hie-cradle": "implicit-hie-cradle", "lsp": "lsp", "lsp-test": "lsp-test", diff --git a/flake.nix b/flake.nix index c4873ed9d7..b7f1cb6b06 100644 --- a/flake.nix +++ b/flake.nix @@ -111,6 +111,10 @@ url = "https://hackage.haskell.org/package/hiedb-0.4.2.0/hiedb-0.4.2.0.tar.gz"; flake = false; }; + hw-prim = { + url = "https://hackage.haskell.org/package/hw-prim-0.6.3.2/hw-prim-0.6.3.2.tar.gz"; + flake = false; + }; }; outputs = inputs@{ self, nixpkgs, flake-compat, flake-utils, gitignore, all-cabal-hashes-unpacked, ... }: @@ -182,6 +186,7 @@ entropy = hsuper.callCabal2nix "entropy" inputs.entropy {}; hiedb = hsuper.callCabal2nix "hiedb" inputs.hiedb {}; + hw-prim = hsuper.callCabal2nix "hw-prim" inputs.hw-prim {}; implicit-hie-cradle = hself.callCabal2nix "implicit-hie-cradle" inputs.implicit-hie-cradle {}; ghc-check = hself.callCabal2nix "ghc-check" inputs.ghc-check {}; diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index af5c8c1ace..56579f6130 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -130,6 +130,8 @@ module Development.IDE.GHC.Compat.Core ( ), pattern FunTy, pattern ConPatIn, + conPatDetails, + mapConPatDetail, #if !MIN_VERSION_ghc(9,2,0) Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, #endif @@ -253,6 +255,7 @@ module Development.IDE.GHC.Compat.Core ( SrcLoc.noSrcSpan, SrcLoc.noSrcLoc, SrcLoc.noLoc, + SrcLoc.mapLoc, -- * Finder FindResult(..), mkHomeModLocation, @@ -461,6 +464,18 @@ module Development.IDE.GHC.Compat.Core ( module GHC.Unit.Finder.Types, module GHC.Unit.Env, module GHC.Driver.Phases, +#endif +# if !MIN_VERSION_ghc(9,4,0) + pattern HsFieldBind, + hfbAnn, + hfbLHS, + hfbRHS, + hfbPun, +#endif +#if !MIN_VERSION_ghc_boot_th(9,4,1) + Extension(.., NamedFieldPuns), +#else + Extension(..) #endif ) where @@ -710,12 +725,12 @@ import TcRnMonad hiding (Applicative (..), IORef, allM, anyM, concatMapM, foldrM, mapMaybeM, (<$>)) import TcRnTypes -import TcType +import TcType import qualified TcType import TidyPgm as GHC import qualified TyCoRep import TyCon -import Type +import Type import TysPrim import TysWiredIn import Unify @@ -755,6 +770,11 @@ import qualified GHC.Driver.Finder as GHC import qualified Finder as GHC #endif +-- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. +-- Not the greatest solution, but gets the job done +-- (until the CPP extension is actually needed). +import GHC.LanguageExtensions.Type hiding (Cpp) + mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,3,0) @@ -936,6 +956,25 @@ pattern ConPatIn con args = ConPat NoExtField con args #endif #endif +conPatDetails :: Pat p -> Maybe (HsConPatDetails p) +#if MIN_VERSION_ghc(9,0,0) +conPatDetails (ConPat _ _ args) = Just args +conPatDetails _ = Nothing +#else +conPatDetails (ConPatIn _ args) = Just args +conPatDetails _ = Nothing +#endif + +mapConPatDetail :: (HsConPatDetails p -> Maybe (HsConPatDetails p)) -> Pat p -> Maybe (Pat p) +#if MIN_VERSION_ghc(9,0,0) +mapConPatDetail f pat@(ConPat _ _ args) = (\args' -> pat { pat_args = args'}) <$> f args +mapConPatDetail _ _ = Nothing +#else +mapConPatDetail f (ConPatIn ss args) = ConPatIn ss <$> f args +mapConPatDetail _ _ = Nothing +#endif + + initDynLinker, initObjLinker :: HscEnv -> IO () initDynLinker = #if !MIN_VERSION_ghc(9,0,0) @@ -1101,3 +1140,21 @@ driverNoStop = hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } #endif + +#if !MIN_VERSION_ghc(9,2,0) +match :: HsRecField' id arg -> ((), id, arg, Bool) +match (HsRecField lhs rhs pun) = ((), SrcLoc.unLoc lhs, rhs, pun) + +pattern HsFieldBind :: () -> id -> arg -> Bool -> HsRecField' id arg +pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- (match -> (hfbAnn, hfbLHS, hfbRHS, hfbPun)) where + HsFieldBind _ lhs rhs pun = HsRecField (SrcLoc.noLoc lhs) rhs pun +#elif !MIN_VERSION_ghc(9,4,0) +pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg +pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where + HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun +#endif + +#if !MIN_VERSION_ghc_boot_th(9,4,1) +pattern NamedFieldPuns :: Extension +pattern NamedFieldPuns = RecordPuns +#endif diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 70486f4d74..ca108ebc4d 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -26,10 +26,12 @@ module Development.IDE.GHC.Util( setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - printOutputable + printOutputable, + getExtensions ) where #if MIN_VERSION_ghc(9,2,0) +import GHC.Data.EnumSet import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Env hiding (hscSetFlags) @@ -73,7 +75,7 @@ import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC +import GHC hiding (ParsedModule (..)) import GHC.IO.BufferedIO (BufferedIO) import GHC.IO.Device as IODevice import GHC.IO.Encoding @@ -295,3 +297,6 @@ printOutputable = -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. unescape . T.pack . printWithoutUniques {-# INLINE printOutputable #-} + +getExtensions :: ParsedModule -> [Extension] +getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 02d3db2721..6e00769922 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -6,7 +6,8 @@ module Development.IDE.Spans.Pragmas ( NextPragmaInfo(..) , LineSplitTextEdits(..) , getNextPragmaInfo - , insertNewPragma ) where + , insertNewPragma + , getFirstPragma ) where import Data.Bits (Bits (setBit)) import Data.Function ((&)) @@ -14,11 +15,15 @@ import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as Text -import Development.IDE (srcSpanToRange) +import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import GHC.LanguageExtensions.Type (Extension) import qualified Language.LSP.Types as LSP +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Ide.Types (PluginId(..)) +import qualified Data.Text as T +import Ide.PluginUtils (handleMaybeM) getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText = @@ -31,13 +36,29 @@ getNextPragmaInfo dynFlags sourceText = | otherwise -> NextPragmaInfo 0 Nothing +-- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns` +-- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4 +-- GHC as well, hence the replacement. +-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156 +showExtension :: Extension -> Text +showExtension NamedFieldPuns = "NamedFieldPuns" +showExtension ext = pack (show ext) + insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit -insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" } :: LSP.TextEdit -insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" +insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" } :: LSP.TextEdit +insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" where pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition +getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo +getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do + ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp + (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp + case ghcSession of + Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents + Nothing -> pure Nothing + -- Pre-declaration comments parser ----------------------------------------------------- -- | Each mode represents the "strongest" thing we've seen so far. diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ec62f7cd6d..5c857c2de6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -163,6 +163,11 @@ flag explicitFixity default: True manual: True +flag explicitFields + description: Enable explicitFields plugin + default: True + manual: True + -- formatters flag floskell @@ -300,6 +305,11 @@ common explicitFixity build-depends: hls-explicit-fixity-plugin ^>= 1.0 cpp-options: -DexplicitFixity +common explicitFields + if flag(explicitFields) + build-depends: hls-explicit-record-fields-plugin ^>= 1.0 + cpp-options: -DexplicitFields + -- formatters common floskell @@ -358,6 +368,7 @@ library , codeRange , gadt , explicitFixity + , explicitFields , floskell , fourmolu , ormolu diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index e73afdbd65..f2961d452a 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -2,39 +2,34 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where -import Control.Lens ((^.)) -import Control.Monad.Except (ExceptT, MonadIO, liftIO) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text, unpack) -import qualified Data.Text as T -import Development.IDE (GetParsedModule (GetParsedModule), - GhcSession (GhcSession), - IdeState, RuleResult, Rules, - define, getFileContents, - hscEnv, realSrcSpanToRange, - runAction, use, useWithStale) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat hiding (getSrcSpan) -import Development.IDE.GHC.Compat.Util (toList) -import Development.IDE.Graph.Classes (Hashable, NFData, rnf) -import Development.IDE.Spans.Pragmas (NextPragmaInfo, - getNextPragmaInfo, - insertNewPragma) -import Development.IDE.Types.Logger as Logger -import GHC.Generics (Generic) -import GHC.LanguageExtensions.Type (Extension) -import Ide.Plugin.Conversion (AlternateFormat, - ExtensionNeeded (NeedsExtension, NoExtension), - alternateFormat) +import Control.Lens ((^.)) +import Control.Monad.Except (ExceptT, MonadIO, liftIO) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text, unpack) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + IdeState, RuleResult, Rules, + define, realSrcSpanToRange, + runAction, use) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (getSrcSpan) +import Development.IDE.GHC.Util (getExtensions) +import Development.IDE.Graph.Classes (Hashable, NFData, rnf) +import Development.IDE.Spans.Pragmas (NextPragmaInfo, getFirstPragma, + insertNewPragma) +import Development.IDE.Types.Logger as Logger +import GHC.Generics (Generic) +import Ide.Plugin.Conversion (AlternateFormat, + ExtensionNeeded (NeedsExtension, NoExtension), + alternateFormat) import Ide.Plugin.Literals -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, pluginResponse) +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybeM, pluginResponse) import Ide.Types import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L newtype Log = LogShake Shake.Log deriving Show @@ -75,12 +70,10 @@ collectLiteralsRule :: Recorder (WithPriority Log) -> Rules () collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do pm <- use GetParsedModule nfp -- get the current extensions active and transform them into FormatTypes - let exts = getExtensions <$> pm + let exts = map GhcExtension . getExtensions <$> pm -- collect all the literals for a file lits = collectLiterals . pm_parsed_source <$> pm pure ([], CLR <$> lits <*> exts) - where - getExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do @@ -141,14 +134,6 @@ contains Range {_start, _end} x = isInsideRealSrcSpan _start x || isInsideRealSr isInsideRealSrcSpan :: Position -> RealSrcSpan -> Bool p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p && p <= ep -getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo -getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do - ghcSession <- liftIO $ runAction (unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp - (_, fileContents) <- liftIO $ runAction (unpack pId <> ".GetFileContents") state $ getFileContents nfp - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents - Nothing -> pure Nothing - requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult requestLiterals (PluginId pId) state = handleMaybeM "Could not Collect Literals" . liftIO diff --git a/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs b/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs index 7a61bf9935..b0454e46fb 100644 --- a/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs +++ b/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs @@ -17,7 +17,8 @@ import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T import Development.IDE hiding - (pluginHandlers) + (getExtensions, + pluginHandlers) import qualified Development.IDE.GHC.Compat as GHC hiding (Cpp) import qualified Development.IDE.GHC.Compat.Util as GHC diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs index 920ed228da..1c5deb10e9 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -13,7 +13,6 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.Pragmas (getNextPragmaInfo, insertNewPragma) -import GHC.LanguageExtensions.Type (Extension) import Ide.PluginUtils import Language.LSP.Types @@ -64,6 +63,6 @@ insertPragmaIfNotPresent state nfp pragma = do $ liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state $ use GetParsedModuleWithComments nfp - let exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm + let exts = getExtensions pm info = getNextPragmaInfo sessionDynFlags fileContents pure [insertNewPragma info pragma | pragma `notElem` exts] diff --git a/plugins/hls-explicit-record-fields-plugin/CHANGELOG.md b/plugins/hls-explicit-record-fields-plugin/CHANGELOG.md new file mode 100644 index 0000000000..609eef3bed --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hls-explicit-record-fields-plugin + +## 1.0.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/plugins/hls-explicit-record-fields-plugin/LICENSE b/plugins/hls-explicit-record-fields-plugin/LICENSE new file mode 100644 index 0000000000..00abc29fb4 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Berk Ozkutuk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Berk Ozkutuk nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/plugins/hls-explicit-record-fields-plugin/README.md b/plugins/hls-explicit-record-fields-plugin/README.md new file mode 100644 index 0000000000..d4330c3445 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/README.md @@ -0,0 +1,18 @@ +# Explicit Record Fields Plugin + +`hls-explicit-record-fields-plugin` is a plugin to expand record wildcards, explicitly listing all record fields as field puns. It works in both record construction and pattern binding scenarios, and it works as you would expect regardless of whether there are explicitly provided fields or puns in addition to the wildcard. + + +## Demo + +![Expand Wildcard Demo](wildcard.gif) + + +## Known limitations + +One of the shortcomings of the current approach is that all fields of the record are expanded, whether they are actually used or not. This results in warnings of unused bindings, if the corresponding warning flag is enabled. + + +## Change log +### 1.0.0.0 +- Release diff --git a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal new file mode 100644 index 0000000000..2af84b89fb --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: hls-explicit-record-fields-plugin +version: 1.0.0.0 +synopsis: Explicit record fields plugin for Haskell Language Server +description: + Please see the README on GitHub at +license: BSD-3-Clause +license-file: LICENSE +author: Berk Ozkutuk +maintainer: berk.ozkutuk@tweag.io +-- copyright: +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Ide.Plugin.ExplicitFields + -- other-modules: + -- other-extensions: + build-depends: + , base >=4.12 && <5 + , ghcide ^>=1.7 || ^>=1.8 + , hls-plugin-api ^>=1.4 || ^>=1.5 + , lsp + , lens + , hls-graph + , text + , syb + , transformers + , ghc-boot-th + , unordered-containers + , hw-fingertree + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base + , filepath + , text + , hls-explicit-record-fields-plugin + , lsp-test + , hls-test-utils diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs new file mode 100644 index 0000000000..1a32ae70bb --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.ExplicitFields + ( descriptor + ) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Foldable (foldl') +import Data.Generics (GenericQ, everything, + extQ, mkQ) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (catMaybes, isJust, + mapMaybe, + maybeToList) +import Data.Text (Text) +import Development.IDE (IdeState, + NormalizedFilePath, + Pretty (..), + Range (..), + Recorder (..), Rules, + WithPriority (..), + srcSpanToRange) +import Development.IDE.Core.Rules (runAction) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import Development.IDE.Core.Shake (define, use) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (HsConDetails (RecCon), + HsRecFields (..), + LPat, Outputable, + SrcSpan, getLoc, + unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + GhcPass, + HsExpr (RecordCon, rcon_flds), + LHsExpr, Pass (..), + Pat (..), + conPatDetails, + hfbPun, hs_valds, + mapConPatDetail, + mapLoc) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, + NFData (rnf)) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import Development.IDE.Types.Logger (Priority (..), + cmapWithPrio, + logWith, (<+>)) +import GHC.Generics (Generic) +import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybeM, + pluginResponse) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Types (CodeAction (..), + CodeActionKind (CodeActionRefactorRewrite), + CodeActionParams (..), + Command, List (..), + Method (..), + Position, + SMethod (..), + TextEdit (..), + WorkspaceEdit (WorkspaceEdit), + fromNormalizedUri, + normalizedFilePathToUri, + type (|?) (InR)) +import qualified Language.LSP.Types.Lens as L + + +data Log + = LogShake Shake.Log + | LogCollectedRecords [RecordInfo] + | LogRenderedRecords [RenderedRecordInfo] + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs + LogRenderedRecords recs -> "Rendered records:" <+> pretty recs + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginRules = collectRecordsRule recorder + } + +codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do + nfp <- getNormalizedFilePath (docId ^. L.uri) + pragma <- getFirstPragma pId ideState nfp + CRR recMap (map unExt -> exts) <- collectRecords' ideState nfp + let actions = map (mkCodeAction nfp exts pragma) (filterRecords range recMap) + pure $ List actions + + where + mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction + mkCodeAction nfp exts pragma rec = InR CodeAction + { _title = mkCodeActionTitle exts + , _kind = Just CodeActionRefactorRewrite + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkWorkspaceEdit nfp edits + , _command = Nothing + , _xdata = Nothing + } + where + edits = catMaybes [ mkTextEdit rec , pragmaEdit ] + + mkTextEdit :: RenderedRecordInfo -> Maybe TextEdit + mkTextEdit (RenderedRecordInfo ss r) = TextEdit <$> srcSpanToRange ss <*> pure r + + pragmaEdit :: Maybe TextEdit + pragmaEdit = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns + + mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit + mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing + where + changes = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits) + + mkCodeActionTitle :: [Extension] -> Text + mkCodeActionTitle exts = + if NamedFieldPuns `elem` exts + then title + else title <> " (needs extension: NamedFieldPuns)" + where + title = "Expand record wildcard" + +collectRecordsRule :: Recorder (WithPriority Log) -> Rules () +collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> do + tmr <- use TypeCheck nfp + let exts = getEnabledExtensions <$> tmr + recs = concat $ maybeToList (getRecords <$> tmr) + logWith recorder Debug (LogCollectedRecords recs) + let renderedRecs = traverse renderRecordInfo recs + recMap = buildIntervalMap <$> renderedRecs + logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) + pure ([], CRR <$> recMap <*> exts) + where + getEnabledExtensions :: TcModuleResult -> [GhcExtension] + getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed + +getRecords :: TcModuleResult -> [RecordInfo] +getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = + collectRecords valBinds + +data CollectRecords = CollectRecords + deriving (Eq, Show, Generic) + +instance Hashable CollectRecords +instance NFData CollectRecords + +data CollectRecordsResult = CRR + { recordInfos :: IM.IntervalMap Position RenderedRecordInfo + , enabledExtensions :: [GhcExtension] + } + deriving (Generic) + +instance NFData CollectRecordsResult + +instance Show CollectRecordsResult where + show _ = "" + +type instance RuleResult CollectRecords = CollectRecordsResult + +-- `Extension` is wrapped so that we can provide an `NFData` instance +-- (without resorting to creating an orphan instance). +newtype GhcExtension = GhcExtension { unExt :: Extension } + +instance NFData GhcExtension where + rnf x = x `seq` () + +data RecordInfo + = RecordInfoPat SrcSpan (Pat (GhcPass 'Renamed)) + | RecordInfoCon SrcSpan (HsExpr (GhcPass 'Renamed)) + +instance Pretty RecordInfo where + pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p) + pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) + +data RenderedRecordInfo = RenderedRecordInfo + { renderedSrcSpan :: SrcSpan + , renderedRecord :: Text + } + deriving (Generic) + +instance Pretty RenderedRecordInfo where + pretty (RenderedRecordInfo ss r) = pretty (printOutputable ss) <> ":" <+> pretty r + +instance NFData RenderedRecordInfo + +renderRecordInfo :: RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat pat +renderRecordInfo (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr + +-- We make use of the `Outputable` instances on AST types to pretty-print +-- the renamed and expanded records back into source form, to be substituted +-- with the original record later. However, `Outputable` instance of +-- `HsRecFields` does smart things to print the records that originally had +-- wildcards in their original form (i.e. with dots, without field names), +-- even after the wildcard is removed by the renamer pass. This is undesirable, +-- as we want to print the records in their fully expanded form. +-- Here `rec_dotdot` is set to `Nothing` so that fields are printed without +-- such post-processing. +preprocessRecord :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg +preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } + where + no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be + -- left as is, hence the split. + (no_puns, puns) = splitAt no_pun_count (rec_flds flds) + -- `hsRecPun` is set to `True` in order to pretty-print the fields as field + -- puns (since there is similar mechanism in the `Outputable` instance as + -- explained above). + puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns + rec_flds' = no_puns <> puns' + +showRecordPat :: Outputable (Pat (GhcPass c)) => Pat (GhcPass c) -> Maybe Text +showRecordPat = fmap printOutputable . mapConPatDetail (\case + RecCon flds -> Just $ RecCon (preprocessRecord flds) + _ -> Nothing) + +showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text +showRecordCon expr@(RecordCon _ _ flds) = + Just $ printOutputable $ + expr { rcon_flds = preprocessRecord flds } +showRecordCon _ = Nothing + +collectRecords :: GenericQ [RecordInfo] +collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) + +getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo +getRecCons e@(unLoc -> RecordCon _ _ flds) + | isJust (rec_dotdot flds) = Just $ mkRecInfo e + where + mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> RecordInfo + mkRecInfo expr = RecordInfoCon (getLoc expr) (unLoc expr) +getRecCons _ = Nothing + +getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo +getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) + | isJust (rec_dotdot flds) = Just $ mkRecInfo conPat + where + mkRecInfo :: LPat (GhcPass 'Renamed) -> RecordInfo + mkRecInfo pat = RecordInfoPat (getLoc pat) (unLoc pat) +getRecPatterns _ = Nothing + +collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult +collectRecords' ideState = + handleMaybeM "Unable to TypeCheck" + . liftIO + . runAction "ExplicitFields" ideState + . use CollectRecords + +rangeToInterval :: Range -> IM.Interval Position +rangeToInterval (Range s e) = IM.Interval s e + +buildIntervalMap :: [RenderedRecordInfo] -> IM.IntervalMap Position RenderedRecordInfo +buildIntervalMap recs = toIntervalMap $ mapMaybe (\recInfo -> (,recInfo) <$> srcSpanToInterval (renderedSrcSpan recInfo)) recs + where + toIntervalMap :: Ord v => [(IM.Interval v, a)] -> IM.IntervalMap v a + toIntervalMap = foldl' (\m (i, v) -> IM.insert i v m) IM.empty + + srcSpanToInterval :: SrcSpan -> Maybe (IM.Interval Position) + srcSpanToInterval = fmap rangeToInterval . srcSpanToRange + +filterRecords :: Range -> IM.IntervalMap Position RenderedRecordInfo -> [RenderedRecordInfo] +filterRecords range = map snd . IM.dominators (rangeToInterval range) diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs new file mode 100644 index 0000000000..c31c45223b --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Main ( main ) where + +import Data.Either (rights) +import qualified Data.Text as T +import qualified Ide.Plugin.ExplicitFields as ExplicitFields +import System.FilePath ((<.>), ()) +import Test.Hls + + +main :: IO () +main = defaultTestRunner test + +plugin :: PluginDescriptor IdeState +plugin = ExplicitFields.descriptor mempty "explicit-fields" + +test :: TestTree +test = testGroup "explicit-fields" + [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "WithPun" "WithPun" 13 10 13 25 + , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 + , mkTest "Mixed" "Mixed" 13 10 13 37 + , mkTest "Construction" "Construction" 16 5 16 15 + , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 + , mkTestNoAction "Puns" "Puns" 12 10 12 31 + , mkTestNoAction "Infix" "Infix" 11 11 11 31 + , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + ] + +mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTestNoAction title fp x1 y1 x2 y2 = + testCase title $ + runSessionWithServer plugin (testDataDir "noop") $ do + doc <- openDoc (fp <.> "hs") "haskell" + actions <- getExplicitFieldsActions doc x1 y1 x2 y2 + liftIO $ actions @?= [] + +mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTest title fp x1 y1 x2 y2 = + goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do + (act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 + executeCodeAction act + +getExplicitFieldsActions + :: TextDocumentIdentifier + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getExplicitFieldsActions doc x1 y1 x2 y2 = + findExplicitFieldsAction <$> getCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +findExplicitFieldsAction :: [a |? CodeAction] -> [CodeAction] +findExplicitFieldsAction = filter isExplicitFieldsCodeAction . rights . map toEither + +isExplicitFieldsCodeAction :: CodeAction -> Bool +isExplicitFieldsCodeAction CodeAction {_title} = + "Expand record wildcard" `T.isPrefixOf` _title + +testDataDir :: FilePath +testDataDir = "test" "testdata" diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs new file mode 100644 index 0000000000..d1376c084d --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Construction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let foo = 3 + bar = 5 + baz = 'a' + in MyRec {foo, bar, baz} diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs new file mode 100644 index 0000000000..5e18c66209 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Construction.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module Construction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let foo = 3 + bar = 5 + baz = 'a' + in MyRec {..} diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs new file mode 100644 index 0000000000..93adb44a44 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Mixed where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar = bar', baz} = show foo ++ show bar' ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs new file mode 100644 index 0000000000..810c78eca7 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/Mixed.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Mixed where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar = bar', ..} = show foo ++ show bar' ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs new file mode 100644 index 0000000000..4b196f27fd --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WildcardOnly where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs new file mode 100644 index 0000000000..f339895df4 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WildcardOnly.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module WildcardOnly where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {..} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs new file mode 100644 index 0000000000..fff4d306cf --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WithExplicitBind where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo = foo', bar, baz} = show foo' ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs new file mode 100644 index 0000000000..b416a624f5 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithExplicitBind.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} + +module WithExplicitBind where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo = foo', ..} = show foo' ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs new file mode 100644 index 0000000000..c4285b629b --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WithPun where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs new file mode 100644 index 0000000000..4b34cfa652 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/WithPun.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module WithPun where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, ..} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs new file mode 100644 index 0000000000..de44a8a57d --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/ExplicitBinds.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Haskell2010 #-} + +module ExplicitBinds where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo = foo', bar = bar', baz = baz'} = show foo' ++ show bar' ++ show baz' diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs new file mode 100644 index 0000000000..c361e9f2fd --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Infix.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Haskell2010 #-} + +module Infix where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + } + +convertMe :: MyRec -> String +convertMe (foo' `MyRec` bar') = show foo' ++ show bar' diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs new file mode 100644 index 0000000000..c34ba0a389 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Prefix.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Haskell2010 #-} + +module Prefix where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + } + +convertMe :: MyRec -> String +convertMe (foo' `MyRec` bar') = show foo' ++ show bar' diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs new file mode 100644 index 0000000000..c81e66666d --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/noop/Puns.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Puns where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: MyRec -> String +convertMe MyRec {foo, bar, baz} = show foo ++ show bar ++ show baz diff --git a/plugins/hls-explicit-record-fields-plugin/wildcard.gif b/plugins/hls-explicit-record-fields-plugin/wildcard.gif new file mode 100644 index 0000000000..2cf10d6bf1 Binary files /dev/null and b/plugins/hls-explicit-record-fields-plugin/wildcard.gif differ diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index fe68a74be8..1e7fade456 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -8,30 +8,26 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.GADT (descriptor) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.Except -import Data.Aeson (FromJSON, ToJSON, - Value (Null), toJSON) -import Data.Either.Extra (maybeToEither) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text as T +import Data.Aeson (FromJSON, ToJSON, Value (Null), + toJSON) +import Data.Either.Extra (maybeToEither) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat -import Control.Monad.Trans.Except (throwE) -import Data.Maybe (mapMaybe) -import Development.IDE.GHC.Compat.Util (toList) -import Development.IDE.Spans.Pragmas (NextPragmaInfo, - getNextPragmaInfo, - insertNewPragma) -import GHC.Generics (Generic) -import GHC.LanguageExtensions.Type (Extension (GADTSyntax, GADTs)) +import Control.Monad.Trans.Except (throwE) +import Data.Maybe (mapMaybe) +import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) +import GHC.Generics (Generic) import Ide.Plugin.GHC import Ide.PluginUtils import Ide.Types -import Language.LSP.Server (sendRequest) +import Language.LSP.Server (sendRequest) import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -52,20 +48,20 @@ toGADTSyntaxCommandId = "GADT.toGADT" -- | A command replaces H98 data decl with GADT decl in place toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams -toGADTCommand _ state ToGADTParams{..} = pluginResponse $ do +toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do nfp <- getNormalizedFilePath uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d _ -> throwE $ "Expected 1 declaration, but got " <> show (Prelude.length decls) - deps <- liftIO $ runAction "GADT.GhcSessionDeps" state $ use GhcSessionDeps nfp + deps <- liftIO $ runAction (T.unpack pId' <> ".GhcSessionDeps") state $ use GhcSessionDeps nfp (hsc_dflags . hscEnv -> df) <- liftEither $ maybeToEither "Get GhcSessionDeps failed" deps txt <- liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither $ maybeToEither "Unable to get data decl range" $ srcSpanToRange $ locA ann - pragma <- getNextPragma state nfp + pragma <- getFirstPragma pId state nfp let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ sendRequest @@ -118,14 +114,5 @@ getInRangeH98DeclsAndExts state range nfp = do decls = filter isH98DataDecl $ mapMaybe getDataDecl $ filter (inRange range) hsDecls - exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm + exts = getExtensions pm pure (decls, exts) - --- Copy from hls-alternate-number-format-plugin -getNextPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo -getNextPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do - ghcSession <- liftIO $ runAction "GADT.GhcSession" state $ useWithStale GhcSession nfp - (_, fileContents) <- liftIO $ runAction "GADT.GetFileContents" state $ getFileContents nfp - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents - Nothing -> pure Nothing diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index e1efc2869d..280acf26f8 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -51,7 +51,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable import Development.IDE hiding - (Error) + (Error, + getExtensions) import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments, usePropertyAction) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index d9b11f8786..ee56d75d3b 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -43,7 +43,8 @@ import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake hiding (Log) -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding + (ImplicitPrelude) import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs index 7c675c36f9..a13d7c1a65 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs @@ -21,7 +21,7 @@ import Development.IDE (hscEnv, realSrcSpanToRange) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (empty) +import Development.IDE.GHC.Compat hiding (empty, EmptyCase) import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.LocalBindings (getLocalScope) import Ide.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index 40d6362d94..b5a6521b7e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -16,7 +16,6 @@ import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T import Development.IDE.GHC.Compat -import GHC.LanguageExtensions.Type (Extension (LambdaCase)) import Ide.Types import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..)) import Prelude hiding (span) diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index a1caeef12d..42065aa289 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -10,7 +10,6 @@ module Wingman.StaticPlugin import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes)) import Ide.Types diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 5095a637c0..1aa433fb5d 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -94,6 +94,10 @@ import Ide.Plugin.GADT as GADT import Ide.Plugin.ExplicitFixity as ExplicitFixity #endif +#if explicitFields +import Ide.Plugin.ExplicitFields as ExplicitFields +#endif + -- formatters #if hls_floskell @@ -221,4 +225,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if explicitFixity ++ [let pId = "explicit-fixity" in ExplicitFixity.descriptor (pluginRecorder pId) pId] #endif +#if explicitFields + ++ [let pId = "explicit-fields" in ExplicitFields.descriptor (pluginRecorder pId) pId] +#endif diff --git a/stack-lts19.yaml b/stack-lts19.yaml index af599c2112..88b3024df0 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -34,6 +34,7 @@ packages: - ./plugins/hls-gadt-plugin - ./plugins/hls-explicit-fixity-plugin - ./plugins/hls-refactor-plugin + - ./plugins/hls-explicit-record-fields-plugin ghc-options: "$everything": -haddock diff --git a/stack.yaml b/stack.yaml index 914b0a980b..86b0e67584 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,6 +34,7 @@ packages: - ./plugins/hls-gadt-plugin - ./plugins/hls-explicit-fixity-plugin - ./plugins/hls-refactor-plugin +- ./plugins/hls-explicit-record-fields-plugin extra-deps: - floskell-0.10.6@sha256:e77d194189e8540abe2ace2c7cb8efafc747ca35881a2fefcbd2d40a1292e036,3819