Skip to content

Commit d640d13

Browse files
isovectoranka-213jneira
authored
GHC-9.0 support for hls-tactics-plugin (#2581)
* Initial partially broken ghc9 support for tactics It compiles and most tests succeed, but some fail. In particular, the ones where it should suggest `show` fails to find that as a possible solution and fails to find evidence for `Show a`. * Enable tactics plugin for nix as well * Wingman does support ghc9 now * Fix stack support for tactics ghc-9.0.1 * Enable tests for tactics on ghc-9 on ci * Actually enable tactics for ghc-9 on nix * Wingman: Improve test failure messages Previously when wingman fails to find a solution, the test failure would say "Timed out when waiting for a message". Now it instead prints the error message from wingman. * Get theta * Make wrapper theta discovery more reliable * Fix AutoThetaRankN * Fix FmapJoin and FmapJoinInLet * Fix MetaBegin * Cleanup * Fix merge More fixing the merge No, seriously fix the merge Fix a broken merge * Need a comma * Try a better ConPatIn * Oops * its a nightmare * i hate ci * ok that fixes the conpat * Maybe this is the end of it * ci * refinery * undo some changes * no more tctypes? * maybe it builds now * omg * om F g * expect fail on 9.2 * fix * fix again Co-authored-by: Andreas Källberg <[email protected]> Co-authored-by: Javier Neira <[email protected]>
1 parent 70bb0ab commit d640d13

23 files changed

+137
-45
lines changed

‎.github/workflows/test.yml

+1-1
Original file line numberDiff line numberDiff line change
@@ -194,7 +194,7 @@ jobs:
194194
name: Test hls-fourmolu-plugin
195195
run: cabal test hls-fourmolu-plugin --test-options="$TEST_OPTS" || cabal test hls-fourmolu-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-fourmolu-plugin --test-options="$TEST_OPTS"
196196

197-
- if: matrix.test && matrix.ghc != '9.0.1' && matrix.ghc != '9.0.2' && matrix.ghc != '9.2.1' && !(matrix.os == 'ubuntu-latest' && matrix.ghc == '8.6.5')
197+
- if: matrix.test && matrix.ghc != '9.2.1'
198198
name: Test hls-tactics-plugin test suite
199199
run: cabal test hls-tactics-plugin --test-options="$TEST_OPTS" || cabal test hls-tactics-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-tactics-plugin --test-options="$TEST_OPTS"
200200

‎cabal-ghc90.project

+1-1
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ index-state: 2022-01-11T22:05:45Z
4040
constraints:
4141
-- These plugins don't work on GHC9 yet
4242
-- Add a plugin needs remove the -flag but also update ghc bounds in hls.cabal
43-
haskell-language-server +ignore-plugins-ghc-bounds -stylishhaskell -tactic,
43+
haskell-language-server +ignore-plugins-ghc-bounds -stylishhaskell,
4444
ghc-lib-parser ^>= 9.0
4545

4646
-- although we are not building all plugins cabal solver phase is run for all packages

‎configuration-ghc-901.nix

-2
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@
33

44
let
55
disabledPlugins = [
6-
"hls-tactics-plugin"
76
"hls-brittany-plugin"
87
"hls-stylish-haskell-plugin"
98
];
@@ -20,7 +19,6 @@ let
2019
(pkgs.lib.concatStringsSep " " [
2120
"-f-brittany"
2221
"-f-stylishhaskell"
23-
"-f-tactic"
2422
]) { };
2523

2624
# YOLO

‎ghcide/src/Development/IDE/GHC/Compat/Core.hs

+20
Original file line numberDiff line numberDiff line change
@@ -67,7 +67,10 @@ module Development.IDE.GHC.Compat.Core (
6767
-- slightly unsafe
6868
setUnsafeGlobalDynFlags,
6969
-- * Linear Haskell
70+
#if !MIN_VERSION_ghc(9,0,0)
7071
Scaled,
72+
unrestricted,
73+
#endif
7174
scaledThing,
7275
-- * Interface Files
7376
IfaceExport,
@@ -127,6 +130,7 @@ module Development.IDE.GHC.Compat.Core (
127130
TyCoRep.CoercionTy
128131
),
129132
pattern FunTy,
133+
pattern ConPatIn,
130134
#if !MIN_VERSION_ghc(9,2,0)
131135
Development.IDE.GHC.Compat.Core.splitForAllTyCoVars,
132136
#endif
@@ -537,6 +541,7 @@ import GHC.Parser.Header hiding (getImports)
537541
import qualified GHC.Linker.Loader as Linker
538542
import GHC.Linker.Types
539543
import GHC.Parser.Lexer hiding (initParserState)
544+
import GHC.Parser.Annotation (EpAnn (..))
540545
import GHC.Platform.Ways
541546
import GHC.Runtime.Context (InteractiveImport (..))
542547
#else
@@ -877,6 +882,9 @@ dataConExTyCoVars = DataCon.dataConExTyVars
877882
type Scaled a = a
878883
scaledThing :: Scaled a -> a
879884
scaledThing = id
885+
886+
unrestricted :: a -> Scaled a
887+
unrestricted = id
880888
#endif
881889

882890
mkVisFunTys :: [Scaled Type] -> Type -> Type
@@ -953,6 +961,18 @@ type PlainGhcException = Plain.PlainGhcException
953961
type PlainGhcException = Plain.GhcException
954962
#endif
955963

964+
#if MIN_VERSION_ghc(9,0,0)
965+
-- This is from the old api, but it still simplifies
966+
pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs
967+
#if MIN_VERSION_ghc(9,2,0)
968+
pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args
969+
where
970+
ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args
971+
#else
972+
pattern ConPatIn con args = ConPat NoExtField con args
973+
#endif
974+
#endif
975+
956976
initDynLinker, initObjLinker :: HscEnv -> IO ()
957977
initDynLinker =
958978
#if !MIN_VERSION_ghc(9,0,0)

‎plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Language.LSP.Types hiding (CodeLens, CodeAction)
2929
import Wingman.AbstractLSP.Types
3030
import Wingman.EmptyCase (fromMaybeT)
3131
import Wingman.LanguageServer (getTacticConfig, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams)
32+
import Wingman.StaticPlugin (enableQuasiQuotes)
3233
import Wingman.Types
3334

3435

@@ -110,7 +111,7 @@ runContinuation plId cont state (fc, b) = do
110111
GraftEdit gr -> do
111112
ccs <- lift getClientCapabilities
112113
TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
113-
case mkWorkspaceEdits le_dflags ccs (fc_uri le_fileContext) (unTrack pm) gr of
114+
case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of
114115
Left errs ->
115116
pure $ Just $ ResponseError
116117
{ _code = InternalError

‎plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs

+7-2
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE OverloadedLabels #-}
34
{-# LANGUAGE OverloadedStrings #-}
@@ -56,7 +57,7 @@ destructMatches use_field_puns f scrut t jdg = do
5657
Just (dcs, apps) ->
5758
fmap unzipTrace $ for dcs $ \dc -> do
5859
let con = RealDataCon dc
59-
ev = concatMap mkEvidence $ dataConInstArgTys dc apps
60+
ev = concatMap (mkEvidence . scaledThing) $ dataConInstArgTys dc apps
6061
-- We explicitly do not need to add the method hypothesis to
6162
-- #syn_scoped
6263
method_hy = foldMap evidenceToHypothesis ev
@@ -184,7 +185,7 @@ conLikeInstOrigArgTys'
184185
-- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument.
185186
conLikeInstOrigArgTys' con uniTys =
186187
let exvars = conLikeExTys con
187-
in conLikeInstOrigArgTys con $
188+
in fmap scaledThing $ conLikeInstOrigArgTys con $
188189
uniTys ++ fmap mkTyVarTy exvars
189190
-- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys'
190191
-- unifies the second argument with DataCon's universals followed by existentials.
@@ -228,7 +229,11 @@ destructLambdaCase' use_field_puns f jdg = do
228229
when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic
229230
let g = jGoal jdg
230231
case splitFunTy_maybe (unCType g) of
232+
#if __GLASGOW_HASKELL__ >= 900
233+
Just (_multiplicity, arg, _) | isAlgType arg ->
234+
#else
231235
Just (arg, _) | isAlgType arg ->
236+
#endif
232237
fmap (fmap noLoc lambdaCase) <$>
233238
destructMatches use_field_puns f Nothing (CType arg) jdg
234239
_ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g

‎plugins/hls-tactics-plugin/src/Wingman/Context.hs

+6
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE CPP #-}
2+
13
module Wingman.Context where
24

35
import Control.Arrow
@@ -12,6 +14,10 @@ import Wingman.GHC (normalizeType)
1214
import Wingman.Judgements.Theta
1315
import Wingman.Types
1416

17+
#if __GLASGOW_HASKELL__ >= 900
18+
import GHC.Tc.Utils.TcType
19+
#endif
20+
1521

1622
mkContext
1723
:: Config

‎plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ scrutinzedType :: EmptyCaseSort Type -> Maybe Type
8888
scrutinzedType (EmptyCase ty) = pure ty
8989
scrutinzedType (EmptyLamCase ty) =
9090
case tacticsSplitFunTy ty of
91-
(_, _, tys, _) -> listToMaybe tys
91+
(_, _, tys, _) -> listToMaybe $ fmap scaledThing tys
9292

9393

9494
------------------------------------------------------------------------------

‎plugins/hls-tactics-plugin/src/Wingman/GHC.hs

+14-2
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,10 @@ import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT)
2121
import Wingman.StaticPlugin (pattern MetaprogramSyntax)
2222
import Wingman.Types
2323

24+
#if __GLASGOW_HASKELL__ >= 900
25+
import GHC.Tc.Utils.TcType
26+
#endif
27+
2428

2529
tcTyVar_maybe :: Type -> Maybe Var
2630
tcTyVar_maybe ty | Just ty' <- tcView ty = tcTyVar_maybe ty'
@@ -57,7 +61,7 @@ isFunction _ = True
5761
------------------------------------------------------------------------------
5862
-- | Split a function, also splitting out its quantified variables and theta
5963
-- context.
60-
tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Type], Type)
64+
tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Scaled Type], Type)
6165
tacticsSplitFunTy t
6266
= let (vars, theta, t') = tcSplitNestedSigmaTys t
6367
(args, res) = tcSplitFunTys t'
@@ -179,7 +183,11 @@ allOccNames = everything (<>) $ mkQ mempty $ \case
179183

180184
------------------------------------------------------------------------------
181185
-- | Unpack the relevant parts of a 'Match'
186+
#if __GLASGOW_HASKELL__ >= 900
187+
pattern AMatch :: HsMatchContext (NoGhcTc GhcPs) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)
188+
#else
182189
pattern AMatch :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)
190+
#endif
183191
pattern AMatch ctx pats body <-
184192
Match { m_ctxt = ctx
185193
, m_pats = fmap fromPatCompat -> pats
@@ -192,7 +200,7 @@ pattern SingleLet bind pats val expr <-
192200
HsLet _
193201
(HsValBinds _
194202
(ValBinds _ (bagToList ->
195-
[(L _ (FunBind _ (L _ bind) (MG _ (L _ [L _ (AMatch _ pats val)]) _) _ _))]) _))
203+
[L _ (FunBind {fun_id = (L _ bind), fun_matches = (MG _ (L _ [L _ (AMatch _ pats val)]) _)})]) _))
196204
(L _ expr)
197205

