hls-overloaded-record-dot-plugin 2.0.0.1 → 2.1.0.0

raw patch · 3 files changed

+150/−87 lines, 3 filesdep +aesondep +lsp-typesdep +row-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, lsp-types, row-types

API changes (from Hackage documentation)

Files

• hls-overloaded-record-dot-plugin.cabal +7/−1
• src/Ide/Plugin/OverloadedRecordDot.hs +109/−73
• test/Main.hs +34/−13

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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 

@@ -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 

@@ -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)