Skip to content

Commit f7980c3

Browse files
berbermanberberman
committed
Package ghcide code actions
1 parent 848067b commit f7980c3

File tree

4 files changed

+172
-56
lines changed

4 files changed

+172
-56
lines changed

‎ghcide/ghcide.cabal

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -101,7 +101,8 @@ library
101101
cryptohash-sha1 >=0.11.100 && <0.12,
102102
hie-bios >= 0.7.1 && < 0.8.0,
103103
implicit-hie-cradle >= 0.3.0.2 && < 0.4,
104-
base16-bytestring >=0.1.1 && <0.2
104+
base16-bytestring >=0.1.1 && <0.2,
105+
template-haskell
105106
if os(windows)
106107
build-depends:
107108
Win32
@@ -190,6 +191,8 @@ library
190191
Development.IDE.GHC.Warnings
191192
Development.IDE.LSP.Notifications
192193
Development.IDE.Plugin.CodeAction.PositionIndexed
194+
Development.IDE.Plugin.CodeAction.Args
195+
Development.IDE.Plugin.CodeAction.Args.TH
193196
Development.IDE.Plugin.Completions.Logic
194197
Development.IDE.Session.VersionCheck
195198
Development.IDE.Types.Action

‎ghcide/src/Development/IDE/Plugin/CodeAction.hs

Lines changed: 25 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,10 @@
33

