Skip to content

Commit 3d017aa

Browse files
wz1000wz1000
committed
Make it compile with 8.10, handle errors, move LocalBinding to ghcide
1 parent 7565509 commit 3d017aa

File tree

8 files changed

+71
-191
lines changed

8 files changed

+71
-191
lines changed

‎cabal.project

+1-1
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,6 @@ package ghcide
2020

2121
write-ghc-environment-files: never
2222

23-
index-state: 2020-09-09T00:00:00Z
23+
index-state: 2020-09-16T00:00:00Z
2424

2525
allow-newer: data-tree-print:base

‎ghcide

Submodule ghcide updated 28 files

‎haskell-language-server.cabal

+4-6
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ library
7070
, process
7171
, unordered-containers
7272

73-
ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing
73+
ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wincomplete-uni-patterns
7474

7575
if flag(pedantic)
7676
ghc-options: -Werror
@@ -92,15 +92,14 @@ executable haskell-language-server
9292
Ide.Plugin.Pragmas
9393
Ide.Plugin.Retrie
9494
Ide.Plugin.StylishHaskell
95-
Ide.LocalBindings
9695
Ide.Plugin.Tactic
9796
Ide.Plugin.Tactic.Types
9897
Ide.Plugin.Tactic.Machinery
9998
Ide.Plugin.Tactic.Tactics
10099
Ide.TreeTransform
101100

102101
ghc-options:
103-
-threaded -Wall -Wno-name-shadowing -Wredundant-constraints
102+
-threaded -Wall -Wno-name-shadowing -Wredundant-constraints -Wincomplete-uni-patterns
104103
-- allow user RTS overrides
105104
-rtsopts
106105
-- disable idle GC
@@ -118,7 +117,6 @@ executable haskell-language-server
118117
, deepseq
119118
, floskell ^>=0.10
120119
, fourmolu ^>=0.1
121-
, fingertree
122120
, ghc
123121
, ghc-boot-th
124122
, ghcide >=0.1
@@ -150,7 +148,7 @@ executable haskell-language-server
150148
, unordered-containers
151149
, ghc-source-gen
152150
, refinery
153-
, ghc-exactprint
151+
, ghc-exactprint >= 0.6.3.2
154152

155153
if flag(agpl)
156154
build-depends: brittany
@@ -166,7 +164,7 @@ executable haskell-language-server-wrapper
166164
other-modules: Paths_haskell_language_server
167165
autogen-modules: Paths_haskell_language_server
168166
ghc-options:
169-
-threaded -Wall -Wno-name-shadowing -Wredundant-constraints
167+
-threaded -Wall -Wno-name-shadowing -Wredundant-constraints -Wincomplete-uni-patterns
170168
-- allow user RTS overrides
171169
-rtsopts
172170
-- disable idle GC

‎plugins/default/src/Ide/LocalBindings.hs

-115
This file was deleted.

‎plugins/default/src/Ide/Plugin/Tactic.hs

+31-41
Original file line numberDiff line numberDiff line change
@@ -23,16 +23,15 @@ import Data.Maybe
2323
import qualified Data.Text as T
2424
import Data.Traversable
2525
import Development.IDE.Core.PositionMapping
26-
import Development.IDE.Core.RuleTypes (TcModuleResult (tmrModule), TypeCheck (..), GhcSession(..), GetHieAst (..), refMap)
26+
import Development.IDE.Core.RuleTypes
2727
import Development.IDE.Core.Service (runAction)
2828
import Development.IDE.Core.Shake (useWithStale, IdeState (..))
2929
import Development.IDE.GHC.Compat
30-
import Development.IDE.GHC.Error (srcSpanToRange)
30+
import Development.IDE.GHC.Error (realSrcSpanToRange)
3131
import Development.IDE.GHC.Util (hscEnv)
3232
import Development.Shake (Action)
3333
import GHC.Generics (Generic)
3434
import HscTypes (hsc_dflags)
35-
import Ide.LocalBindings (bindings, mostSpecificSpan, holify)
3635
import Ide.Plugin (mkLspCommand)
3736
import Ide.Plugin.Tactic.Machinery
3837
import Ide.Plugin.Tactic.Tactics
@@ -42,7 +41,7 @@ import Ide.Types
4241
import Language.Haskell.LSP.Core (clientCapabilities)
4342
import Language.Haskell.LSP.Types
4443
import OccName
45-
import Type
44+
import qualified FastString
4645

4746

