/
EmptyCase.hs
179 lines (150 loc) · 6.66 KB
/
EmptyCase.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonoLocalBinds #-}
module Wingman.EmptyCase where
import Control.Applicative (empty)
import Control.Monad
import Control.Monad.Except (runExcept)
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Aeson
import Data.Generics.Aliases (mkQ, GenericQ)
import Data.Generics.Schemes (everything)
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Data.Traversable
import Development.IDE (hscEnv)
import Development.IDE (realSrcSpanToRange)
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake (IdeState (..))
import Development.IDE.Core.UseStale
import Development.IDE.GHC.Compat
import Development.IDE.GHC.ExactPrint
import Development.IDE.Spans.LocalBindings (getLocalScope)
import Ide.Types
import Language.LSP.Server
import Language.LSP.Types
import OccName
import Prelude hiding (span)
import Prelude hiding (span)
import TcRnTypes (tcg_binds)
import Wingman.CodeGen (destructionFor)
import Wingman.GHC
import Wingman.Judgements
import Wingman.LanguageServer
import Wingman.Types
------------------------------------------------------------------------------
-- | The 'CommandId' for the empty case completion.
emptyCaseLensCommandId :: CommandId
emptyCaseLensCommandId = CommandId "wingman.emptyCase"
------------------------------------------------------------------------------
-- | A command function that just applies a 'WorkspaceEdit'.
workspaceEditHandler :: CommandFunction IdeState WorkspaceEdit
workspaceEditHandler _ideState wedit = do
_ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
return $ Right Null
------------------------------------------------------------------------------
-- | Provide the "empty case completion" code lens
codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLensProvider state plId (CodeLensParams _ _ (TextDocumentIdentifier uri))
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
let stale a = runStaleIde "codeLensProvider" state nfp a
ccs <- getClientCapabilities
liftIO $ fromMaybeT (Right $ List []) $ do
dflags <- getIdeDynflags state nfp
TrackedStale pm _ <- stale GetAnnotatedParsedSource
TrackedStale binds bind_map <- stale GetBindings
holes <- emptyCaseScrutinees state nfp
fmap (Right . List) $ for holes $ \(ss, ty) -> do
binds_ss <- liftMaybe $ mapAgeFrom bind_map ss
let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss
range = realSrcSpanToRange $ unTrack ss
matches <-
liftMaybe $
destructionFor
(foldMap (hySingleton . occName . fst) bindings)
ty
edits <- liftMaybe $ hush $
mkWorkspaceEdits dflags ccs uri (unTrack pm) $
graftMatchGroup (RealSrcSpan $ unTrack ss) $
noLoc matches
pure $
CodeLens range
(Just
$ mkLspCommand
plId
emptyCaseLensCommandId
(mkEmptyCaseLensDesc ty)
$ Just $ pure $ toJSON $ edits
)
Nothing
codeLensProvider _ _ _ = pure $ Right $ List []
scrutinzedType :: EmptyCaseSort Type -> Maybe Type
scrutinzedType (EmptyCase ty) = pure ty
scrutinzedType (EmptyLamCase ty) =
case tacticsSplitFunTy ty of
(_, _, tys, _) -> listToMaybe tys
------------------------------------------------------------------------------
-- | The description for the empty case lens.
mkEmptyCaseLensDesc :: Type -> T.Text
mkEmptyCaseLensDesc ty =
"Wingman: Complete case constructors (" <> T.pack (unsafeRender ty) <> ")"
------------------------------------------------------------------------------
-- | Silence an error.
hush :: Either e a -> Maybe a
hush (Left _) = Nothing
hush (Right a) = Just a
------------------------------------------------------------------------------
-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly
-- deals with top-level holes, in which we might need to fiddle with the
-- 'Match's that bind variables.
graftMatchGroup
:: SrcSpan
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Graft (Either String) ParsedSource
graftMatchGroup ss l =
hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case
L span (HsCase ext scrut mg@_) -> do
pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l }
L span (HsLamCase ext mg@_) -> do
pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l }
(_ :: LHsExpr GhcPs) -> pure Nothing
fromMaybeT :: Functor m => a -> MaybeT m a -> m a
fromMaybeT def = fmap (fromMaybe def) . runMaybeT
------------------------------------------------------------------------------
-- | Find the last typechecked module, and find the most specific span, as well
-- as the judgement at the given range.
emptyCaseScrutinees
:: IdeState
-> NormalizedFilePath
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
emptyCaseScrutinees state nfp = do
let stale a = runStaleIde "emptyCaseScrutinees" state nfp a
TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck
let tcg' = unTrack tcg
hscenv <- stale GhcSessionDeps
let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg
fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do
ty <- MaybeT
. fmap (scrutinzedType <=< sequence)
. traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg')
$ scrutinee
case null $ tacticsGetDataCons ty of
True -> pure empty
False ->
case ss of
RealSrcSpan r -> do
rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
pure $ Just (rss', ty)
UnhelpfulSpan _ -> empty
data EmptyCaseSort a
= EmptyCase a
| EmptyLamCase a
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
------------------------------------------------------------------------------
-- | Get the 'SrcSpan' and scrutinee of every empty case.
emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
emptyCaseQ = everything (<>) $ mkQ mempty $ \case
L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee)
L new_span (expr@(LamCase [])) -> pure (new_span, EmptyLamCase expr)
(_ :: LHsExpr GhcTc) -> mempty