44
{-# LANGUAGE CPP #-}
55
{-# LANGUAGE DuplicateRecordFields #-}
6-
{-# LANGUAGE GADTs #-}
7-
{-# LANGUAGE RankNTypes #-}
86
#include "ghc-api-version.h"
97

108
-- | Go to the definition of a variable.
9+
1110
module Development.IDE.Plugin.CodeAction
1211
( descriptor
1312

@@ -20,7 +19,6 @@ import Control.Applicative ((<|>))
2019
import Control.Arrow (second,
2120
(>>>))
2221
import Control.Concurrent.Extra (readVar)
23-
import Control.Lens (alaf)
2422
import Control.Monad (guard, join)
2523
import Control.Monad.IO.Class
2624
import Data.Char
@@ -34,7 +32,6 @@ import Data.List.NonEmpty (NonEmpty ((:
3432
import qualified Data.List.NonEmpty as NE
3533
import qualified Data.Map as M
3634
import Data.Maybe
37-
import Data.Monoid (Ap (..))
3835
import qualified Data.Rope.UTF16 as Rope
3936
import qualified Data.Set as S
4037
import qualified Data.Text as T
@@ -47,13 +44,12 @@ import Development.IDE.GHC.Error
4744
import Development.IDE.GHC.ExactPrint
4845
import Development.IDE.GHC.Util (prettyPrint,
4946
printRdrName)
47+
import Development.IDE.Plugin.CodeAction.Args
5048
import Development.IDE.Plugin.CodeAction.ExactPrint
5149
import Development.IDE.Plugin.CodeAction.PositionIndexed
5250
import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),
53-
GlobalBindingTypeSigsResult,
5451
suggestSignature)
5552
import Development.IDE.Spans.Common
56-
import Development.IDE.Spans.LocalBindings (Bindings)
5753
import Development.IDE.Types.Exports
5854
import Development.IDE.Types.HscEnvEq
5955
import Development.IDE.Types.Location
@@ -117,7 +113,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod
117113
df = ms_hspp_opts . pm_mod_summary <$> parsedModule
118114
actions =
119115
[ mkCA title [x] edit
120-
| x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x
116+
| x <- xs, (title, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x
121117
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
122118
]
123119
actions' = caRemoveRedundantImports parsedModule text diag xs uri
@@ -129,55 +125,29 @@ mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
129125
mkCA title diags edit =
130126
InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing
131127

132-
rewrite ::
133-
Maybe DynFlags ->
134-
Maybe (Annotated ParsedSource) ->
135-
(DynFlags -> ParsedSource -> [(T.Text, [Rewrite])]) ->
136-
[(T.Text, [TextEdit])]
137-
rewrite (Just df) (Just ps) f
138-
| Right edit <- (traverse . traverse)
139-
(alaf Ap foldMap (rewriteToEdit df (annsA ps)))
140-
(f df $ astA ps) = edit
141-
rewrite _ _ _ = []
142-
143-
suggestAction
144-
:: ExportsMap
145-
-> IdeOptions
146-
-> Maybe ParsedModule
147-
-> Maybe T.Text
148-
-> Maybe DynFlags
149-
-> Maybe (Annotated ParsedSource)
150-
-> Maybe TcModuleResult
151-
-> Maybe HieAstResult
152-
-> Maybe Bindings
153-
-> Maybe GlobalBindingTypeSigsResult
154-
-> Diagnostic
155-
-> [(T.Text, [TextEdit])]
156-
suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings gblSigs diag =
157-
concat
128+
suggestAction :: CodeActionArgs -> [(T.Text, [TextEdit])]
129+
suggestAction caa =
130+
concat $ unwrap caa <$>
158131
-- Order these suggestions by priority
159-
[ suggestSignature True gblSigs tcM bindings diag
160-
, rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag
161-
, rewrite df annSource $ \df ps ->
162-
suggestImportDisambiguation df text ps diag
163-
, rewrite df annSource $ \_ ps -> suggestNewOrExtendImportForClassMethod packageExports ps diag
164-
, suggestFillTypeWildcard diag
165-
, suggestFixConstructorImport text diag
166-
, suggestModuleTypo diag
167-
, suggestReplaceIdentifier text diag
168-
, removeRedundantConstraints text diag
169-
, suggestAddTypeAnnotationToSatisfyContraints text diag
170-
, rewrite df annSource $ \df ps -> suggestConstraint df ps diag
171-
, rewrite df annSource $ \_ ps -> suggestImplicitParameter ps diag
172-
, rewrite df annSource $ \_ ps -> suggestHideShadow ps tcM har diag
173-
] ++ concat
174-
[ suggestNewDefinition ideOptions pm text diag
175-
++ suggestNewImport packageExports pm diag
176-
++ suggestDeleteUnusedBinding pm text diag
177-
++ suggestExportUnusedTopBinding text pm diag
178-
| Just pm <- [parsedModule]
179-
] ++
180-
suggestFillHole diag -- Lowest priority
132+
[ wrap $ suggestSignature True
133+
, wrap suggestExtendImport
134+
, wrap suggestImportDisambiguation
135+
, wrap suggestNewOrExtendImportForClassMethod
136+
, wrap suggestFillTypeWildcard
137+
, wrap suggestFixConstructorImport
138+
, wrap suggestModuleTypo
139+
, wrap suggestReplaceIdentifier
140+
, wrap removeRedundantConstraints
141+
, wrap suggestAddTypeAnnotationToSatisfyContraints
142+
, wrap suggestConstraint
143+
, wrap suggestImplicitParameter
144+
, wrap suggestHideShadow
145+
, wrap suggestNewDefinition
146+
, wrap suggestNewImport
147+
, wrap suggestDeleteUnusedBinding
148+
, wrap suggestExportUnusedTopBinding
149+
, wrap suggestFillHole -- Lowest priority
150+
]
181151

182152
findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)
183153
findSigOfDecl pred decls =

‎ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs

Lines changed: 102 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,102 @@
1+
{-# LANGUAGE ExistentialQuantification #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
5+
module Development.IDE.Plugin.CodeAction.Args where
6+
7+
import Control.Lens (alaf)
8+
import Data.Bifunctor (second)
9+
import Data.Monoid (Ap (..))
10+
import qualified Data.Text as T
11+
import Development.IDE
12+
import Development.IDE.GHC.Compat
13+
import Development.IDE.Plugin.CodeAction.Args.TH
14+
import Development.IDE.Plugin.CodeAction.ExactPrint
15+
import Development.IDE.Plugin.TypeLenses (GlobalBindingTypeSigsResult)
16+
import Development.IDE.Spans.LocalBindings (Bindings)
17+
import Development.IDE.Types.Exports (ExportsMap)
18+
import Development.IDE.Types.Options (IdeOptions)
19+
import Language.LSP.Types (TextEdit,
20+
type (|?) (..))
21+
import Retrie (Annotated (astA))
22+
import Retrie.ExactPrint (annsA)
23+
24+
data CodeActionArgs = CodeActionArgs
25+
{ caaExportsMap :: ExportsMap
26+
, caaIdeOptions :: IdeOptions
27+
, caaParsedModule :: Maybe ParsedModule
28+
, caaContents :: Maybe T.Text
29+
, caaDf :: Maybe DynFlags
30+
, caaAnnSource :: Maybe (Annotated ParsedSource)
31+
, caaTmr :: Maybe TcModuleResult
32+
, caaHar :: Maybe HieAstResult
33+
, caaBindings :: Maybe Bindings
34+
, caaGblSigs :: Maybe GlobalBindingTypeSigsResult
35+
, caaDiagnostics :: Diagnostic
36+
}
37+
38+
rewrite ::
39+
Maybe DynFlags ->
40+
Maybe (Annotated ParsedSource) ->
41+
[(T.Text, [Rewrite])] ->
42+
[(T.Text, [TextEdit])]
43+
rewrite (Just df) (Just ps) r
44+
| Right edit <-
45+
(traverse . traverse)
46+
(alaf Ap foldMap (rewriteToEdit df (annsA ps)))
47+
r =
48+
edit
49+
rewrite _ _ _ = []
50+
51+
-- we need this intermediate existential type to encapsulate functions producing code actions into a list
52+
data SomeAction = forall a. ToCodeAction a => SomeAction a
53+
54+
wrap :: ToCodeAction a => a -> SomeAction
55+
wrap = SomeAction
56+
57+
unwrap :: CodeActionArgs -> SomeAction -> [(T.Text, [TextEdit])]
58+
unwrap caa (SomeAction x) = toCodeAction caa x
59+
60+
class ToCodeAction a where
61+
toCodeAction :: CodeActionArgs -> a -> [(T.Text, [TextEdit])]
62+
63+
instance ToCodeAction [(T.Text, [TextEdit])] where
64+
toCodeAction _ = id
65+
66+
instance ToCodeAction [(T.Text, [Rewrite])] where
67+
toCodeAction CodeActionArgs{..} = rewrite caaDf caaAnnSource
68+
69+
instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where
70+
toCodeAction caa@CodeActionArgs{caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps
71+
toCodeAction _ _ = []
72+
73+
instance ToCodeAction [(T.Text, [TextEdit |? Rewrite])] where
74+
toCodeAction CodeActionArgs{..} r = second (concatMap go) <$> r
75+
where
76+
go (InL te) = [te]
77+
go (InR rw)
78+
| Just df <- caaDf,
79+
Just ps <- caaAnnSource,
80+
Right x <- rewriteToEdit df (annsA ps) rw
81+
= x
82+
| otherwise = []
83+
84+
-- generates instances of 'ToCodeAction',
85+
-- where the pattern is @instance ToCodeAction r => ToCodeAction (field -> r)@, for each field of 'CodeActionArgs'.
86+
-- therefore functions to produce code actions in CodeAction.hs can be wrapped into 'SomeAction' without modification.
87+
-- for types applied to 'Maybe', it generates to instances: for example,
88+
--
89+
-- @
90+
-- instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where
91+
-- toCodeAction caa@CodeActionArgs {caaDf = x} f = toCodeAction caa $ f x
92+
-- @
93+
--
94+
-- and
95+
--
96+
-- @
97+
-- instance ToCodeAction r => ToCodeAction (DynFlags -> r) where
98+
-- toCodeAction caa@CodeActionArgs {caaDf = Just x} f = toCodeAction caa $ f x
99+
-- toCodeAction _ _ = []
100+
-- @
101+
-- will be derived from 'caaDf'.
102+
mkInstances ''CodeActionArgs

‎ghcide/src/Development/IDE/Plugin/CodeAction/Args/TH.hs

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
3+
module Development.IDE.Plugin.CodeAction.Args.TH (mkInstances) where
4+
5+
import Language.Haskell.TH
6+
7+
mkInstances :: Name -> DecsQ
8+
mkInstances tyConName =
9+
reify tyConName >>= \case
10+
(TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys
11+
_ -> error "unsupported"
12+
where
13+
clsType = conT $ mkName "ToCodeAction"
14+
methodName = mkName "toCodeAction"
15+
tempType = varT $ mkName "r"
16+
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|]) []]
17+
genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty'))
18+
| _maybe == ''Maybe =
19+
do
20+
withMaybe <-
21+
instanceD
22+
(cxt [clsType `appT` tempType])
23+
(clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
24+
[commonFun dataConName fieldName]
25+
withoutMaybe <-
26+
instanceD
27+
(cxt [clsType `appT` tempType])
28+
(clsType `appT` ((arrowT `appT` pure ty') `appT` tempType))
29+
[ funD
30+
methodName
31+
[ clause [mkName "caa" `asP` recP dataConName [fieldPat fieldName $ conP 'Just [varP (mkName "x")]], varP (mkName "f")] (normalB [|$(varE methodName) caa $ f x|]) []
32+
, clause [wildP, wildP] (normalB [|[]|]) []
33+
]
34+
]
35+
pure [withMaybe, withoutMaybe]
36+
genForVar dataConName (fieldName, _, ty) =
37+
pure
38+
<$> instanceD
39+
(cxt [clsType `appT` tempType])
40+
(clsType `appT` ((arrowT `appT` pure ty) `appT` tempType))
41+
[commonFun dataConName fieldName]

0 commit comments

Comments
 (0)