diff --git a/hls-overloaded-record-dot-plugin.cabal b/hls-overloaded-record-dot-plugin.cabal --- a/hls-overloaded-record-dot-plugin.cabal +++ b/hls-overloaded-record-dot-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-overloaded-record-dot-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Overloaded record dot plugin for Haskell Language Server description: Please see the README on GitHub at @@ -30,6 +30,7 @@ exposed-modules: Ide.Plugin.OverloadedRecordDot build-depends: , base >=4.16 && <5 + , aeson , ghcide , hls-plugin-api , lsp @@ -58,8 +59,13 @@ build-depends: , base , filepath + , ghcide , text , hls-overloaded-record-dot-plugin + , hls-plugin-api + , lens , lsp-test + , lsp-types + , row-types , hls-test-utils diff --git a/src/Ide/Plugin/OverloadedRecordDot.hs b/src/Ide/Plugin/OverloadedRecordDot.hs --- a/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/src/Ide/Plugin/OverloadedRecordDot.hs @@ -3,9 +3,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} - module Ide.Plugin.OverloadedRecordDot ( descriptor , Log @@ -14,24 +14,26 @@ -- based off of Berk Okzuturk's hls-explicit-records-fields-plugin import Control.Lens ((^.)) +import Control.Monad (replicateM) 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.Aeson (FromJSON, ToJSON, toJSON) +import Data.Generics (GenericQ, everythingBut, + mkQ) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map import Data.Maybe (mapMaybe, maybeToList) import Data.Text (Text) +import Data.Unique (hashUnique, newUnique) 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 Development.IDE.Core.Shake (define, useWithStale) import qualified Development.IDE.Core.Shake as Shake #if __GLASGOW_HASKELL__ >= 903 @@ -41,17 +43,17 @@ #endif import Control.DeepSeq (rwhnf) -import Development.IDE.Core.PositionMapping (PositionMapping (PositionMapping), +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), GhcPass, HsExpansion (HsExpanded), - HsExpr (HsApp, HsPar, HsVar, OpApp, XExpr), + HsExpr (HsApp, HsVar, OpApp, XExpr), LHsExpr, Outputable, - Pass (..), RealSrcSpan, - appPrec, dollarName, - getLoc, hs_valds, - parenthesizeHsContext, + Pass (..), appPrec, + dollarName, getLoc, + hs_valds, parenthesizeHsExpr, pattern RealSrcSpan, unLoc) @@ -62,42 +64,41 @@ import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) -import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError (..), + getNormalizedFilePathE, + handleMaybe) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, - pluginResponse) +import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Types (CodeAction (..), - CodeActionKind (CodeActionRefactorRewrite), + ResolveFunction, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), - Command, List (..), - Method (..), - SMethod (..), - TextEdit (..), - WorkspaceEdit (WorkspaceEdit), - fromNormalizedUri, - normalizedFilePathToUri, - type (|?) (InR)) -import qualified Language.LSP.Types.Lens as L + TextEdit (..), Uri (..), + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (..)) + data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] - | LogTextEdits [TextEdit] + | forall a. (Pretty a) => LogResolve a instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecordSelectors recs -> "Collected record selectors:" <+> pretty recs + LogResolve msg -> pretty msg data CollectRecordSelectors = CollectRecordSelectors deriving (Eq, Show, Generic) @@ -106,7 +107,14 @@ instance NFData CollectRecordSelectors data CollectRecordSelectorsResult = CRSR - { recordInfos :: RangeMap RecordSelectorExpr + { -- |We store everything in here that we need to create the unresolved + -- codeAction: the range, an uniquely identifiable int, and the selector + --selector expression (HSExpr) that we use to generate the name + records :: RangeMap (Int, HsExpr (GhcPass 'Renamed)) + -- |This is for when we need to fully generate a textEdit. It contains the + -- whole expression we are interested in indexed to the unique id we got + -- from the previous field + , recordInfos :: IntMap.IntMap RecordSelectorExpr , enabledExtensions :: [Extension] } deriving (Generic) @@ -130,63 +138,86 @@ recordExpr :: LHsExpr (GhcPass 'Renamed) } instance Pretty RecordSelectorExpr where - pretty (RecordSelectorExpr l rs se) = pretty (printOutputable rs) <> ":" + pretty (RecordSelectorExpr _ rs se) = pretty (printOutputable rs) <> ":" <+> pretty (printOutputable se) instance NFData RecordSelectorExpr where rnf = rwhnf +-- |The data that is serialized and placed in the data field of resolvable +-- code actions +data ORDResolveData = ORDRD { + -- |We need the uri to get shake results + uri :: Uri + -- |The unique id that allows us to find the specific codeAction we want +, uniqueID :: Int +} deriving (Generic, Show) +instance ToJSON ORDResolveData +instance FromJSON ORDResolveData + descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = - mkPluginHandler STextDocumentCodeAction codeActionProvider +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + pluginHandler = mkCodeActionHandlerWithResolve resolveRecorder codeActionProvider resolveProvider + in (defaultPluginDescriptor plId) + { pluginHandlers = pluginHandler , 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 +resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve +resolveProvider ideState plId ca uri (ORDRD _ int) = + do + nfp <- getNormalizedFilePathE uri + CRSR _ crsDetails exts <- collectRecSelResult ideState nfp + pragma <- getFirstPragma plId ideState nfp + rse <- handleMaybe PluginStaleResolve $ IntMap.lookup int crsDetails + pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} + +codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionProvider ideState _ (CodeActionParams _ _ caDocId caRange _) = + do + nfp <- getNormalizedFilePathE (caDocId ^. L.uri) + CRSR crsMap _ exts <- collectRecSelResult ideState nfp + let mkCodeAction (crsM, nse) = 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 + _title = mkCodeActionTitle exts nse + , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing - , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing + , _edit = Nothing , _command = Nothing - , _xdata = Nothing + , _data_ = Just $ toJSON $ ORDRD (caDocId ^. L.uri) crsM } actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap) - pure $ List actions + pure $ InL actions where - mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text - mkCodeActionTitle exts (RecordSelectorExpr _ se _) = + mkCodeActionTitle :: [Extension] -> HsExpr (GhcPass 'Renamed) -> Text + mkCodeActionTitle exts se = if OverloadedRecordDot `elem` exts then title else title <> " (needs extension: OverloadedRecordDot)" where - title = "Convert `" <> name <> "` to record dot syntax" - name = printOutputable se + title = "Convert `" <> printOutputable se <> "` to record dot syntax" +mkWorkspaceEdit:: Uri -> RecordSelectorExpr -> [Extension] -> NextPragmaInfo-> Maybe WorkspaceEdit +mkWorkspaceEdit uri recSel exts pragma = + Just $ WorkspaceEdit + { _changes = + Just (Map.singleton uri (convertRecordSelectors recSel : maybeToList pragmaEdit)) + , _documentChanges = Nothing + , _changeAnnotations = Nothing} + where pragmaEdit = + if OverloadedRecordDot `elem` exts + then Nothing + else Just $ insertNewPragma pragma OverloadedRecordDot + collectRecSelsRule :: Recorder (WithPriority Log) -> Rules () collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecordSelectors nfp -> @@ -202,11 +233,17 @@ -- the OverloadedRecordDot pragma exts = getEnabledExtensions tmr recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr) + -- We are creating a list as long as our rec selectors of unique int s + -- created by calling hashUnique on a Unique. The reason why we are + -- extracting the ints is because they don't need any work to serialize. + uniques <- liftIO $ replicateM (length recSels) (hashUnique <$> newUnique) 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) + let crsUniquesAndDetails = zip uniques recSels + -- We need the rangeMap to be able to filter by range later + rangeAndUnique = toRangeAndUnique <$> crsUniquesAndDetails + crsMap :: RangeMap (Int, HsExpr (GhcPass 'Renamed)) + crsMap = RangeMap.fromList' rangeAndUnique + pure ([], CRSR <$> Just crsMap <*> Just (IntMap.fromList crsUniquesAndDetails) <*> Just exts) where getEnabledExtensions :: TcModuleResult -> [Extension] getEnabledExtensions = getExtensions . tmrParsed getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr] @@ -218,10 +255,11 @@ case toCurrentRange pm (location recSel) of Just newLoc -> Just $ recSel{location = newLoc} Nothing -> Nothing + toRangeAndUnique (uid, RecordSelectorExpr l (unLoc -> se) _) = (l, (uid, se)) convertRecordSelectors :: RecordSelectorExpr -> TextEdit -convertRecordSelectors (RecordSelectorExpr l se re) = - TextEdit l $ convertRecSel se re +convertRecordSelectors RecordSelectorExpr{..} = + TextEdit location $ convertRecSel selectorExpr recordExpr -- |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 @@ -271,10 +309,8 @@ getRecSels _ = ([], False) collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath - -> ExceptT String m CollectRecordSelectorsResult + -> ExceptT PluginError m CollectRecordSelectorsResult collectRecSelResult ideState = - handleMaybeM "Unable to TypeCheck" - . liftIO - . runAction "overloadedRecordDot.collectRecordSelectors" ideState - . use CollectRecordSelectors + runActionE "overloadedRecordDot.collectRecordSelectors" ideState + . useE CollectRecordSelectors diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,31 +11,42 @@ import System.FilePath (()) import Test.Hls - main :: IO () -main = defaultTestRunner test +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 "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 :: 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 + [mkNoResolveTest (title <> " without resolve") fp selectorName x1 y1 x2 y2, + mkResolveTest (title <> " with resolve") fp selectorName x1 y1 x2 y2] + +mkNoResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree +mkNoResolveTest title fp selectorName x1 y1 x2 y2 = + goldenWithHaskellAndCaps codeActionNoResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do (act:_) <- getExplicitFieldsActions doc selectorName x1 y1 x2 y2 executeCodeAction act +mkResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree +mkResolveTest title fp selectorName x1 y1 x2 y2 = + goldenWithHaskellAndCaps codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + (act:_) <- getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 + executeCodeAction act + + getExplicitFieldsActions :: TextDocumentIdentifier -> T.Text @@ -43,6 +54,16 @@ -> Session [CodeAction] getExplicitFieldsActions doc selectorName x1 y1 x2 y2 = findExplicitFieldsAction selectorName <$> getCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +getAndResolveExplicitFieldsActions + :: TextDocumentIdentifier + -> T.Text + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 = do + findExplicitFieldsAction selectorName <$> getAndResolveCodeActions doc range where range = Range (Position x1 y1) (Position x2 y2)