4847
descriptor :: PluginId -> PluginDescriptor
@@ -137,20 +136,17 @@ codeActionProvider :: CodeActionProvider
137136
codeActionProvider _conf state plId (TextDocumentIdentifier uri) range _ctx
138137
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri =
139138
fromMaybeT (Right $ List []) $ do
140-
(pos, mss, jdg) <- MaybeT $ judgmentForHole state nfp range
141-
case mss of
142-
L span' (HsUnboundVar _ _) -> do
143-
resulting_range <-
144-
liftMaybe $ toCurrentRange pos =<< srcSpanToRange span'
145-
actions <- lift $
146-
-- This foldMap is over the function monoid.
147-
foldMap commandProvider enabledTactics
148-
plId
149-
uri
150-
resulting_range
151-
jdg
152-
pure $ Right $ List actions
153-
_ -> pure $ Right $ codeActions []
139+
(pos, span, jdg) <- MaybeT $ judgementForHole state nfp range
140+
resulting_range <-
141+
liftMaybe $ toCurrentRange pos $ realSrcSpanToRange span
142+
actions <- lift $
143+
-- This foldMap is over the function monoid.
144+
foldMap commandProvider enabledTactics
145+
plId
146+
uri
147+
resulting_range
148+
jdg
149+
pure $ Right $ List actions
154150
codeActionProvider _ _ _ _ _ _ = pure $ Right $ codeActions []
155151

156152

@@ -208,38 +204,33 @@ data TacticParams = TacticParams
208204
------------------------------------------------------------------------------
209205
-- | Find the last typechecked module, and find the most specific span, as well
210206
-- as the judgement at the given range.
211-
judgmentForHole
207+
judgementForHole
212208
:: IdeState
213209
-> NormalizedFilePath
214210
-> Range
215-
-> IO (Maybe (PositionMapping, LHsExpr GhcTc, Judgement))
216-
judgmentForHole state nfp range = runMaybeT $ do
217-
(tmr, pos) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp
211+
-> IO (Maybe (PositionMapping, RealSrcSpan, Judgement))
212+
judgementForHole state nfp range = runMaybeT $ do
213+
(asts, pos) <- MaybeT $ runIde state $ useWithStale GetHieAst nfp
218214
range' <- liftMaybe $ fromCurrentRange pos range
219-
let span = rangeToSrcSpan (fromNormalizedFilePath nfp) range'
220-
mod = tmrModule tmr
221215