198206

@@ -255,7 +263,11 @@ pattern LamCase matches <-
255263
-- @Just False@ if it can't be homomorphic
256264
-- @Just True@ if it can
257265
lambdaCaseable :: Type -> Maybe Bool
266+
#if __GLASGOW_HASKELL__ >= 900
267+
lambdaCaseable (splitFunTy_maybe -> Just (_multiplicity, arg, res))
268+
#else
258269
lambdaCaseable (splitFunTy_maybe -> Just (arg, res))
270+
#endif
259271
| isJust (algebraicTyCon arg)
260272
= Just $ isJust $ algebraicTyCon res
261273
lambdaCaseable _ = Nothing

‎plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs

+29-4
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,10 @@ import GHC.Generics
2626
import Wingman.GHC
2727
import Wingman.Types
2828

29+
#if __GLASGOW_HASKELL__ >= 900
30+
import GHC.Tc.Utils.TcType
31+
#endif
32+
2933

3034
------------------------------------------------------------------------------
3135
-- | Something we've learned about the type environment.
@@ -172,31 +176,52 @@ excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name
172176
------------------------------------------------------------------------------
173177
-- | Extract evidence from 'AbsBinds' in scope.
174178
absBinds :: SrcSpan -> LHsBindLR GhcTc GhcTc -> [PredType]
179+
#if __GLASGOW_HASKELL__ >= 900
180+
absBinds dst (L src (FunBind w _ _ _))
181+
| dst `isSubspanOf` src
182+
= wrapper w
183+
absBinds dst (L src (AbsBinds _ _ h _ _ z _))
184+
#else
175185
absBinds dst (L src (AbsBinds _ _ h _ _ _ _))
176-
| dst `isSubspanOf` src = fmap idType h
186+
#endif
187+
| dst `isSubspanOf` src
188+
= fmap idType h
189+
#if __GLASGOW_HASKELL__ >= 900
190+
<> foldMap (absBinds dst) z
191+
#endif
177192
absBinds _ _ = []
178193

