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 index 195fad87f5..12884290a0 100644 --- 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 @@ -30,6 +30,7 @@ library exposed-modules: Ide.Plugin.OverloadedRecordDot build-depends: , base >=4.16 && <5 + , aeson , ghcide , hls-plugin-api , lsp @@ -58,8 +59,12 @@ test-suite tests build-depends: , base , filepath + , ghcide , text , hls-overloaded-record-dot-plugin + , lens , lsp-test + , lsp-types + , row-types , 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 index 5dc7ea586b..7a743bcdd5 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -13,16 +13,24 @@ module Ide.Plugin.OverloadedRecordDot -- based off of Berk Okzuturk's hls-explicit-records-fields-plugin -import Control.Lens ((^.)) +import Control.Lens (_Just, (^.), (^?)) +import Control.Monad (replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, throwE) +import Data.Aeson (FromJSON, Result (..), + ToJSON, fromJSON, toJSON) import Data.Generics (GenericQ, everything, everythingBut, mkQ) +import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map -import Data.Maybe (mapMaybe, maybeToList) +import Data.Maybe (fromJust, mapMaybe, + maybeToList) import Data.Text (Text) +import Data.Unique (hashUnique, newUnique) import Development.IDE (IdeState, NormalizedFilePath, + NormalizedUri, Pretty (..), Range, Recorder (..), Rules, WithPriority (..), @@ -75,7 +83,9 @@ import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, defaultPluginDescriptor, + mkCodeActionHandlerWithResolve, mkPluginHandler) +import Language.LSP.Protocol.Lens (HasChanges (changes)) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (Method (..), SMethod (..)) @@ -83,10 +93,12 @@ import Language.LSP.Protocol.Types (CodeAction (..), CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), Command, TextEdit (..), - WorkspaceEdit (WorkspaceEdit), + Uri (..), + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), fromNormalizedUri, normalizedFilePathToUri, type (|?) (..)) +import Language.LSP.Server (getClientCapabilities) data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] @@ -105,7 +117,14 @@ instance Hashable CollectRecordSelectors 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) @@ -135,56 +154,85 @@ instance Pretty RecordSelectorExpr where 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 SMethod_TextDocumentCodeAction codeActionProvider + mkCodeActionHandlerWithResolve codeActionProvider resolveProvider , pluginRules = collectRecSelsRule recorder } +resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve +resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) = + pluginResponse $ do + case fromJSON resData of + Success (ORDRD uri int) -> do + nfp <- getNormalizedFilePath uri + CRSR _ crsDetails exts <- collectRecSelResult ideState nfp + pragma <- getFirstPragma pId ideState nfp + case IntMap.lookup int crsDetails of + Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} + -- We need to throw a content modified error here, see + -- https://github.com/microsoft/language-server-protocol/issues/1738 + -- but we need fendor's plugin error response pr to make it + -- convenient to use here, so we will wait to do that till that's merged + _ -> throwE "Content Modified Error" + _ -> throwE "Unable to deserialize the data" + codeActionProvider :: PluginMethodHandler IdeState 'Method_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 $ Map.singleton (fromNormalizedUri - (normalizedFilePathToUri nfp)) - (edits crs) - mkCodeAction crs = InR CodeAction + CRSR crsMap crsDetails 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 + _title = mkCodeActionTitle exts crsM nse , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing - , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing + , _edit = Nothing , _command = Nothing - , _data_ = Nothing + , _data_ = Just $ toJSON $ ORDRD (caDocId ^. L.uri) crsM } actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap) pure $ InL actions where - mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text - mkCodeActionTitle exts (RecordSelectorExpr _ se _) = + mkCodeActionTitle :: [Extension] -> Int -> HsExpr (GhcPass 'Renamed) -> Text + mkCodeActionTitle exts crsM 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) $ @@ -201,11 +249,17 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ -- 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] @@ -217,6 +271,7 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ case toCurrentRange pm (location recSel) of Just newLoc -> Just $ recSel{location = newLoc} Nothing -> Nothing + toRangeAndUnique (id, RecordSelectorExpr l (unLoc -> se) _) = (l, (id, se)) convertRecordSelectors :: RecordSelectorExpr -> TextEdit convertRecordSelectors (RecordSelectorExpr l se re) = diff --git a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs index 7780c83acd..6015eedcba 100644 --- a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs +++ b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs @@ -5,37 +5,64 @@ module Main ( main ) where +import Control.Lens ((^.)) import Data.Either (rights) +import Data.Functor (void) +import Data.Maybe (isNothing) +import Data.Row import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Development.IDE.Types.Logger (Doc, Logger (Logger), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder) import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot -import System.FilePath (()) +import Language.LSP.Protocol.Lens as L +import System.FilePath ((<.>), ()) import Test.Hls - +import Test.Hls.Util (codeActionNoResolveCaps, + codeActionResolveCaps) 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 :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree + (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 + [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 + ((Right act):_) <- getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 + executeCodeAction act + + getExplicitFieldsActions :: TextDocumentIdentifier -> T.Text @@ -46,6 +73,19 @@ getExplicitFieldsActions doc selectorName x1 y1 x2 y2 = where range = Range (Position x1 y1) (Position x2 y2) +getAndResolveExplicitFieldsActions + :: TextDocumentIdentifier + -> T.Text + -> UInt -> UInt -> UInt -> UInt + -> Session [Either ResponseError CodeAction] +getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 = do + actions <- findExplicitFieldsAction selectorName <$> getCodeActions doc range + rsp <- mapM (request SMethod_CodeActionResolve) (filter (\x -> isNothing (x ^. L.edit)) actions) + pure $ (^. L.result) <$> rsp + + where + range = Range (Position x1 y1) (Position x2 y2) + findExplicitFieldsAction :: T.Text -> [a |? CodeAction] -> [CodeAction] findExplicitFieldsAction selectorName = filter (isExplicitFieldsCodeAction selectorName) . rights . map toEither