diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index ca745abd68..0a2dd198b5 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -247,6 +247,12 @@ jobs: name: Test hls-retrie-plugin test suite run: cabal test hls-retrie-plugin --test-options="$TEST_OPTS" || cabal test hls-retrie-plugin --test-options="$TEST_OPTS" + - if: matrix.test && matrix.ghc != '8.10.7' && matrix.ghc != '9.0.2' + name: Test hls-overloaded-record-dot-plugin test suite + run: cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS" + + + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/CODEOWNERS b/CODEOWNERS index a48cb33c4c..a56a15c614 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -33,6 +33,7 @@ /plugins/hls-tactics-plugin @isovector /plugins/hls-stan-plugin @uhbif19 /plugins/hls-explicit-record-fields-plugin @ozkutuk +/plugins/hls-overloaded-record-dot-plugin @joyfulmantis # Benchmarking /shake-bench @pepeiborra diff --git a/cabal.project b/cabal.project index 74b62a5d73..e5f7be6b40 100644 --- a/cabal.project +++ b/cabal.project @@ -36,6 +36,7 @@ packages: ./plugins/hls-explicit-fixity-plugin ./plugins/hls-explicit-record-fields-plugin ./plugins/hls-refactor-plugin + ./plugins/hls-overloaded-record-dot-plugin -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script diff --git a/docs/features.md b/docs/features.md index b74ec7a1da..e15853a9ae 100644 --- a/docs/features.md +++ b/docs/features.md @@ -398,6 +398,15 @@ Known limitations: - Cross-module renaming requires all components to be indexed, which sometimes causes [partial renames in multi-component projects](https://github.com/haskell/haskell-language-server/issues/2193). +### Rewrite to overloaded record syntax + +Provided by: `hls-overloaded-record-dot-plugin` + +Code action kind: `refactor.rewrite` + +Rewrites record selectors to use overloaded dot syntax + +![Explicit Wildcard Demo](../plugins/hls-overloaded-record-dot-plugin/example.gif) ## Missing features The following features are supported by the LSP specification but not implemented in HLS. diff --git a/docs/support/plugin-support.md b/docs/support/plugin-support.md index ed36c9bd45..f675c52138 100644 --- a/docs/support/plugin-support.md +++ b/docs/support/plugin-support.md @@ -63,6 +63,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has | `hls-refine-imports-plugin` | 2 | | | `hls-stylish-haskell-plugin` | 2 | 9.6 | | `hls-tactics-plugin` | 2 | 9.2, 9.4, 9.6 | +| `hls-overloaded-recrod-dot-plugin` | 2 | 8.10, 9.0 | | `hls-haddock-comments-plugin` | 3 | 9.2, 9.4, 9.6 | | `hls-stan-plugin` | 3 | 8.6, 9.0, 9.2, 9.4, 9.6 | | `hls-retrie-plugin` | 3 | | diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 563a10b5eb..b9d1646386 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -236,3 +236,9 @@ instance NFData NodeKey where instance NFData HomeModLinkable where rnf = rwhnf #endif + +instance NFData (HsExpr (GhcPass 'Renamed)) where + rnf = rwhnf + +instance NFData Extension where + rnf = rwhnf diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3b5b7522ec..ec8d4f8e67 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -174,6 +174,11 @@ flag explicitFields default: True manual: True +flag overloadedRecordDot + description: Enable overloadedRecordDot plugin + default: True + manual: True + -- formatters flag floskell @@ -326,10 +331,15 @@ common explicitFields build-depends: hls-explicit-record-fields-plugin == 2.0.0.0 cpp-options: -DexplicitFields +common overloadedRecordDot + if flag(overloadedRecordDot) && (impl(ghc >= 9.2.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-overloaded-record-dot-plugin == 2.0.0.0 + cpp-options: -Dhls_overloaded_record_dot + -- formatters common floskell - if flag(floskell) && impl(ghc < 9.5) + if flag(floskell) && impl(ghc < 9.5) build-depends: hls-floskell-plugin == 2.0.0.0 cpp-options: -Dhls_floskell @@ -387,6 +397,7 @@ library , ormolu , stylishHaskell , refactor + , overloadedRecordDot exposed-modules: Ide.Arguments 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 index 12a0791b6c..7600daa671 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -22,8 +22,8 @@ import Data.Functor ((<&>)) import Data.Generics (GenericQ, everything, extQ, mkQ) import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (isJust, listToMaybe, - maybeToList, fromMaybe) +import Data.Maybe (fromMaybe, isJust, + listToMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), @@ -36,8 +36,8 @@ 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, getLoc, unLoc, - recDotDot) + Outputable, getLoc, recDotDot, + unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), GhcPass, HsExpr (RecordCon, rcon_flds), @@ -103,7 +103,7 @@ 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 + CRR recMap exts <- collectRecords' ideState nfp let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) pure $ List actions @@ -160,8 +160,8 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect pure ([], CRR <$> recMap <*> Just exts) where - getEnabledExtensions :: TcModuleResult -> [GhcExtension] - getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed + getEnabledExtensions :: TcModuleResult -> [Extension] + getEnabledExtensions = getExtensions . tmrParsed getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = @@ -186,7 +186,7 @@ instance NFData CollectRecords data CollectRecordsResult = CRR { recordInfos :: RangeMap RenderedRecordInfo - , enabledExtensions :: [GhcExtension] + , enabledExtensions :: [Extension] } deriving (Generic) @@ -213,15 +213,8 @@ instance Show CollectNamesResult where type instance RuleResult CollectNames = CollectNamesResult --- `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` () - -- As with `GhcExtension`, this newtype exists mostly to attach --- an `NFData` instance to `UniqFM`. +-- an `NFData` instance to `UniqFM`.(without resorting to creating an orphan instance). newtype NameMap = NameMap (UniqFM Name [Name]) instance NFData NameMap where diff --git a/plugins/hls-overloaded-record-dot-plugin/CHANGELOG.md b/plugins/hls-overloaded-record-dot-plugin/CHANGELOG.md new file mode 100644 index 0000000000..6179d5a570 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hls-overloaded-record-dot-plugin + +## 1.0.0.0 -- 2023-04-16 + +* First version. diff --git a/plugins/hls-overloaded-record-dot-plugin/LICENSE b/plugins/hls-overloaded-record-dot-plugin/LICENSE new file mode 100644 index 0000000000..16590f45c8 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Nathan Maxson + +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 Nathan Maxson 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-overloaded-record-dot-plugin/README.md b/plugins/hls-overloaded-record-dot-plugin/README.md new file mode 100644 index 0000000000..7b15d09911 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/README.md @@ -0,0 +1,18 @@ +# Explicit Record Fields Plugin + +`hls-overloaded-record-dot-plugin` is a plugin to convert record selectors to record dot syntax in GHC 9.2 and above. + + +## Demo + +![Convert Record Selector Demo](example.gif) + + +## Known limitations + +hls-overloaded-record-dot-plugin currently only converts record selectors to the record dot syntax, and will not help you convert your record updaters to overloaded record update syntax. + + +## Change log +### 1.0.0.0 +- Release diff --git a/plugins/hls-overloaded-record-dot-plugin/example.gif b/plugins/hls-overloaded-record-dot-plugin/example.gif new file mode 100644 index 0000000000..e0fbd192bb Binary files /dev/null and b/plugins/hls-overloaded-record-dot-plugin/example.gif differ diff --git a/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal b/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal new file mode 100644 index 0000000000..d39f780614 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal @@ -0,0 +1,65 @@ +cabal-version: 3.0 +name: hls-overloaded-record-dot-plugin +version: 2.0.0.0 +synopsis: Overloaded record dot plugin for Haskell Language Server +description: + Please see the README on GitHub at +license: BSD-3-Clause +license-file: LICENSE +author: Nathan Maxson +maintainer: joyfulmantis@gmail.com +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md +extra-source-files: + test/testdata/**/*.hs + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +common warnings + ghc-options: -Wall + +library + if impl(ghc < 9.2) + buildable: False + else + buildable: True + import: warnings + exposed-modules: Ide.Plugin.OverloadedRecordDot + build-depends: + , base >=4.16 && <5 + , ghcide + , hls-plugin-api + , lsp + , lens + , hls-graph + , text + , syb + , transformers + , ghc-boot-th + , unordered-containers + , containers + , deepseq + hs-source-dirs: src + default-language: GHC2021 + +test-suite tests + if impl(ghc < 9.2) + buildable: False + else + buildable: True + import: warnings + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base + , filepath + , text + , hls-overloaded-record-dot-plugin + , lsp-test + , hls-test-utils + diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs new file mode 100644 index 0000000000..0fa03b7b31 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.OverloadedRecordDot + ( descriptor + , Log + ) where + +-- based off of Berk Okzuturk's hls-explicit-records-fields-plugin + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Generics (GenericQ, everything, + everythingBut, mkQ) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (mapMaybe, maybeToList) +import Data.Text (Text) +import Development.IDE (IdeState, + NormalizedFilePath, + Pretty (..), Range, + Recorder (..), Rules, + WithPriority (..), + realSrcSpanToRange) +import Development.IDE.Core.Rules (runAction) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import Development.IDE.Core.Shake (define, use, + useWithStale) +import qualified Development.IDE.Core.Shake as Shake + +#if __GLASGOW_HASKELL__ >= 903 +import Development.IDE.GHC.Compat (HsExpr (HsRecSel)) +#else +import Development.IDE.GHC.Compat (HsExpr (HsRecFld)) +#endif + +import Control.DeepSeq (rwhnf) +import Development.IDE.Core.PositionMapping (PositionMapping (PositionMapping), + toCurrentRange) +import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), + GhcPass, + HsExpansion (HsExpanded), + HsExpr (HsApp, HsPar, HsVar, OpApp, XExpr), + LHsExpr, Outputable, + Pass (..), RealSrcSpan, + appPrec, dollarName, + getLoc, hs_valds, + parenthesizeHsContext, + parenthesizeHsExpr, + pattern RealSrcSpan, + unLoc) +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 Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +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 (..), + SMethod (..), + TextEdit (..), + WorkspaceEdit (WorkspaceEdit), + fromNormalizedUri, + normalizedFilePathToUri, + type (|?) (InR)) +import qualified Language.LSP.Types.Lens as L +data Log + = LogShake Shake.Log + | LogCollectedRecordSelectors [RecordSelectorExpr] + | LogTextEdits [TextEdit] + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogCollectedRecordSelectors recs -> "Collected record selectors:" + <+> pretty recs + +data CollectRecordSelectors = CollectRecordSelectors + deriving (Eq, Show, Generic) + +instance Hashable CollectRecordSelectors +instance NFData CollectRecordSelectors + +data CollectRecordSelectorsResult = CRSR + { recordInfos :: RangeMap RecordSelectorExpr + , enabledExtensions :: [Extension] + } + deriving (Generic) + +instance NFData CollectRecordSelectorsResult + +instance Show CollectRecordSelectorsResult where + show _ = "" + +type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult + +-- |Where we store our collected record selectors +data RecordSelectorExpr = RecordSelectorExpr + { -- |The location of the matched expression + location :: Range, + -- |The record selector, this is found in front of recordExpr, but get's + -- placed after it when converted into record dot syntax + selectorExpr :: LHsExpr (GhcPass 'Renamed), + -- |The record expression. The only requirement is that it evaluates to a + -- record in the end + recordExpr :: LHsExpr (GhcPass 'Renamed) } + +instance Pretty RecordSelectorExpr where + pretty (RecordSelectorExpr l rs se) = pretty (printOutputable rs) <> ":" + <+> pretty (printOutputable se) + +instance NFData RecordSelectorExpr where + rnf = rwhnf + +descriptor :: Recorder (WithPriority Log) -> PluginId + -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginHandlers = + mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginRules = collectRecSelsRule recorder + } + +codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = + pluginResponse $ do + nfp <- getNormalizedFilePath (caDocId ^. L.uri) + pragma <- getFirstPragma pId ideState nfp + CRSR crsMap exts <- collectRecSelResult ideState nfp + let pragmaEdit = + if OverloadedRecordDot `elem` exts + then Nothing + else Just $ insertNewPragma pragma OverloadedRecordDot + edits crs = convertRecordSelectors crs : maybeToList pragmaEdit + changes crs = + Just $ HashMap.singleton (fromNormalizedUri + (normalizedFilePathToUri nfp)) + (List (edits crs)) + mkCodeAction crs = InR CodeAction + { -- We pass the record selector to the title function, so that + -- we can have the name of the record selector in the title of + -- the codeAction. This allows the user can easily distinguish + -- between the different codeActions when using nested record + -- selectors, the disadvantage is we need to print out the + -- name of the record selector which will decrease performance + _title = mkCodeActionTitle exts crs + , _kind = Just CodeActionRefactorRewrite + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing + , _command = Nothing + , _xdata = Nothing + } + actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap) + pure $ List actions + where + mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text + mkCodeActionTitle exts (RecordSelectorExpr _ se _) = + if OverloadedRecordDot `elem` exts + then title + else title <> " (needs extension: OverloadedRecordDot)" + where + title = "Convert `" <> name <> "` to record dot syntax" + name = printOutputable se + +collectRecSelsRule :: Recorder (WithPriority Log) -> Rules () +collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ + \CollectRecordSelectors nfp -> + useWithStale TypeCheck nfp >>= \case + -- `useWithStale` here allows us to be able to return codeActions even + -- if the file does not typecheck. The disadvantage being that we + -- sometimes will end up corrupting code. This is most obvious in that + -- used code actions will continue to be presented, and when applied + -- multiple times will almost always cause code corruption. + Nothing -> pure ([], Nothing) + Just (tmr, pm) -> do + let -- We need the file's extensions to check whether we need to add + -- the OverloadedRecordDot pragma + exts = getEnabledExtensions tmr + recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr) + logWith recorder Debug (LogCollectedRecordSelectors recSels) + let -- We need the rangeMap to be able to filter by range later + crsMap :: RangeMap RecordSelectorExpr + crsMap = RangeMap.fromList location recSels + pure ([], CRSR <$> Just crsMap <*> Just exts) + where getEnabledExtensions :: TcModuleResult -> [Extension] + getEnabledExtensions = getExtensions . tmrParsed + getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr] + getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = + collectRecordSelectors valBinds + rewriteRange :: PositionMapping -> RecordSelectorExpr + -> Maybe RecordSelectorExpr + rewriteRange pm recSel = + case toCurrentRange pm (location recSel) of + Just newLoc -> Just $ recSel{location = newLoc} + Nothing -> Nothing + +convertRecordSelectors :: RecordSelectorExpr -> TextEdit +convertRecordSelectors (RecordSelectorExpr l se re) = + TextEdit l $ convertRecSel se re + +-- |Converts a record selector expression into record dot syntax, currently we +-- are using printOutputable to do it. We are also letting GHC decide when to +-- parenthesize the record expression +convertRecSel :: Outputable (LHsExpr (GhcPass 'Renamed)) + => LHsExpr (GhcPass 'Renamed) + -> LHsExpr (GhcPass 'Renamed) -> Text +convertRecSel se re = printOutputable (parenthesizeHsExpr appPrec re) <> "." + <> printOutputable se + +collectRecordSelectors :: GenericQ [RecordSelectorExpr] +-- It's important that we use everthingBut here, because if we used everything +-- we would get duplicates for every case that occurs inside a HsExpanded +-- expression. Please see the test MultilineExpanded.hs +collectRecordSelectors = everythingBut (<>) (([], False) `mkQ` getRecSels) + +-- |We want to return a list here, because on the occasion that we encounter a +-- HsExpanded expression, we want to return all the results from recursing on +-- one branch, which could be multiple matches. Again see MultilineExpanded.hs +getRecSels :: LHsExpr (GhcPass 'Renamed) -> ([RecordSelectorExpr], Bool) +-- When we stumble upon an occurrence of HsExpanded, we only want to follow one +-- branch. We do this here, by explicitly returning occurrences from traversing +-- the original branch, and returning True, which keeps syb from implicitly +-- continuing to traverse. +getRecSels (unLoc -> XExpr (HsExpanded a _)) = (collectRecordSelectors a, True) +#if __GLASGOW_HASKELL__ >= 903 +-- applied record selection: "selector record" or "selector (record)" or +-- "selector selector2.record2" +getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecSel _ _) re) = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +-- Record selection where the field is being applied with the "$" operator: +-- "selector $ record" +getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _) + (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +#else +getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecFld _ _) re) = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _) + (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +#endif +getRecSels _ = ([], False) + +collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath + -> ExceptT String m CollectRecordSelectorsResult +collectRecSelResult ideState = + handleMaybeM "Unable to TypeCheck" + . liftIO + . runAction "overloadedRecordDot.collectRecordSelectors" ideState + . use CollectRecordSelectors + diff --git a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs new file mode 100644 index 0000000000..7780c83acd --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs @@ -0,0 +1,57 @@ +{-# 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.OverloadedRecordDot as OverloadedRecordDot +import System.FilePath (()) +import Test.Hls + + +main :: IO () +main = defaultTestRunner test + +plugin :: PluginTestDescriptor OverloadedRecordDot.Log +plugin = mkPluginTestDescriptor OverloadedRecordDot.descriptor "overloaded-record-dot" + +test :: TestTree +test = testGroup "overloaded-record-dot" + [ mkTest "Simple" "Simple" "name" 10 7 10 15, + mkTest "NoPragmaNeeded" "NoPragmaNeeded" "name" 11 7 11 15, + mkTest "NestedParens" "NestedParens" "name" 15 7 15 24, + mkTest "NestedDot" "NestedDot" "name" 17 7 17 22, + mkTest "NestedDollar" "NestedDollar" "name" 15 7 15 24, + mkTest "MultilineCase" "MultilineCase" "name" 10 7 12 15, + mkTest "Multiline" "Multiline" "name" 10 7 11 15, + mkTest "MultilineExpanded" "MultilineExpanded" "owner" 28 8 28 19 + ] + +mkTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTest title fp selectorName x1 y1 x2 y2 = + goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do + (act:_) <- getExplicitFieldsActions doc selectorName x1 y1 x2 y2 + executeCodeAction act + +getExplicitFieldsActions + :: TextDocumentIdentifier + -> T.Text + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getExplicitFieldsActions doc selectorName x1 y1 x2 y2 = + findExplicitFieldsAction selectorName <$> getCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +findExplicitFieldsAction :: T.Text -> [a |? CodeAction] -> [CodeAction] +findExplicitFieldsAction selectorName = filter (isExplicitFieldsCodeAction selectorName) . rights . map toEither + +isExplicitFieldsCodeAction :: T.Text -> CodeAction -> Bool +isExplicitFieldsCodeAction selectorName CodeAction {_title} = + ("Convert `" <> selectorName <> "` to record dot syntax") `T.isPrefixOf` _title + +testDataDir :: FilePath +testDataDir = "test" "testdata" diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs new file mode 100644 index 0000000000..f046bb0f35 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = man.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs new file mode 100644 index 0000000000..f9a6400ac6 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Multiline.hs @@ -0,0 +1,12 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name + man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs new file mode 100644 index 0000000000..5508aacb92 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = (case True of + True -> man + False -> man).name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs new file mode 100644 index 0000000000..4659858f89 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineCase.hs @@ -0,0 +1,13 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name $ case True of + True -> man + False -> man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs new file mode 100644 index 0000000000..0c1b9b4de8 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.expected.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +home2 :: Building +home2 = Building {address = "No. 6 Beach Ave.", owner = man} + +home3 :: Building +home3 = Building {address = "No. 12 Central Blvd.", owner = man} + +n:: Int +n = 3 + +test :: String +test = (case n of + 0 -> owner home + 1 -> home2.owner + 2 -> owner home3 + _ -> man).name + diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs new file mode 100644 index 0000000000..e9fc606f2b --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/MultilineExpanded.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +home2 :: Building +home2 = Building {address = "No. 6 Beach Ave.", owner = man} + +home3 :: Building +home3 = Building {address = "No. 12 Central Blvd.", owner = man} + +n:: Int +n = 3 + +test :: String +test = (case n of + 0 -> owner home + 1 -> owner home2 + 2 -> owner home3 + _ -> man).name + diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs new file mode 100644 index 0000000000..fa15181d2f --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = (owner home).name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs new file mode 100644 index 0000000000..cbd47da8bc --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDollar.hs @@ -0,0 +1,16 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = name $ owner home diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs new file mode 100644 index 0000000000..2022eacc20 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = home.owner.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs new file mode 100644 index 0000000000..c25922fb6f --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedDot.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = name home.owner diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs new file mode 100644 index 0000000000..fa15181d2f --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = (owner home).name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs new file mode 100644 index 0000000000..578ffd9a6c --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NestedParens.hs @@ -0,0 +1,16 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +data Building = Building {address :: String, owner :: Happy} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +home :: Building +home = Building {address = "No. 10 Privet Dr.", owner = man} + +test :: String +test = name (owner home) diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs new file mode 100644 index 0000000000..f046bb0f35 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = man.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs new file mode 100644 index 0000000000..9f88a03775 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/NoPragmaNeeded.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name man diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs new file mode 100644 index 0000000000..f046bb0f35 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedRecordDot #-} +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = man.name diff --git a/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs new file mode 100644 index 0000000000..40fd5a71e1 --- /dev/null +++ b/plugins/hls-overloaded-record-dot-plugin/test/testdata/Simple.hs @@ -0,0 +1,11 @@ +data Happy = Happy {name :: String, age :: Int, happy :: Bool} + +main :: IO () +main = do + putStrLn test + +man :: Happy +man = Happy {name = "Happy", age = 1, happy = True} + +test :: String +test = name man diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index f341208bfb..06b4c26bad 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -100,6 +100,10 @@ import qualified Ide.Plugin.ExplicitFixity as ExplicitFixity import qualified Ide.Plugin.ExplicitFields as ExplicitFields #endif +#if hls_overloaded_record_dot +import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot +#endif + -- formatters #if hls_floskell @@ -226,11 +230,14 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "ghcide-code-actions-fill-holes" in Refactor.fillHolePluginDescriptor (pluginRecorder pId) pId : let pId = "ghcide-extend-import-action" in Refactor.extendImportPluginDescriptor (pluginRecorder pId) pId : #endif - GhcIde.descriptors (pluginRecorder "ghcide") #if explicitFixity - ++ [let pId = "explicit-fixity" in ExplicitFixity.descriptor (pluginRecorder pId) pId] + let pId = "explicit-fixity" in ExplicitFixity.descriptor (pluginRecorder pId) pId : #endif #if explicitFields - ++ [let pId = "explicit-fields" in ExplicitFields.descriptor (pluginRecorder pId) pId] + let pId = "explicit-fields" in ExplicitFields.descriptor (pluginRecorder pId) pId : #endif +#if hls_overloaded_record_dot + let pId = "overloaded-record-dot" in OverloadedRecordDot.descriptor (pluginRecorder pId) pId : +#endif + GhcIde.descriptors (pluginRecorder "ghcide") diff --git a/stack.yaml b/stack.yaml index ff511b03f9..8ec367da08 100644 --- a/stack.yaml +++ b/stack.yaml @@ -36,6 +36,7 @@ packages: - ./plugins/hls-explicit-fixity-plugin - ./plugins/hls-refactor-plugin - ./plugins/hls-explicit-record-fields-plugin +- ./plugins/hls-overloaded-record-dot-plugin extra-deps: # needed for tests of hls-cabal-fmt-plugin