179194

180195
------------------------------------------------------------------------------
181196
-- | Extract evidence from 'HsWrapper's in scope
182197
wrapperBinds :: SrcSpan -> LHsExpr GhcTc -> [PredType]
198+
#if __GLASGOW_HASKELL__ >= 900
199+
wrapperBinds dst (L src (XExpr (WrapExpr (HsWrap h _))))
200+
#else
183201
wrapperBinds dst (L src (HsWrap _ h _))
184-
| dst `isSubspanOf` src = wrapper h
202+
#endif
203+
| dst `isSubspanOf` src
204+
= wrapper h
185205
wrapperBinds _ _ = []
186206

187207

188208
------------------------------------------------------------------------------
189209
-- | Extract evidence from the 'ConPatOut's bound in this 'Match'.
190210
matchBinds :: SrcSpan -> LMatch GhcTc (LHsExpr GhcTc) -> [PredType]
191211
matchBinds dst (L src (Match _ _ pats _))
192-
| dst `isSubspanOf` src = everything (<>) (mkQ mempty patBinds) pats
212+
| dst `isSubspanOf` src
213+
= everything (<>) (mkQ mempty patBinds) pats
193214
matchBinds _ _ = []
194215

195216

196217
------------------------------------------------------------------------------
197218
-- | Extract evidence from a 'ConPatOut'.
198219
patBinds :: Pat GhcTc -> [PredType]
199-
patBinds ConPatOut{ pat_dicts = dicts }
220+
#if __GLASGOW_HASKELL__ >= 900
221+
patBinds (ConPat{ pat_con_ext = ConPatTc { cpt_dicts = dicts }})
222+
#else
223+
patBinds (ConPatOut { pat_dicts = dicts })
224+
#endif
200225
= fmap idType dicts
201226
patBinds _ = []
202227

