From f7980c3ac9fb2bd7ff5f8ef91203b79387392fb3 Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Sun, 7 Mar 2021 16:22:26 +0800
Subject: [PATCH 1/6] Package ghcide code actions

---
 ghcide/ghcide.cabal                           |   5 +-
 .../src/Development/IDE/Plugin/CodeAction.hs  |  80 +++++---------
 .../Development/IDE/Plugin/CodeAction/Args.hs | 102 ++++++++++++++++++
 .../IDE/Plugin/CodeAction/Args/TH.hs          |  41 +++++++
 4 files changed, 172 insertions(+), 56 deletions(-)
 create mode 100644 ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
 create mode 100644 ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs

diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index 137271bad5..5dfb2de39b 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -101,7 +101,8 @@ library
         cryptohash-sha1 >=0.11.100 && <0.12,
         hie-bios >= 0.7.1 && < 0.8.0,
         implicit-hie-cradle >= 0.3.0.2 && < 0.4,
-        base16-bytestring >=0.1.1 && <0.2
+        base16-bytestring >=0.1.1 && <0.2,
+        template-haskell
     if os(windows)
       build-depends:
         Win32
@@ -190,6 +191,8 @@ library
         Development.IDE.GHC.Warnings
         Development.IDE.LSP.Notifications
         Development.IDE.Plugin.CodeAction.PositionIndexed