222-
(mss@(L span' (HsVar _ (L _ v))))
223-
<- liftMaybe $ mostSpecificSpan @_ @GhcTc span (tm_typechecked_source mod)
224-
rss <-
225-
liftMaybe $ case span' of
226-
RealSrcSpan rss -> Just rss
227-
_ -> Nothing
216+
(rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts $ hieAst asts) $ \fs ast ->
217+
case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of
218+
Nothing -> Nothing
219+
Just ast' -> do
220+
ty <- listToMaybe $ nodeType $ nodeInfo ast'
221+
pure (nodeSpan ast', ty)
228222

229-
(har, _) <- MaybeT $ runIde state $ useWithStale GetHieAst nfp
230-
let refs = refMap har
231-
binds2 = bindings refs
223+
(binds,_) <- MaybeT $ runIde state $ useWithStale GetBindings nfp
232224

233-
let goal = varType v
234-
hyps = hypothesisFromBindings rss binds2
235-
pure (pos, holify binds2 mss, Judgement hyps $ CType goal)
225+
let hyps = hypothesisFromBindings rss binds
226+
pure (pos, rss, Judgement hyps $ CType goal)
236227

237228

238229
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction TacticParams
239230
tacticCmd tac lf state (TacticParams uri range var_name)
240231
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri =
241232
fromMaybeT (Right Null, Nothing) $ do
242-
(pos, _, jdg) <- MaybeT $ judgmentForHole state nfp range
233+
(pos, _, jdg) <- MaybeT $ judgementForHole state nfp range
243234
-- Ok to use the stale 'ModIface', since all we need is its 'DynFlags'
244235
-- which don't change very often.
245236
(hscenv, _) <- MaybeT $ runIde state $ useWithStale GhcSession nfp
@@ -258,10 +249,9 @@ tacticCmd tac lf state (TacticParams uri range var_name)
258249
let span = rangeToSrcSpan (fromNormalizedFilePath nfp) range'
259250
g = graft span res
260251
let response = transform dflags (clientCapabilities lf) uri g pm
261-
pure
262-
( Right Null
263-
, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams response)
264-
)
252+
pure $ case response of
253+
Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res))
254+
Left err -> (Left $ ResponseError InternalError (T.pack err) Nothing, Nothing)
265255
tacticCmd _ _ _ _ =
266256
pure ( Left $ ResponseError InvalidRequest (T.pack "Bad URI") Nothing
267257
, Nothing

‎plugins/default/src/Ide/Plugin/Tactic/Machinery.hs

+22-14
Original file line numberDiff line numberDiff line change
@@ -5,18 +5,16 @@
55
{-# LANGUAGE MultiParamTypeClasses #-}
66
{-# LANGUAGE TypeSynonymInstances #-}
77
{-# LANGUAGE ViewPatterns #-}
8+
{-# LANGUAGE ViewPatterns #-}
89

910
module Ide.Plugin.Tactic.Machinery where
1011

11-
import Control.Arrow
1212
import Control.Monad.State (get, modify, evalStateT)
1313
import Data.Char
1414
import Data.Function
1515
import Data.List
1616
import Data.Map (Map)
1717
import qualified Data.Map as M
18-
import Data.Set (Set)
19-
import qualified Data.Set as S
2018
import Data.Traversable
2119
import DataCon
2220
import Development.IDE.GHC.Compat
@@ -25,19 +23,21 @@ import DynFlags (unsafeGlobalDynFlags)
2523
import qualified FastString as FS
2624
import GHC.Generics
2725
import GHC.SourceGen.Overloaded
28-
import Ide.LocalBindings
26+
import Development.IDE.Spans.LocalBindings
2927
import Name
3028
import Outputable hiding ((<>))
3129
import Refinery.Tactic
3230
import TcType
3331
import Type
3432
import TysWiredIn (listTyCon, pairTyCon, intTyCon, floatTyCon, doubleTyCon, charTyCon)
33+
import Data.Maybe
34+
import SrcLoc
3535

3636

3737
------------------------------------------------------------------------------
3838
-- | Orphan instance for producing holes when attempting to solve tactics.
3939
instance MonadExtract (LHsExpr GhcPs) ProvableM where
40-
hole = pure $ noLoc $ HsVar noExt $ noLoc $ Unqual $ mkVarOcc "_"
40+
hole = pure $ noLoc $ HsVar noExtField $ noLoc $ Unqual $ mkVarOcc "_"
4141

4242

4343
------------------------------------------------------------------------------
@@ -59,12 +59,17 @@ hypothesisFromBindings span bs = buildHypothesis (getLocalScope bs span)
5959

6060
------------------------------------------------------------------------------
6161
-- | Convert a @Set Id@ into a hypothesis.
62-
buildHypothesis :: Set Id -> Map OccName CType
62+
buildHypothesis :: [(Name, Maybe Type)] -> Map OccName CType
6363
buildHypothesis
6464
= M.fromList
65-
. fmap (occName &&& CType . varType)
66-
. filter (isAlpha . head . occNameString . occName)
67-
. S.toList
65+
. mapMaybe go
66+
where
67+
go (n, t)
68+
| Just ty <- t
69+
, isAlpha . head . occNameString $ occ = Just (occ, CType ty)
70+
| otherwise = Nothing
71+
where
72+
occ = occName n
6873

6974

7075
------------------------------------------------------------------------------
@@ -236,18 +241,21 @@ buildDataCon hy dc apps = do
236241
pure
237242
. noLoc
238243
. foldl' (@@)
239-
(HsVar noExt $ noLoc $ Unqual $ nameOccName $ dataConName dc)
244+
(HsVar noExtField $ noLoc $ Unqual $ nameOccName $ dataConName dc)
240245
$ fmap unLoc sgs
241246

242247

243248
------------------------------------------------------------------------------
244249
-- | Convert a DAML compiler Range to a GHC SrcSpan
245250
-- TODO(sandy): this doesn't belong here
246251
rangeToSrcSpan :: String -> Range -> SrcSpan
247-
rangeToSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) =
248-
mkSrcSpan
249-
(mkSrcLoc (FS.fsLit file) (startLn + 1) (startCh + 1))
250-
(mkSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1))
252+
rangeToSrcSpan file range = RealSrcSpan $ rangeToRealSrcSpan file range
253+
254+
rangeToRealSrcSpan :: String -> Range -> RealSrcSpan
255+
rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) =
256+
mkRealSrcSpan
257+
(mkRealSrcLoc (FS.fsLit file) (startLn + 1) (startCh + 1))
258+
(mkRealSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1))
251259

252260
------------------------------------------------------------------------------
253261
-- | Print something

0 commit comments

Comments
 (0)