‎plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs

+11-3
Original file line numberDiff line numberDiff line change
@@ -308,8 +308,8 @@ getAlreadyDestructed (unTrack -> span) (unTrack -> binds) =
308308

309309
getSpanAndTypeAtHole
310310
:: Tracked age Range
311-
-> Tracked age (HieASTs b)
312-
-> Maybe (Tracked age RealSrcSpan, b)
311+
-> Tracked age (HieASTs Type)
312+
-> Maybe (Tracked age RealSrcSpan, Type)
313313
getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do
314314
join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
315315
case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of
@@ -402,7 +402,11 @@ buildPatHy prov (fromPatCompat -> p0) =
402402
(RealDataCon $ tupleDataCon boxity $ length pats)
403403
tys
404404
$ zip [0.. ] pats
405-
ConPatOut (L _ con) args _ _ _ f _ ->
405+
#if __GLASGOW_HASKELL__ >= 900
406+
ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} ->
407+
#else
408+
ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} ->
409+
#endif
406410
case f of
407411
PrefixCon l_pgt ->
408412
mkDerivedConHypothesis prov con args $ zip [0..] l_pgt
@@ -563,7 +567,11 @@ wingmanRules plId = do
563567
L span (HsVar _ (L _ name))
564568
| isHole (occName name) ->
565569
maybeToList $ srcSpanToRange span
570+
#if __GLASGOW_HASKELL__ >= 900
571+
L span (HsUnboundVar _ occ)
572+
#else
566573
L span (HsUnboundVar _ (TrueExprHole occ))
574+
#endif
567575
| isHole occ ->
568576
maybeToList $ srcSpanToRange span
569577
#if __GLASGOW_HASKELL__ <= 808