+        Development.IDE.Plugin.CodeAction.Args
+        Development.IDE.Plugin.CodeAction.Args.TH
         Development.IDE.Plugin.Completions.Logic
         Development.IDE.Session.VersionCheck
         Development.IDE.Types.Action
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 3fe9b7bb71..85097708cb 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -3,11 +3,10 @@
 
 {-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE RankNTypes            #-}
 #include "ghc-api-version.h"
 
 -- | Go to the definition of a variable.
+
 module Development.IDE.Plugin.CodeAction
     ( descriptor
 
@@ -20,7 +19,6 @@ import           Control.Applicative                               ((<|>))
 import           Control.Arrow                                     (second,
                                                                     (>>>))
 import           Control.Concurrent.Extra                          (readVar)
-import           Control.Lens                                      (alaf)
 import           Control.Monad                                     (guard, join)
 import           Control.Monad.IO.Class
 import           Data.Char
@@ -34,7 +32,6 @@ import           Data.List.NonEmpty                                (NonEmpty ((:
 import qualified Data.List.NonEmpty                                as NE
 import qualified Data.Map                                          as M
 import           Data.Maybe
-import           Data.Monoid                                       (Ap (..))
 import qualified Data.Rope.UTF16                                   as Rope
 import qualified Data.Set                                          as S
 import qualified Data.Text                                         as T
@@ -47,13 +44,12 @@ import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.ExactPrint
 import           Development.IDE.GHC.Util                          (prettyPrint,
                                                                     printRdrName)
+import           Development.IDE.Plugin.CodeAction.Args
 import           Development.IDE.Plugin.CodeAction.ExactPrint
 import           Development.IDE.Plugin.CodeAction.PositionIndexed
 import           Development.IDE.Plugin.TypeLenses                 (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),
-                                                                    GlobalBindingTypeSigsResult,
                                                                     suggestSignature)
 import           Development.IDE.Spans.Common
-import           Development.IDE.Spans.LocalBindings               (Bindings)
 import           Development.IDE.Types.Exports
 import           Development.IDE.Types.HscEnvEq
 import           Development.IDE.Types.Location
@@ -117,7 +113,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod
       df = ms_hspp_opts . pm_mod_summary <$> parsedModule
       actions =
         [ mkCA title  [x] edit
-        | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x
+        | x <- xs, (title, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ]
       actions' = caRemoveRedundantImports parsedModule text diag xs uri
@@ -129,55 +125,29 @@ mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
 mkCA title diags edit =
   InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing
 
-rewrite ::
-    Maybe DynFlags ->
-    Maybe (Annotated ParsedSource) ->
-    (DynFlags -> ParsedSource -> [(T.Text, [Rewrite])]) ->
-    [(T.Text, [TextEdit])]
-rewrite (Just df) (Just ps) f
-    | Right edit <- (traverse . traverse)
-        (alaf Ap foldMap (rewriteToEdit df (annsA ps)))
-        (f df $ astA ps) = edit
-rewrite _ _ _ = []
-
-suggestAction
-  :: ExportsMap
-  -> IdeOptions
-  -> Maybe ParsedModule
-  -> Maybe T.Text
-  -> Maybe DynFlags
-  -> Maybe (Annotated ParsedSource)
-  -> Maybe TcModuleResult
-  -> Maybe HieAstResult
-  -> Maybe Bindings
-  -> Maybe GlobalBindingTypeSigsResult
-  -> Diagnostic
-  -> [(T.Text, [TextEdit])]
-suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings gblSigs diag =
-    concat
+suggestAction :: CodeActionArgs -> [(T.Text, [TextEdit])]
+suggestAction caa =
+    concat $ unwrap caa <$>
    -- Order these suggestions by priority
-    [ suggestSignature True gblSigs tcM bindings diag
-    , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag
-    , rewrite df annSource $ \df ps ->
-        suggestImportDisambiguation df text ps diag
-    , rewrite df annSource $ \_ ps -> suggestNewOrExtendImportForClassMethod packageExports ps diag
-    , suggestFillTypeWildcard diag
-    , suggestFixConstructorImport text diag
-    , suggestModuleTypo diag
-    , suggestReplaceIdentifier text diag
-    , removeRedundantConstraints text diag
-    , suggestAddTypeAnnotationToSatisfyContraints text diag
-    , rewrite df annSource $ \df ps -> suggestConstraint df ps diag
-    , rewrite df annSource $ \_ ps -> suggestImplicitParameter ps diag
-    , rewrite df annSource $ \_ ps -> suggestHideShadow ps tcM har diag
-    ] ++ concat
-    [  suggestNewDefinition ideOptions pm text diag
-    ++ suggestNewImport packageExports pm diag
-    ++ suggestDeleteUnusedBinding pm text diag
-    ++ suggestExportUnusedTopBinding text pm diag
-    | Just pm <- [parsedModule]
-    ] ++
-    suggestFillHole diag                   -- Lowest priority
+    [ wrap $ suggestSignature True
+    , wrap suggestExtendImport
+    , wrap suggestImportDisambiguation
+    , wrap suggestNewOrExtendImportForClassMethod
+    , wrap suggestFillTypeWildcard
+    , wrap suggestFixConstructorImport
+    , wrap suggestModuleTypo
+    , wrap suggestReplaceIdentifier
+    , wrap removeRedundantConstraints
+    , wrap suggestAddTypeAnnotationToSatisfyContraints
+    , wrap suggestConstraint
+    , wrap suggestImplicitParameter
+    , wrap suggestHideShadow
+    , wrap suggestNewDefinition
+    , wrap suggestNewImport
+    , wrap suggestDeleteUnusedBinding
+    , wrap suggestExportUnusedTopBinding
+    , wrap suggestFillHole -- Lowest priority
+    ]
 
 findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)
 findSigOfDecl pred decls =
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
new file mode 100644
index 0000000000..866603da5e
--- /dev/null
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE TemplateHaskell           #-}
+
+module Development.IDE.Plugin.CodeAction.Args where
+
+import           Control.Lens                                 (alaf)
+import           Data.Bifunctor                               (second)
+import           Data.Monoid                                  (Ap (..))
+import qualified Data.Text                                    as T
+import           Development.IDE
+import           Development.IDE.GHC.Compat
+import           Development.IDE.Plugin.CodeAction.Args.TH
+import           Development.IDE.Plugin.CodeAction.ExactPrint
+import           Development.IDE.Plugin.TypeLenses            (GlobalBindingTypeSigsResult)
+import           Development.IDE.Spans.LocalBindings          (Bindings)
+import           Development.IDE.Types.Exports                (ExportsMap)
+import           Development.IDE.Types.Options                (IdeOptions)
+import           Language.LSP.Types                           (TextEdit,
+                                                               type (|?) (..))
+import           Retrie                                       (Annotated (astA))
+import           Retrie.ExactPrint                            (annsA)
+
+data CodeActionArgs = CodeActionArgs
+  { caaExportsMap   :: ExportsMap
+  , caaIdeOptions   :: IdeOptions
+  , caaParsedModule :: Maybe ParsedModule
+  , caaContents     :: Maybe T.Text
+  , caaDf           :: Maybe DynFlags
+  , caaAnnSource    :: Maybe (Annotated ParsedSource)
+  , caaTmr          :: Maybe TcModuleResult
+  , caaHar          :: Maybe HieAstResult
+  , caaBindings     :: Maybe Bindings
+  , caaGblSigs      :: Maybe GlobalBindingTypeSigsResult
+  , caaDiagnostics  :: Diagnostic
+  }
+
+rewrite ::
+  Maybe DynFlags ->
+  Maybe (Annotated ParsedSource) ->
+  [(T.Text, [Rewrite])] ->
+  [(T.Text, [TextEdit])]
+rewrite (Just df) (Just ps) r
+  | Right edit <-
+      (traverse . traverse)
+        (alaf Ap foldMap (rewriteToEdit df (annsA ps)))
+        r =
+    edit
+rewrite _ _ _ = []
+
+-- we need this intermediate existential type to encapsulate functions producing code actions into a list
+data SomeAction = forall a. ToCodeAction a => SomeAction a
+
+wrap :: ToCodeAction a => a -> SomeAction
+wrap = SomeAction
+
+unwrap :: CodeActionArgs -> SomeAction -> [(T.Text, [TextEdit])]
+unwrap caa (SomeAction x) = toCodeAction caa x
+
+class ToCodeAction a where
+  toCodeAction :: CodeActionArgs -> a -> [(T.Text, [TextEdit])]
+
+instance ToCodeAction [(T.Text, [TextEdit])] where
+  toCodeAction _ = id
+
+instance ToCodeAction [(T.Text, [Rewrite])] where
+  toCodeAction CodeActionArgs{..} = rewrite caaDf caaAnnSource
+
+instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where
+  toCodeAction caa@CodeActionArgs{caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps
+  toCodeAction _ _ = []
+
+instance ToCodeAction [(T.Text, [TextEdit |? Rewrite])] where
+  toCodeAction CodeActionArgs{..} r = second (concatMap go) <$> r
+    where
+      go (InL te) = [te]
+      go (InR rw)
+        | Just df <- caaDf,
+          Just ps <- caaAnnSource,
+          Right x <- rewriteToEdit df (annsA ps) rw
+         = x
+        | otherwise = []
+
+-- generates instances of 'ToCodeAction',
+-- where the pattern is @instance ToCodeAction r => ToCodeAction (field -> r)@, for each field of 'CodeActionArgs'.
+-- therefore functions to produce code actions in CodeAction.hs can be wrapped into 'SomeAction' without modification.
+-- for types applied to 'Maybe', it generates to instances: for example,
+--
+-- @
+-- instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where
+--   toCodeAction caa@CodeActionArgs {caaDf = x} f = toCodeAction caa $ f x
+-- @
+--
+-- and
+--
+-- @
+-- instance ToCodeAction r => ToCodeAction (DynFlags -> r) where
+--   toCodeAction caa@CodeActionArgs {caaDf = Just x} f = toCodeAction caa $ f x
+--   toCodeAction _ _  = []
+-- @
+-- will be derived from 'caaDf'.
+mkInstances ''CodeActionArgs
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs
new file mode 100644
index 0000000000..b0693695fc
--- /dev/null
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Development.IDE.Plugin.CodeAction.Args.TH (mkInstances) where
+
+import           Language.Haskell.TH
+
+mkInstances :: Name -> DecsQ
+mkInstances tyConName =
+  reify tyConName >>= \case
+    (TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys
+    _ -> error "unsupported"
+ where
+  clsType = conT $ mkName "ToCodeAction"
+  methodName = mkName "toCodeAction"
+  tempType = varT $ mkName "r"
+  commonFun dataConName fieldName = funD methodName [clause [mkName "caa" `asP` recP dataConName [fieldPat fieldName $ varP (mkName "x")], varP (mkName "f")] (normalB [|$(varE methodName) caa $ f x|]) []]
+  genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty'))
+    | _maybe == ''Maybe =
+      do
+        withMaybe <-
+          instanceD
+            (cxt [clsType `appT` tempType])
+            (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
+            [commonFun dataConName fieldName]
+        withoutMaybe <-
+          instanceD
+            (cxt [clsType `appT` tempType])
+            (clsType `appT` ((arrowT `appT` pure ty') `appT` tempType))
+            [ funD
+                methodName
+                [ clause [mkName "caa" `asP` recP dataConName [fieldPat fieldName $ conP 'Just [varP (mkName "x")]], varP (mkName "f")] (normalB [|$(varE methodName) caa $ f x|]) []
+                , clause [wildP, wildP] (normalB [|[]|]) []
+                ]
+            ]
+        pure [withMaybe, withoutMaybe]
+  genForVar dataConName (fieldName, _, ty) =
+    pure
+      <$> instanceD
+        (cxt [clsType `appT` tempType])
+        (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
+        [commonFun dataConName fieldName]

From 19c61cc0f8ce39dc89dd8874b44f5af030d60b6c Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Sun, 7 Mar 2021 17:24:35 +0800
Subject: [PATCH 2/6] HLint

---
 .../Development/IDE/Plugin/CodeAction/Args.hs | 20 ++++++++++---------
 1 file changed, 11 insertions(+), 9 deletions(-)

diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
index 866603da5e..654cd3b150 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -2,7 +2,9 @@
 {-# LANGUAGE FlexibleInstances         #-}
 {-# LANGUAGE TemplateHaskell           #-}
 
-module Development.IDE.Plugin.CodeAction.Args where
+module Development.IDE.Plugin.CodeAction.Args (
+  module Development.IDE.Plugin.CodeAction.Args,
+) where
 
 import           Control.Lens                                 (alaf)
 import           Data.Bifunctor                               (second)
@@ -72,14 +74,14 @@ instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where
 
 instance ToCodeAction [(T.Text, [TextEdit |? Rewrite])] where
   toCodeAction CodeActionArgs{..} r = second (concatMap go) <$> r
-    where
-      go (InL te) = [te]
-      go (InR rw)
-        | Just df <- caaDf,
-          Just ps <- caaAnnSource,
-          Right x <- rewriteToEdit df (annsA ps) rw
-         = x
-        | otherwise = []
+   where
+    go (InL te) = [te]
+    go (InR rw)
+      | Just df <- caaDf
+        , Just ps <- caaAnnSource
+        , Right x <- rewriteToEdit df (annsA ps) rw =
+        x
+      | otherwise = []
 
 -- generates instances of 'ToCodeAction',
 -- where the pattern is @instance ToCodeAction r => ToCodeAction (field -> r)@, for each field of 'CodeActionArgs'.

From 586292e85b06944e78604c254e5b1e480aab0a4d Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Wed, 10 Mar 2021 11:53:03 +0800
Subject: [PATCH 3/6] Expand and remove TH, Remove the existential type

---
 ghcide/ghcide.cabal                           |   4 +-
 .../src/Development/IDE/Plugin/CodeAction.hs  |   6 +-
 .../Development/IDE/Plugin/CodeAction/Args.hs | 265 ++++++++++++++----
 .../IDE/Plugin/CodeAction/Args/TH.hs          |  41 ---
 4 files changed, 219 insertions(+), 97 deletions(-)
 delete mode 100644 ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs

diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index 5dfb2de39b..daff1bc13f 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -101,8 +101,7 @@ library
         cryptohash-sha1 >=0.11.100 && <0.12,
         hie-bios >= 0.7.1 && < 0.8.0,
         implicit-hie-cradle >= 0.3.0.2 && < 0.4,
-        base16-bytestring >=0.1.1 && <0.2,
-        template-haskell
+        base16-bytestring >=0.1.1 && <0.2
     if os(windows)
       build-depends:
         Win32
@@ -192,7 +191,6 @@ library
         Development.IDE.LSP.Notifications
         Development.IDE.Plugin.CodeAction.PositionIndexed
         Development.IDE.Plugin.CodeAction.Args
-        Development.IDE.Plugin.CodeAction.Args.TH
         Development.IDE.Plugin.Completions.Logic
         Development.IDE.Session.VersionCheck
         Development.IDE.Types.Action
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 85097708cb..7e648644c5 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -127,8 +127,7 @@ mkCA title diags edit =
 
 suggestAction :: CodeActionArgs -> [(T.Text, [TextEdit])]
 suggestAction caa =
-    concat $ unwrap caa <$>
-   -- Order these suggestions by priority
+  concat   -- Order these suggestions by priority
     [ wrap $ suggestSignature True
     , wrap suggestExtendImport
     , wrap suggestImportDisambiguation
@@ -148,6 +147,9 @@ suggestAction caa =
     , wrap suggestExportUnusedTopBinding
     , wrap suggestFillHole -- Lowest priority
     ]
+    where
+      wrap :: ToCodeAction a => a -> [(T.Text, [TextEdit])]
+      wrap = toCodeAction caa
 
 findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)
 findSigOfDecl pred decls =
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
index 654cd3b150..cfb45a5663 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -1,25 +1,27 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances         #-}
-{-# LANGUAGE TemplateHaskell           #-}
+{-# LANGUAGE FlexibleInstances #-}
 
-module Development.IDE.Plugin.CodeAction.Args (
-  module Development.IDE.Plugin.CodeAction.Args,
-) where
+module Development.IDE.Plugin.CodeAction.Args
+  ( module Development.IDE.Plugin.CodeAction.Args,
+  )
+where
 
 import           Control.Lens                                 (alaf)
 import           Data.Bifunctor                               (second)
 import           Data.Monoid                                  (Ap (..))
 import qualified Data.Text                                    as T
-import           Development.IDE
-import           Development.IDE.GHC.Compat
-import           Development.IDE.Plugin.CodeAction.Args.TH
-import           Development.IDE.Plugin.CodeAction.ExactPrint
+import           Development.IDE                              (Diagnostic,
+                                                               HieAstResult,
+                                                               TcModuleResult)
+import           Development.IDE.GHC.Compat                   (DynFlags,
+                                                               ParsedModule,
+                                                               ParsedSource)
+import           Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,
+                                                               rewriteToEdit)
 import           Development.IDE.Plugin.TypeLenses            (GlobalBindingTypeSigsResult)
 import           Development.IDE.Spans.LocalBindings          (Bindings)
 import           Development.IDE.Types.Exports                (ExportsMap)
 import           Development.IDE.Types.Options                (IdeOptions)
-import           Language.LSP.Types                           (TextEdit,
-                                                               type (|?) (..))
+import           Language.LSP.Types                           (TextEdit)
 import           Retrie                                       (Annotated (astA))
 import           Retrie.ExactPrint                            (annsA)
 
@@ -50,55 +52,216 @@ rewrite (Just df) (Just ps) r
     edit
 rewrite _ _ _ = []
 
--- we need this intermediate existential type to encapsulate functions producing code actions into a list
-data SomeAction = forall a. ToCodeAction a => SomeAction a
-
-wrap :: ToCodeAction a => a -> SomeAction
-wrap = SomeAction
-
-unwrap :: CodeActionArgs -> SomeAction -> [(T.Text, [TextEdit])]
-unwrap caa (SomeAction x) = toCodeAction caa x
+-------------------------------------------------------------------------------------------------
 
+-- | Given 'CodeActionArgs', @a@ can be converted into the representation of code actions.
+-- This class is designed to package functions that produce code actions in "Development.IDE.Plugin.CodeAction".
+--
+-- For each field @fld@ of 'CodeActionArgs', we make
+--
+-- @@
+-- instance ToCodeAction r => ToCodeAction (fld -> r)
+-- @@
+--
+-- where we take the value of @fld@ from 'CodeActionArgs' and then feed it into @(fld -> r)@.
+-- If @fld@ is @Maybe a@, we make
+--
+-- @@
+-- instance ToCodeAction r => ToCodeAction (Maybe a -> r)
+-- instance ToCodeAction r => ToCodeAction (a -> r)
+-- @@
 class ToCodeAction a where
   toCodeAction :: CodeActionArgs -> a -> [(T.Text, [TextEdit])]
 
+-------------------------------------------------------------------------------------------------
+-- Acceptable return types:
 instance ToCodeAction [(T.Text, [TextEdit])] where
   toCodeAction _ = id
 
 instance ToCodeAction [(T.Text, [Rewrite])] where
-  toCodeAction CodeActionArgs{..} = rewrite caaDf caaAnnSource
+  toCodeAction CodeActionArgs {..} = rewrite caaDf caaAnnSource
+
+instance ToCodeAction [(T.Text, [Either TextEdit Rewrite])] where
+  toCodeAction CodeActionArgs {..} r = second (concatMap go) <$> r
+    where
+      go (Left te) = [te]
+      go (Right rw)
+        | Just df <- caaDf,
+          Just ps <- caaAnnSource,
+          Right x <- rewriteToEdit df (annsA ps) rw =
+          x
+        | otherwise = []
+
+-------------------------------------------------------------------------------------------------
 
+-- | Complement: we can obtain 'ParsedSource' from 'caaAnnSource'
 instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where
-  toCodeAction caa@CodeActionArgs{caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps
+  toCodeAction caa@CodeActionArgs {caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps
   toCodeAction _ _ = []
 
-instance ToCodeAction [(T.Text, [TextEdit |? Rewrite])] where
-  toCodeAction CodeActionArgs{..} r = second (concatMap go) <$> r
-   where
-    go (InL te) = [te]
-    go (InR rw)
-      | Just df <- caaDf
-        , Just ps <- caaAnnSource
-        , Right x <- rewriteToEdit df (annsA ps) rw =
-        x
-      | otherwise = []
-
--- generates instances of 'ToCodeAction',
--- where the pattern is @instance ToCodeAction r => ToCodeAction (field -> r)@, for each field of 'CodeActionArgs'.
--- therefore functions to produce code actions in CodeAction.hs can be wrapped into 'SomeAction' without modification.
--- for types applied to 'Maybe', it generates to instances: for example,
---
--- @
--- instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where
---   toCodeAction caa@CodeActionArgs {caaDf = x} f = toCodeAction caa $ f x
--- @
---
--- and
+-- The following boilerplate code can be generated by 'mkInstances'.
+-- Now it was commented out with generated code spliced out,
+-- because fields of 'CodeActionArgs' don't change frequently.
 --
--- @
--- instance ToCodeAction r => ToCodeAction (DynFlags -> r) where
---   toCodeAction caa@CodeActionArgs {caaDf = Just x} f = toCodeAction caa $ f x
---   toCodeAction _ _  = []
--- @
--- will be derived from 'caaDf'.
-mkInstances ''CodeActionArgs
+-- mkInstances :: Name -> DecsQ
+-- mkInstances tyConName =
+--   reify tyConName >>= \case
+--     (TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys
+--     _ -> error "unsupported"
+--  where
+--   clsType = conT $ mkName "ToCodeAction"
+--   methodName = mkName "toCodeAction"
+--   tempType = varT $ mkName "r"
+--   commonFun dataConName fieldName =
+--     funD
+--       methodName
+--       [ clause
+--           [ mkName "caa"
+--               `asP` recP
+--                 dataConName
+--                 [fieldPat fieldName $ varP (mkName "x")]
+--           , varP (mkName "f")
+--           ]
+--           (normalB [|$(varE methodName) caa $ f x|])
+--           []
+--       ]
+--   genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty'))
+--     | _maybe == ''Maybe =
+--       do
+--         withMaybe <-
+--           instanceD
+--             (cxt [clsType `appT` tempType])
+--             (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
+--             [commonFun dataConName fieldName]
+--         withoutMaybe <-
+--           instanceD
+--             (cxt [clsType `appT` tempType])
+--             (clsType `appT` ((arrowT `appT` pure ty') `appT` tempType))
+--             [ funD
+--                 methodName
+--                 [ clause
+--                     [ mkName "caa"
+--                         `asP` recP
+--                           dataConName
+--                           [fieldPat fieldName $ conP 'Just [varP (mkName "x")]]
+--                     , varP (mkName "f")
+--                     ]
+--                     (normalB [|$(varE methodName) caa $ f x|])
+--                     []
+--                 , clause [wildP, wildP] (normalB [|[]|]) []
+--                 ]
+--             ]
+--         pure [withMaybe, withoutMaybe]
+--   genForVar dataConName (fieldName, _, ty) =
+--     pure
+--       <$> instanceD
+--         (cxt [clsType `appT` tempType])
+--         (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
+--         [commonFun dataConName fieldName]
+
+instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where
+  toCodeAction caa@CodeActionArgs {caaExportsMap = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where
+  toCodeAction caa@CodeActionArgs {caaIdeOptions = x} f =
+    toCodeAction caa $ f x
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (Maybe ParsedModule -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaParsedModule = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where
+  toCodeAction caa@CodeActionArgs {caaParsedModule = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where
+  toCodeAction caa@CodeActionArgs {caaContents = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (T.Text -> r) where
+  toCodeAction caa@CodeActionArgs {caaContents = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where
+  toCodeAction caa@CodeActionArgs {caaDf = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (DynFlags -> r) where
+  toCodeAction caa@CodeActionArgs {caaDf = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (Maybe (Annotated ParsedSource) -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaAnnSource = x} f =
+    toCodeAction caa $ f x
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (Annotated ParsedSource -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaAnnSource = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (Maybe TcModuleResult -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaTmr = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where
+  toCodeAction caa@CodeActionArgs {caaTmr = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (Maybe HieAstResult -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaHar = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where
+  toCodeAction caa@CodeActionArgs {caaHar = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where
+  toCodeAction caa@CodeActionArgs {caaBindings = x} f =
+    toCodeAction caa $ f x
+
+instance ToCodeAction r => ToCodeAction (Bindings -> r) where
+  toCodeAction caa@CodeActionArgs {caaBindings = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaGblSigs = x} f =
+    toCodeAction caa $ f x
+
+instance
+  ToCodeAction r =>
+  ToCodeAction (GlobalBindingTypeSigsResult -> r)
+  where
+  toCodeAction caa@CodeActionArgs {caaGblSigs = Just x} f =
+    toCodeAction caa $ f x
+  toCodeAction _ _ = []
+
+instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where
+  toCodeAction caa@CodeActionArgs {caaDiagnostics = x} f =
+    toCodeAction caa $ f x
+
+-------------------------------------------------------------------------------------------------
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs
deleted file mode 100644
index b0693695fc..0000000000
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Development.IDE.Plugin.CodeAction.Args.TH (mkInstances) where
-
-import           Language.Haskell.TH
-
-mkInstances :: Name -> DecsQ
-mkInstances tyConName =
-  reify tyConName >>= \case
-    (TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys
-    _ -> error "unsupported"
- where
-  clsType = conT $ mkName "ToCodeAction"
-  methodName = mkName "toCodeAction"
-  tempType = varT $ mkName "r"
-  commonFun dataConName fieldName = funD methodName [clause [mkName "caa" `asP` recP dataConName [fieldPat fieldName $ varP (mkName "x")], varP (mkName "f")] (normalB [|$(varE methodName) caa $ f x|]) []]
-  genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty'))
-    | _maybe == ''Maybe =
-      do
-        withMaybe <-
-          instanceD
-            (cxt [clsType `appT` tempType])
-            (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
-            [commonFun dataConName fieldName]
-        withoutMaybe <-
-          instanceD
-            (cxt [clsType `appT` tempType])
-            (clsType `appT` ((arrowT `appT` pure ty') `appT` tempType))
-            [ funD
-                methodName
-                [ clause [mkName "caa" `asP` recP dataConName [fieldPat fieldName $ conP 'Just [varP (mkName "x")]], varP (mkName "f")] (normalB [|$(varE methodName) caa $ f x|]) []
-                , clause [wildP, wildP] (normalB [|[]|]) []
-                ]
-            ]
-        pure [withMaybe, withoutMaybe]
-  genForVar dataConName (fieldName, _, ty) =
-    pure
-      <$> instanceD
-        (cxt [clsType `appT` tempType])
-        (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
-        [commonFun dataConName fieldName]

From 24a2306417469d6d43d933aecef868b9bff740f2 Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Wed, 10 Mar 2021 13:23:40 +0800
Subject: [PATCH 4/6] Support specifying code action kinds

---
 .../src/Development/IDE/Plugin/CodeAction.hs  | 16 ++--
 .../Development/IDE/Plugin/CodeAction/Args.hs | 80 +++++++++++--------
 2 files changed, 56 insertions(+), 40 deletions(-)

diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 7e648644c5..8c5cb28175 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -112,8 +112,8 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod
       exportsMap = localExports <> pkgExports
       df = ms_hspp_opts . pm_mod_summary <$> parsedModule
       actions =
-        [ mkCA title  [x] edit
-        | x <- xs, (title, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x
+        [ mkCA title kind isPreferred [x] edit
+        | x <- xs, (title, kind, isPreferred, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ]
       actions' = caRemoveRedundantImports parsedModule text diag xs uri
@@ -121,11 +121,11 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod
                <> caRemoveInvalidExports parsedModule text diag xs uri
     pure $ Right $ List actions'
 
-mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
-mkCA title diags edit =
-  InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing
+mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
+mkCA title kind isPreferred diags edit =
+  InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing
 
-suggestAction :: CodeActionArgs -> [(T.Text, [TextEdit])]
+suggestAction :: CodeActionArgs -> GhcideCodeActions
 suggestAction caa =
   concat   -- Order these suggestions by priority
     [ wrap $ suggestSignature True
@@ -148,7 +148,7 @@ suggestAction caa =
     , wrap suggestFillHole -- Lowest priority
     ]
     where
-      wrap :: ToCodeAction a => a -> [(T.Text, [TextEdit])]
+      wrap :: ToCodeAction a => a -> GhcideCodeActions
       wrap = toCodeAction caa
 
 findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)
@@ -276,7 +276,7 @@ caRemoveRedundantImports m contents digs ctxDigs uri
       = caRemoveCtx ++ [caRemoveAll]
   | otherwise = []
   where
-    removeSingle title tedit diagnostic = mkCA title [diagnostic] WorkspaceEdit{..} where
+    removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where
         _changes = Just $ Map.singleton uri $ List tedit
         _documentChanges = Nothing
     removeAll tedit = InR $ CodeAction{..} where
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
index cfb45a5663..1464d70839 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -6,7 +6,6 @@ module Development.IDE.Plugin.CodeAction.Args
 where
 
 import           Control.Lens                                 (alaf)
-import           Data.Bifunctor                               (second)
 import           Data.Monoid                                  (Ap (..))
 import qualified Data.Text                                    as T
 import           Development.IDE                              (Diagnostic,
@@ -21,22 +20,46 @@ import           Development.IDE.Plugin.TypeLenses            (GlobalBindingType
 import           Development.IDE.Spans.LocalBindings          (Bindings)
 import           Development.IDE.Types.Exports                (ExportsMap)
 import           Development.IDE.Types.Options                (IdeOptions)
-import           Language.LSP.Types                           (TextEdit)
+import           Language.LSP.Types                           (CodeActionKind (CodeActionQuickFix),
+                                                               TextEdit)
 import           Retrie                                       (Annotated (astA))
 import           Retrie.ExactPrint                            (annsA)
 
+-- | A compact representation of 'Language.LSP.Types.CodeAction's
+type GhcideCodeActions = [(T.Text, Maybe CodeActionKind, Maybe Bool, [TextEdit])]
+
+class ToTextEdit a where
+  toTextEdit :: CodeActionArgs -> a -> [TextEdit]
+
+instance ToTextEdit TextEdit where
+  toTextEdit _ = pure
+
+instance ToTextEdit Rewrite where
+  toTextEdit CodeActionArgs {..} rw
+    | Just df <- caaDf,
+      Just ps <- caaAnnSource,
+      Right x <- rewriteToEdit df (annsA ps) rw =
+      x
+    | otherwise = []
+
+instance ToTextEdit a => ToTextEdit [a] where
+  toTextEdit caa = foldMap (toTextEdit caa)
+
+instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where
+  toTextEdit caa = either (toTextEdit caa) (toTextEdit caa)
+
 data CodeActionArgs = CodeActionArgs
-  { caaExportsMap   :: ExportsMap
-  , caaIdeOptions   :: IdeOptions
-  , caaParsedModule :: Maybe ParsedModule
-  , caaContents     :: Maybe T.Text
-  , caaDf           :: Maybe DynFlags
-  , caaAnnSource    :: Maybe (Annotated ParsedSource)
-  , caaTmr          :: Maybe TcModuleResult
-  , caaHar          :: Maybe HieAstResult
-  , caaBindings     :: Maybe Bindings
-  , caaGblSigs      :: Maybe GlobalBindingTypeSigsResult
-  , caaDiagnostics  :: Diagnostic
+  { caaExportsMap   :: ExportsMap,
+    caaIdeOptions   :: IdeOptions,
+    caaParsedModule :: Maybe ParsedModule,
+    caaContents     :: Maybe T.Text,
+    caaDf           :: Maybe DynFlags,
+    caaAnnSource    :: Maybe (Annotated ParsedSource),
+    caaTmr          :: Maybe TcModuleResult,
+    caaHar          :: Maybe HieAstResult,
+    caaBindings     :: Maybe Bindings,
+    caaGblSigs      :: Maybe GlobalBindingTypeSigsResult,
+    caaDiagnostics  :: Diagnostic
   }
 
 rewrite ::
@@ -71,26 +94,19 @@ rewrite _ _ _ = []
 -- instance ToCodeAction r => ToCodeAction (a -> r)
 -- @@
 class ToCodeAction a where
-  toCodeAction :: CodeActionArgs -> a -> [(T.Text, [TextEdit])]
+  toCodeAction :: CodeActionArgs -> a -> GhcideCodeActions
 
--------------------------------------------------------------------------------------------------
--- Acceptable return types:
-instance ToCodeAction [(T.Text, [TextEdit])] where
-  toCodeAction _ = id
-
-instance ToCodeAction [(T.Text, [Rewrite])] where
-  toCodeAction CodeActionArgs {..} = rewrite caaDf caaAnnSource
-
-instance ToCodeAction [(T.Text, [Either TextEdit Rewrite])] where
-  toCodeAction CodeActionArgs {..} r = second (concatMap go) <$> r
-    where
-      go (Left te) = [te]
-      go (Right rw)
-        | Just df <- caaDf,
-          Just ps <- caaAnnSource,
-          Right x <- rewriteToEdit df (annsA ps) rw =
-          x
-        | otherwise = []
+instance ToTextEdit a => ToCodeAction [(T.Text, a)] where
+  toCodeAction caa xs = [(title, Just CodeActionQuickFix, Nothing, toTextEdit caa te) | (title, te) <- xs]
+
+instance ToTextEdit a => ToCodeAction [(T.Text, CodeActionKind, a)] where
+  toCodeAction caa xs = [(title, Just kind, Nothing, toTextEdit caa te) | (title, kind, te) <- xs]
+
+instance ToTextEdit a => ToCodeAction [(T.Text, Bool, a)] where
+  toCodeAction caa xs = [(title, Nothing, Just isPreferred, toTextEdit caa te) | (title, isPreferred, te) <- xs]
+
+instance ToTextEdit a => ToCodeAction [(T.Text, CodeActionKind, Bool, a)] where
+  toCodeAction caa xs = [(title, Just kind, Just isPreferred, toTextEdit caa te) | (title, kind, isPreferred, te) <- xs]
 
 -------------------------------------------------------------------------------------------------
 

From 6d4362aa5e202148cf3c2cd27526f0f974a264fc Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Wed, 10 Mar 2021 13:49:22 +0800
Subject: [PATCH 5/6] Simplify

---
 .../src/Development/IDE/Plugin/CodeAction.hs  | 42 +++++++++----------
 .../Development/IDE/Plugin/CodeAction/Args.hs |  3 ++
 2 files changed, 24 insertions(+), 21 deletions(-)

diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
index 8c5cb28175..4d1758d866 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -476,7 +476,7 @@ data ExportsAs = ExportName | ExportPattern | ExportAll
 getLocatedRange :: Located a -> Maybe Range
 getLocatedRange = srcSpanToRange . getLoc
 
-suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)]
 suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}
 -- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’
 -- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’
@@ -494,7 +494,7 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul
   , Just needComma <- needsComma source <$> hsmodExports
   , let exportName = (if needComma then "," else "") <> printExport exportType name
         insertPos = pos {_character = pred $ _character pos}
-  = [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])]
+  = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)]
   | otherwise = []
   where
     -- we get the last export and the closing bracket and check for comma in that range
@@ -641,7 +641,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
     ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
 
 
-suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
+suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
 suggestFillTypeWildcard Diagnostic{_range=_range,..}
 -- Foo.hs:3:8: error:
 --     * Found type wildcard `_' standing for `p -> p1 -> p'
@@ -649,10 +649,10 @@ suggestFillTypeWildcard Diagnostic{_range=_range,..}
     | "Found type wildcard" `T.isInfixOf` _message
     , " standing for " `T.isInfixOf` _message
     , typeSignature <- extractWildCardTypeSignature _message
-        =  [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
+        =  [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)]
     | otherwise = []
 
-suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
+suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)]
 suggestModuleTypo Diagnostic{_range=_range,..}
 -- src/Development/IDE/Core/Compile.hs:58:1: error:
 --     Could not find module ‘Data.Cha’
@@ -660,11 +660,11 @@ suggestModuleTypo Diagnostic{_range=_range,..}
     | "Could not find module" `T.isInfixOf` _message
     , "Perhaps you meant"     `T.isInfixOf` _message = let
       findSuggestedModules = map (head . T.words) . drop 2 . T.lines
-      proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
+      proposeModule mod = ("replace with " <> mod, TextEdit _range mod)
       in map proposeModule $ nubOrd $ findSuggestedModules _message
     | otherwise = []
 
-suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
+suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]
 suggestFillHole Diagnostic{_range=_range,..}
     | Just holeName <- extractHoleName _message
     , (holeFits, refFits) <- processHoleSuggestions (T.lines _message)
@@ -675,7 +675,7 @@ suggestFillHole Diagnostic{_range=_range,..}
       extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"
       proposeHoleFit holeName parenthise name =
           ( "replace " <> holeName <> " with " <> name
-          , [TextEdit _range $ if parenthise then parens name else name])
+          , TextEdit _range $ if parenthise then parens name else name)
       parens x = "(" <> x <> ")"
 
 processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])
@@ -738,7 +738,7 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of
 indentation :: T.Text -> Int
 indentation = T.length . T.takeWhile isSpace
 
-suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])]
+suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
 suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}
     | Just [binding, mod, srcspan] <-
       matchRegexUnifySpaces _message
@@ -757,7 +757,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_
             Just decl <- findImportDeclByRange decls range,
             Just ident <- lookupExportMap binding mod
           = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod
-              , [uncurry extendImport (unImportStyle importStyle) decl]
+              , uncurry extendImport (unImportStyle importStyle) decl
               )
             | importStyle <- NE.toList $ importStyles ident
             ]
@@ -927,8 +927,8 @@ disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case
 findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)
 findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs
 
-suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestFixConstructorImport _ Diagnostic{_range=_range,..}
+suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)]
+suggestFixConstructorImport Diagnostic{_range=_range,..}
     -- ‘Success’ is a data constructor of ‘Result’
     -- To import it use
     -- import Data.Aeson.Types( Result( Success ) )
@@ -938,16 +938,16 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
     matchRegexUnifySpaces _message
     "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
   = let fixedImport = typ <> "(" <> constructor <> ")"
-    in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
+    in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]
   | otherwise = []
 -- | Suggests a constraint for a declaration for which a constraint is missing.
-suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])]
+suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
 suggestConstraint df parsedModule diag@Diagnostic {..}
   | Just missingConstraint <- findMissingConstraint _message
   = let codeAction = if _message =~ ("the type signature for:" :: String)
                         then suggestFunctionConstraint df parsedModule
                         else suggestInstanceConstraint df parsedModule
-     in map (second (:[])) $ codeAction diag missingConstraint
+     in codeAction diag missingConstraint
   | otherwise = []
     where
       findMissingConstraint :: T.Text -> Maybe T.Text
@@ -1003,14 +1003,14 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing
 suggestImplicitParameter ::
   ParsedSource ->
   Diagnostic ->
-  [(T.Text, [Rewrite])]
+  [(T.Text, Rewrite)]
 suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range}
   | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising",
     Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls,
     Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls
     =
       [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId)
-        , [appendConstraint (T.unpack implicitT) hsib_body])]
+        , appendConstraint (T.unpack implicitT) hsib_body)]
   | otherwise = []
 
 findTypeSignatureName :: T.Text -> Maybe T.Text
@@ -1058,7 +1058,7 @@ suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing
         <> "` to the context of the type signature for `" <> typeSignatureName <> "`"
 
 -- | Suggests the removal of a redundant constraint for a type signature.
-removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
+removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, TextEdit)]
 removeRedundantConstraints mContents Diagnostic{..}
 -- • Redundant constraint: Eq a
 -- • In the type signature for:
@@ -1080,7 +1080,7 @@ removeRedundantConstraints mContents Diagnostic{..}
         endOfConstraint = Position typeSignatureLine $
           typeSignatureFirstChar + T.length (constraints <> " => ")
         range = Range startOfConstraint endOfConstraint
-     in [(actionTitle redundantConstraintList typeSignatureName, [TextEdit range newConstraints])]
+     in [(actionTitle redundantConstraintList typeSignatureName, TextEdit range newConstraints)]
   | otherwise = []
     where
       parseConstraints :: T.Text -> [T.Text]
@@ -1169,7 +1169,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps Diagnostic {_message
             ]
               <> maybeToList (("Import " <> moduleNameText,) <$> fmap pure (newImportAll (T.unpack moduleNameText) ps))
 
-suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)]
 suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
   | msg <- unifySpaces _message
   , Just thingMissing <- extractNotInScopeName msg
@@ -1189,7 +1189,7 @@ suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule
   , insertPos <- Position insertLine 0
   , extendImportSuggestions <- matchRegexUnifySpaces msg
     "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
-  = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
+  = [(imp, TextEdit (Range insertPos insertPos) (imp <> "\n"))
     | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions
     ]
 suggestNewImport _ _ _ = []
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
index 1464d70839..7bed234594 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -45,6 +45,9 @@ instance ToTextEdit Rewrite where
 instance ToTextEdit a => ToTextEdit [a] where
   toTextEdit caa = foldMap (toTextEdit caa)
 
+instance ToTextEdit a => ToTextEdit (Maybe a) where
+  toTextEdit caa = maybe [] (toTextEdit caa)
+
 instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where
   toTextEdit caa = either (toTextEdit caa) (toTextEdit caa)
 

From 86d93c62b31e0c1074ef5df225ed409dc2a31591 Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Wed, 10 Mar 2021 14:00:26 +0800
Subject: [PATCH 6/6] Optimize instances

---
 .../Development/IDE/Plugin/CodeAction/Args.hs | 22 ++++++++++++-------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
index 7bed234594..0481f42386 100644
--- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
+++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs
@@ -99,17 +99,23 @@ rewrite _ _ _ = []
 class ToCodeAction a where
   toCodeAction :: CodeActionArgs -> a -> GhcideCodeActions
 
-instance ToTextEdit a => ToCodeAction [(T.Text, a)] where
-  toCodeAction caa xs = [(title, Just CodeActionQuickFix, Nothing, toTextEdit caa te) | (title, te) <- xs]
+instance ToCodeAction a => ToCodeAction [a] where
+  toCodeAction caa = foldMap (toCodeAction caa)
 
-instance ToTextEdit a => ToCodeAction [(T.Text, CodeActionKind, a)] where
-  toCodeAction caa xs = [(title, Just kind, Nothing, toTextEdit caa te) | (title, kind, te) <- xs]
+instance ToCodeAction a => ToCodeAction (Maybe a) where
+  toCodeAction caa = maybe [] (toCodeAction caa)
 
-instance ToTextEdit a => ToCodeAction [(T.Text, Bool, a)] where
-  toCodeAction caa xs = [(title, Nothing, Just isPreferred, toTextEdit caa te) | (title, isPreferred, te) <- xs]
+instance ToTextEdit a => ToCodeAction (T.Text, a) where
+  toCodeAction caa (title, te) = [(title, Just CodeActionQuickFix, Nothing, toTextEdit caa te)]
 
-instance ToTextEdit a => ToCodeAction [(T.Text, CodeActionKind, Bool, a)] where
-  toCodeAction caa xs = [(title, Just kind, Just isPreferred, toTextEdit caa te) | (title, kind, isPreferred, te) <- xs]
+instance ToTextEdit a => ToCodeAction (T.Text, CodeActionKind, a) where
+  toCodeAction caa (title, kind, te) = [(title, Just kind, Nothing, toTextEdit caa te)]
+
+instance ToTextEdit a => ToCodeAction (T.Text, Bool, a) where
+  toCodeAction caa (title, isPreferred, te) = [(title, Nothing, Just isPreferred, toTextEdit caa te)]
+
+instance ToTextEdit a => ToCodeAction (T.Text, CodeActionKind, Bool, a) where
+  toCodeAction caa (title, kind, isPreferred, te) = [(title, Just kind, Just isPreferred, toTextEdit caa te)]
 
 -------------------------------------------------------------------------------------------------