Skip to content

Commit

Permalink
Resolve 1: Support for resolve in overloaded-record-dot (#3658)
Browse files Browse the repository at this point in the history 
* resolve for overloaded-record-dot (checkpoint)

* resolve support works on VSCode (tests need to be redone)

* Tests for both resolve and non resolve variants

* Added more tests

* Fix merge mistakes; move function to hls-test-utils

* Remove codeLens resolve
Fix codeActionResolve combine responses

* Don't use partial functions

* Implement michaelpj's suggestions

* Make owned resolve data transparent to the plugins

* Improve ord's resolve handler's error handling

* Oh well, if only we had MonadFail

* Generic support for resolve in hls packages

* Add a new code action resolve helper that falls backs to commands

* add resolve capability set to hls-test-utils

* use caps defined at hls-test-utils

* Add code lens resolve support

* Improve comments

* remove Benchmark as it wasn't that useful and triggered a lsp-test bug

---------

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>
  • Loading branch information
@joyfulmantis @michaelpj
joyfulmantis and michaelpj authored Jun 30, 2023
1 parent 90b18ee commit 6f775e9
Show file tree
Hide file tree
Showing 3 changed files with 144 additions and 44 deletions.
5 changes: 5 additions & 0 deletions plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ library
exposed-modules: Ide.Plugin.OverloadedRecordDot
build-depends:
, base >=4.16 && <5
, aeson
, ghcide
, hls-plugin-api
, lsp
Expand Down Expand Up @@ -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

113 changes: 84 additions & 29 deletions plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..),
Expand Down Expand Up @@ -75,18 +83,22 @@ 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 (..))
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]
Expand All @@ -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)
Expand Down Expand Up @@ -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) $
Expand All @@ -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]
Expand All @@ -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) =
Expand Down
70 changes: 55 additions & 15 deletions plugins/hls-overloaded-record-dot-plugin/test/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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

Expand Down

0 comments on commit 6f775e9

Please sign in to comment.