‎plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -294,7 +294,7 @@ homoFilter codomain domain =
294294
liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r
295295
liftLambdaCase nil f t =
296296
case tacticsSplitFunTy t of
297-
(_, _, arg : _, res) -> f res arg
297+
(_, _, arg : _, res) -> f res $ scaledThing arg
298298
_ -> nil
299299

300300

‎plugins/hls-tactics-plugin/src/Wingman/Naming.hs

+8-2
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE CPP #-}
2+
13
module Wingman.Naming where
24

35
import Control.Arrow
@@ -18,6 +20,10 @@ import Development.IDE.GHC.Compat.Core hiding (IsFunction)
1820
import Text.Hyphenation (hyphenate, english_US)
1921
import Wingman.GHC (tcTyVar_maybe)
2022

23+
#if __GLASGOW_HASKELL__ >= 900
24+
import GHC.Tc.Utils.TcType
25+
#endif
26+
2127

2228
------------------------------------------------------------------------------
2329
-- | A classification of a variable, for which we have specific naming rules.
@@ -38,11 +44,11 @@ data Purpose
3844

3945
pattern IsPredicate :: Type
4046
pattern IsPredicate <-
41-
(tcSplitFunTys -> ([isFunTy -> False], isBoolTy -> True))
47+
(tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True))
4248

4349
pattern IsFunction :: [Type] -> Type -> Type
4450
pattern IsFunction args res <-
45-
(tcSplitFunTys -> (args@(_:_), res))
51+
(first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res))
4652

4753
pattern IsString :: Type
4854
pattern IsString <-

‎plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs

+5
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
module Wingman.StaticPlugin
44
( staticPlugin
55
, metaprogramHoleName
6+
, enableQuasiQuotes
67
, pattern WingmanMetaprogram
78
, pattern MetaprogramSyntax
89
) where
@@ -13,7 +14,11 @@ import Development.IDE.GHC.Compat.Util
1314
import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes))
1415
import Generics.SYB
1516
import Ide.Types
17+
#if __GLASGOW_HASKELL__ >= 900
18+
import GHC.Driver.Plugins (purePlugin)
19+
#else
1620
import Plugins (purePlugin)
21+
#endif
1722

1823
staticPlugin :: DynFlagsModifications
1924
staticPlugin = mempty

0 commit comments

Comments
 (0)