Fix #3574 and support resolve in explicit records

ghcide/src/Development/IDE/GHC/Orphans.hs

@@ -23,7 +23,7 @@ import           Data.Text                  (unpack)
 #if !MIN_VERSION_ghc(9,0,0)
 import           Bag
 import           ByteCodeTypes
-import           GhcPlugins
+import           GhcPlugins                 hiding (UniqFM)
 import qualified StringBuffer               as SB
 import           Unique                     (getKey)
 #endif
@@ -252,5 +252,11 @@ instance NFData HomeModLinkable where
 instance NFData (HsExpr (GhcPass Renamed)) where
     rnf = rwhnf
 
+instance NFData (Pat (GhcPass Renamed)) where
+    rnf = rwhnf
+
 instance NFData Extension where
   rnf = rwhnf
+
+instance NFData (UniqFM Name [Name]) where
+  rnf (ufmToIntMap -> m) = rnf m

hls-plugin-api/src/Ide/Plugin/Resolve.hs

@@ -6,6 +6,18 @@
 {-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE RankNTypes               #-}
 {-# LANGUAGE ScopedTypeVariables      #-}
+{-| This module currently includes helper functions to provide fallback support
+to code actions that use resolve in HLS. The difference between the two
+functions for code actions that don't support resolve is that
+mkCodeActionHandlerWithResolve will immediately resolve your code action before
+sending it on to the client, while  mkCodeActionWithResolveAndCommand will turn
+your resolve into a command.
+
+General support for resolve in HLS can be used with mkResolveHandler from
+Ide.Types. Resolve theoretically should allow us to delay computation of parts
+of the request till the client needs it, allowing us to answer requests faster
+and with less resource usage.
+-}
 module Ide.Plugin.Resolve
 (mkCodeActionHandlerWithResolve,
 mkCodeActionWithResolveAndCommand) where

plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal

@@ -19,6 +19,11 @@ source-repository head
   type:     git
   location: https://github.com/haskell/haskell-language-server
 
+flag pedantic
+  description: Enable -Werror
+  default:     False
+  manual:      True
+
 common warnings
     ghc-options: -Wall
 
@@ -29,6 +34,7 @@ library
     -- other-extensions:
     build-depends:
       , base                  >=4.12 && <5
+      , ghc
       , ghcide                == 2.1.0.0
       , hls-plugin-api        == 2.1.0.0
       , lsp
@@ -40,9 +46,14 @@ library
       , ghc-boot-th
       , unordered-containers
       , containers
+      , aeson
     hs-source-dirs:   src
     default-language: Haskell2010
 
+  if flag(pedantic)
+    ghc-options: -Werror
+                 -Wwarn=incomplete-record-updates
+
 test-suite tests
     import:           warnings
     default-language: Haskell2010

plugins/hls-explicit-record-fields-plugin/test/Main.hs

@@ -11,7 +11,6 @@ import qualified Ide.Plugin.ExplicitFields as ExplicitFields
 import           System.FilePath           ((<.>), (</>))
 import           Test.Hls
 
-
 main :: IO ()
 main = defaultTestRunner test
 
@@ -27,6 +26,8 @@ test = testGroup "explicit-fields"
   , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32
   , mkTest "Mixed" "Mixed" 14 10 14 37
   , mkTest "Construction" "Construction" 16 5 16 15
+  , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20
+  , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22
   , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52
   , mkTestNoAction "Puns" "Puns" 12 10 12 31
   , mkTestNoAction "Infix" "Infix" 11 11 11 31
@@ -41,18 +42,22 @@ mkTestNoAction title fp x1 y1 x2 y2 =
       actions <- getExplicitFieldsActions doc x1 y1 x2 y2
       liftIO $ actions @?= []
 
-mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
-mkTest title fp x1 y1 x2 y2 =
-  goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do
-    (act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2
+mkTestWithCount :: Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkTestWithCount cnt title fp x1 y1 x2 y2 =
+  goldenWithHaskellAndCaps codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do
+    acts@(act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2
+    liftIO $ length acts @?= cnt
     executeCodeAction act
 
+mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkTest = mkTestWithCount 1
+
 getExplicitFieldsActions
   :: TextDocumentIdentifier
   -> UInt -> UInt -> UInt -> UInt
   -> Session [CodeAction]
 getExplicitFieldsActions doc x1 y1 x2 y2 =
-  findExplicitFieldsAction <$> getCodeActions doc range
+  findExplicitFieldsAction <$> getAndResolveCodeActions doc range
   where
     range = Range (Position x1 y1) (Position x2 y2)
 

plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.expected.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module HsExpanded1 where
+import Prelude
+
+ifThenElse :: Int -> Int -> Int ->  Int
+ifThenElse x y z = x + y + z
+
+data MyRec = MyRec
+  { foo :: Int }
+
+myRecExample = MyRec 5
+
+convertMe :: Int
+convertMe =
+  if (let MyRec {foo} = myRecExample
+      in foo) then 1 else 2

plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module HsExpanded1 where
+import Prelude
+
+ifThenElse :: Int -> Int -> Int ->  Int
+ifThenElse x y z = x + y + z
+
+data MyRec = MyRec
+  { foo :: Int }
+
+myRecExample = MyRec 5
+
+convertMe :: Int
+convertMe =
+  if (let MyRec {..} = myRecExample
+      in foo) then 1 else 2

plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.expected.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module HsExpanded2 where
+import Prelude
+
+ifThenElse :: Int -> Int -> Int ->  Int
+ifThenElse x y z = x + y + z
+
+data MyRec = MyRec
+  { foo :: Int }
+
+data YourRec = YourRec
+  { bar :: Int }
+
+myRecExample = MyRec 5
+
+yourRecExample = YourRec 3
+
+convertMe :: Int
+convertMe =
+  if (let MyRec {..} = myRecExample
+          YourRec {bar} = yourRecExample
+      in bar) then 1 else 2

plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded2.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module HsExpanded2 where
+import Prelude
+
+ifThenElse :: Int -> Int -> Int ->  Int
+ifThenElse x y z = x + y + z
+
+data MyRec = MyRec
+  { foo :: Int }
+
+data YourRec = YourRec
+  { bar :: Int }
+
+myRecExample = MyRec 5
+
+yourRecExample = YourRec 3
+
+convertMe :: Int
+convertMe =
+  if (let MyRec {..} = myRecExample
+          YourRec {..} = yourRecExample
+      in bar) then 1 else 2