diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index b8a9abf4c2..ce1e50dc4e 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -194,7 +194,7 @@ jobs: name: Test hls-fourmolu-plugin 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" - - 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') + - if: matrix.test && matrix.ghc != '9.2.1' name: Test hls-tactics-plugin test suite 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" diff --git a/cabal-ghc90.project b/cabal-ghc90.project index b4c2490712..3ef649ff8b 100644 --- a/cabal-ghc90.project +++ b/cabal-ghc90.project @@ -40,7 +40,7 @@ index-state: 2022-01-11T22:05:45Z constraints: -- These plugins don't work on GHC9 yet -- Add a plugin needs remove the -flag but also update ghc bounds in hls.cabal - haskell-language-server +ignore-plugins-ghc-bounds -stylishhaskell -tactic, + haskell-language-server +ignore-plugins-ghc-bounds -stylishhaskell, ghc-lib-parser ^>= 9.0 -- although we are not building all plugins cabal solver phase is run for all packages diff --git a/configuration-ghc-901.nix b/configuration-ghc-901.nix index 2f411d8579..62d83c9cc0 100644 --- a/configuration-ghc-901.nix +++ b/configuration-ghc-901.nix @@ -3,7 +3,6 @@ let disabledPlugins = [ - "hls-tactics-plugin" "hls-brittany-plugin" "hls-stylish-haskell-plugin" ]; @@ -20,7 +19,6 @@ let (pkgs.lib.concatStringsSep " " [ "-f-brittany" "-f-stylishhaskell" - "-f-tactic" ]) { }; # YOLO diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index d767bb1a7f..2a593bbf73 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -67,7 +67,10 @@ module Development.IDE.GHC.Compat.Core ( -- slightly unsafe setUnsafeGlobalDynFlags, -- * Linear Haskell +#if !MIN_VERSION_ghc(9,0,0) Scaled, + unrestricted, +#endif scaledThing, -- * Interface Files IfaceExport, @@ -127,6 +130,7 @@ module Development.IDE.GHC.Compat.Core ( TyCoRep.CoercionTy ), pattern FunTy, + pattern ConPatIn, #if !MIN_VERSION_ghc(9,2,0) Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, #endif @@ -537,6 +541,7 @@ import GHC.Parser.Header hiding (getImports) import qualified GHC.Linker.Loader as Linker import GHC.Linker.Types import GHC.Parser.Lexer hiding (initParserState) +import GHC.Parser.Annotation (EpAnn (..)) import GHC.Platform.Ways import GHC.Runtime.Context (InteractiveImport (..)) #else @@ -877,6 +882,9 @@ dataConExTyCoVars = DataCon.dataConExTyVars type Scaled a = a scaledThing :: Scaled a -> a scaledThing = id + +unrestricted :: a -> Scaled a +unrestricted = id #endif mkVisFunTys :: [Scaled Type] -> Type -> Type @@ -953,6 +961,18 @@ type PlainGhcException = Plain.PlainGhcException type PlainGhcException = Plain.GhcException #endif +#if MIN_VERSION_ghc(9,0,0) +-- This is from the old api, but it still simplifies +pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs +#if MIN_VERSION_ghc(9,2,0) +pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args + where + ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args +#else +pattern ConPatIn con args = ConPat NoExtField con args +#endif +#endif + initDynLinker, initObjLinker :: HscEnv -> IO () initDynLinker = #if !MIN_VERSION_ghc(9,0,0) diff --git a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs index dde391ee82..dff5363719 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs @@ -29,6 +29,7 @@ import Language.LSP.Types hiding (CodeLens, CodeAction) import Wingman.AbstractLSP.Types import Wingman.EmptyCase (fromMaybeT) import Wingman.LanguageServer (getTacticConfig, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) +import Wingman.StaticPlugin (enableQuasiQuotes) import Wingman.Types @@ -110,7 +111,7 @@ runContinuation plId cont state (fc, b) = do GraftEdit gr -> do ccs <- lift getClientCapabilities TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - case mkWorkspaceEdits le_dflags ccs (fc_uri le_fileContext) (unTrack pm) gr of + case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of Left errs -> pure $ Just $ ResponseError { _code = InternalError diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index add592ec00..3b143d96ae 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -56,7 +57,7 @@ destructMatches use_field_puns f scrut t jdg = do Just (dcs, apps) -> fmap unzipTrace $ for dcs $ \dc -> do let con = RealDataCon dc - ev = concatMap mkEvidence $ dataConInstArgTys dc apps + ev = concatMap (mkEvidence . scaledThing) $ dataConInstArgTys dc apps -- We explicitly do not need to add the method hypothesis to -- #syn_scoped method_hy = foldMap evidenceToHypothesis ev @@ -184,7 +185,7 @@ conLikeInstOrigArgTys' -- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument. conLikeInstOrigArgTys' con uniTys = let exvars = conLikeExTys con - in conLikeInstOrigArgTys con $ + in fmap scaledThing $ conLikeInstOrigArgTys con $ uniTys ++ fmap mkTyVarTy exvars -- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys' -- unifies the second argument with DataCon's universals followed by existentials. @@ -228,7 +229,11 @@ destructLambdaCase' use_field_puns f jdg = do when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic let g = jGoal jdg case splitFunTy_maybe (unCType g) of +#if __GLASGOW_HASKELL__ >= 900 + Just (_multiplicity, arg, _) | isAlgType arg -> +#else Just (arg, _) | isAlgType arg -> +#endif fmap (fmap noLoc lambdaCase) <$> destructMatches use_field_puns f Nothing (CType arg) jdg _ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g diff --git a/plugins/hls-tactics-plugin/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs index 9aea0bf5eb..3c1b40ba1f 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Context.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Wingman.Context where import Control.Arrow @@ -12,6 +14,10 @@ import Wingman.GHC (normalizeType) import Wingman.Judgements.Theta import Wingman.Types +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Tc.Utils.TcType +#endif + mkContext :: Config diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs index 6b0523be2f..7c675c36f9 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs @@ -88,7 +88,7 @@ scrutinzedType :: EmptyCaseSort Type -> Maybe Type scrutinzedType (EmptyCase ty) = pure ty scrutinzedType (EmptyLamCase ty) = case tacticsSplitFunTy ty of - (_, _, tys, _) -> listToMaybe tys + (_, _, tys, _) -> listToMaybe $ fmap scaledThing tys ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs index 944cab82d5..8a2da92770 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs @@ -21,6 +21,10 @@ import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT) import Wingman.StaticPlugin (pattern MetaprogramSyntax) import Wingman.Types +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Tc.Utils.TcType +#endif + tcTyVar_maybe :: Type -> Maybe Var tcTyVar_maybe ty | Just ty' <- tcView ty = tcTyVar_maybe ty' @@ -57,7 +61,7 @@ isFunction _ = True ------------------------------------------------------------------------------ -- | Split a function, also splitting out its quantified variables and theta -- context. -tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Type], Type) +tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Scaled Type], Type) tacticsSplitFunTy t = let (vars, theta, t') = tcSplitNestedSigmaTys t (args, res) = tcSplitFunTys t' @@ -179,7 +183,11 @@ allOccNames = everything (<>) $ mkQ mempty $ \case ------------------------------------------------------------------------------ -- | Unpack the relevant parts of a 'Match' +#if __GLASGOW_HASKELL__ >= 900 +pattern AMatch :: HsMatchContext (NoGhcTc GhcPs) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs) +#else pattern AMatch :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs) +#endif pattern AMatch ctx pats body <- Match { m_ctxt = ctx , m_pats = fmap fromPatCompat -> pats @@ -192,7 +200,7 @@ pattern SingleLet bind pats val expr <- HsLet _ (HsValBinds _ (ValBinds _ (bagToList -> - [(L _ (FunBind _ (L _ bind) (MG _ (L _ [L _ (AMatch _ pats val)]) _) _ _))]) _)) + [L _ (FunBind {fun_id = (L _ bind), fun_matches = (MG _ (L _ [L _ (AMatch _ pats val)]) _)})]) _)) (L _ expr) @@ -255,7 +263,11 @@ pattern LamCase matches <- -- @Just False@ if it can't be homomorphic -- @Just True@ if it can lambdaCaseable :: Type -> Maybe Bool +#if __GLASGOW_HASKELL__ >= 900 +lambdaCaseable (splitFunTy_maybe -> Just (_multiplicity, arg, res)) +#else lambdaCaseable (splitFunTy_maybe -> Just (arg, res)) +#endif | isJust (algebraicTyCon arg) = Just $ isJust $ algebraicTyCon res lambdaCaseable _ = Nothing diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs index a3e23595fd..f1731a8a33 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs @@ -26,6 +26,10 @@ import GHC.Generics import Wingman.GHC import Wingman.Types +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Tc.Utils.TcType +#endif + ------------------------------------------------------------------------------ -- | Something we've learned about the type environment. @@ -172,16 +176,32 @@ excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name ------------------------------------------------------------------------------ -- | Extract evidence from 'AbsBinds' in scope. absBinds :: SrcSpan -> LHsBindLR GhcTc GhcTc -> [PredType] +#if __GLASGOW_HASKELL__ >= 900 +absBinds dst (L src (FunBind w _ _ _)) + | dst `isSubspanOf` src + = wrapper w +absBinds dst (L src (AbsBinds _ _ h _ _ z _)) +#else absBinds dst (L src (AbsBinds _ _ h _ _ _ _)) - | dst `isSubspanOf` src = fmap idType h +#endif + | dst `isSubspanOf` src + = fmap idType h +#if __GLASGOW_HASKELL__ >= 900 + <> foldMap (absBinds dst) z +#endif absBinds _ _ = [] ------------------------------------------------------------------------------ -- | Extract evidence from 'HsWrapper's in scope wrapperBinds :: SrcSpan -> LHsExpr GhcTc -> [PredType] +#if __GLASGOW_HASKELL__ >= 900 +wrapperBinds dst (L src (XExpr (WrapExpr (HsWrap h _)))) +#else wrapperBinds dst (L src (HsWrap _ h _)) - | dst `isSubspanOf` src = wrapper h +#endif + | dst `isSubspanOf` src + = wrapper h wrapperBinds _ _ = [] @@ -189,14 +209,19 @@ wrapperBinds _ _ = [] -- | Extract evidence from the 'ConPatOut's bound in this 'Match'. matchBinds :: SrcSpan -> LMatch GhcTc (LHsExpr GhcTc) -> [PredType] matchBinds dst (L src (Match _ _ pats _)) - | dst `isSubspanOf` src = everything (<>) (mkQ mempty patBinds) pats + | dst `isSubspanOf` src + = everything (<>) (mkQ mempty patBinds) pats matchBinds _ _ = [] ------------------------------------------------------------------------------ -- | Extract evidence from a 'ConPatOut'. patBinds :: Pat GhcTc -> [PredType] -patBinds ConPatOut{ pat_dicts = dicts } +#if __GLASGOW_HASKELL__ >= 900 +patBinds (ConPat{ pat_con_ext = ConPatTc { cpt_dicts = dicts }}) +#else +patBinds (ConPatOut { pat_dicts = dicts }) +#endif = fmap idType dicts patBinds _ = [] diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index b73d69430c..104de36d50 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -308,8 +308,8 @@ getAlreadyDestructed (unTrack -> span) (unTrack -> binds) = getSpanAndTypeAtHole :: Tracked age Range - -> Tracked age (HieASTs b) - -> Maybe (Tracked age RealSrcSpan, b) + -> Tracked age (HieASTs Type) + -> Maybe (Tracked age RealSrcSpan, Type) getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of @@ -402,7 +402,11 @@ buildPatHy prov (fromPatCompat -> p0) = (RealDataCon $ tupleDataCon boxity $ length pats) tys $ zip [0.. ] pats - ConPatOut (L _ con) args _ _ _ f _ -> +#if __GLASGOW_HASKELL__ >= 900 + ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} -> +#else + ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} -> +#endif case f of PrefixCon l_pgt -> mkDerivedConHypothesis prov con args $ zip [0..] l_pgt @@ -563,7 +567,11 @@ wingmanRules plId = do L span (HsVar _ (L _ name)) | isHole (occName name) -> maybeToList $ srcSpanToRange span +#if __GLASGOW_HASKELL__ >= 900 + L span (HsUnboundVar _ occ) +#else L span (HsUnboundVar _ (TrueExprHole occ)) +#endif | isHole occ -> maybeToList $ srcSpanToRange span #if __GLASGOW_HASKELL__ <= 808 diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index 013c6ccb5e..a9ed4e791e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -294,7 +294,7 @@ homoFilter codomain domain = liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r liftLambdaCase nil f t = case tacticsSplitFunTy t of - (_, _, arg : _, res) -> f res arg + (_, _, arg : _, res) -> f res $ scaledThing arg _ -> nil diff --git a/plugins/hls-tactics-plugin/src/Wingman/Naming.hs b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs index 975607da1d..ab0c0e23d9 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Naming.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Wingman.Naming where import Control.Arrow @@ -18,6 +20,10 @@ import Development.IDE.GHC.Compat.Core hiding (IsFunction) import Text.Hyphenation (hyphenate, english_US) import Wingman.GHC (tcTyVar_maybe) +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Tc.Utils.TcType +#endif + ------------------------------------------------------------------------------ -- | A classification of a variable, for which we have specific naming rules. @@ -38,11 +44,11 @@ data Purpose pattern IsPredicate :: Type pattern IsPredicate <- - (tcSplitFunTys -> ([isFunTy -> False], isBoolTy -> True)) + (tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True)) pattern IsFunction :: [Type] -> Type -> Type pattern IsFunction args res <- - (tcSplitFunTys -> (args@(_:_), res)) + (first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res)) pattern IsString :: Type pattern IsString <- diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index 82be432a3a..ce7fb8863b 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -3,6 +3,7 @@ module Wingman.StaticPlugin ( staticPlugin , metaprogramHoleName + , enableQuasiQuotes , pattern WingmanMetaprogram , pattern MetaprogramSyntax ) where @@ -13,7 +14,11 @@ import Development.IDE.GHC.Compat.Util import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes)) import Generics.SYB import Ide.Types +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Driver.Plugins (purePlugin) +#else import Plugins (purePlugin) +#endif staticPlugin :: DynFlagsModifications staticPlugin = mempty diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index ef8025fd89..6e27b05cd4 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -23,7 +23,6 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as S import Data.Traversable (for) -import DataCon import Development.IDE.GHC.Compat hiding (empty) import GHC.Exts import GHC.SourceGen ((@@)) @@ -131,7 +130,8 @@ intros' params = rule $ \jdg -> do let g = jGoal jdg case tacticsSplitFunTy $ unCType g of (_, _, [], _) -> cut -- failure $ GoalMismatch "intros" g - (_, _, args, res) -> do + (_, _, scaledArgs, res) -> do + let args = fmap scaledThing scaledArgs ctx <- ask let gen_names = mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) args occs = case params of @@ -144,7 +144,7 @@ intros' params = rule $ \jdg -> do bound_occs = fmap fst bindings hy' = lambdaHypothesis top_hole bindings jdg' = introduce ctx hy' - $ withNewGoal (CType $ mkVisFunTys (drop num_occs args) res) jdg + $ withNewGoal (CType $ mkVisFunTys (drop num_occs scaledArgs) res) jdg ext <- newSubgoal jdg' pure $ ext @@ -290,6 +290,7 @@ apply (Unsaturated n) hi = tracing ("apply' " <> show (hi_name hi)) $ do . blacklistingDestruct . flip withNewGoal jdg . CType + . scaledThing ) saturated_args pure $ ext @@ -523,6 +524,7 @@ applyByType ty = tracing ("applyByType " <> show ty) $ do . blacklistingDestruct . flip withNewGoal jdg . CType + . scaledThing ) args app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg pure $ @@ -539,7 +541,7 @@ nary :: Int -> TacticsM () nary n = do a <- newUnivar b <- newUnivar - applyByType $ mkVisFunTys (replicate n a) b + applyByType $ mkVisFunTys (replicate n $ unrestricted a) b self :: TacticsM () @@ -557,7 +559,7 @@ cata :: HyInfo CType -> TacticsM () cata hi = do (_, _, calling_args, _) <- tacticsSplitFunTy . unCType <$> getDefiningType - freshened_args <- traverse freshTyvars calling_args + freshened_args <- traverse (freshTyvars . scaledThing) calling_args diff <- hyDiff $ destruct hi -- For for every destructed term, check to see if it can unify with any of @@ -623,7 +625,7 @@ with_arg = rule $ \jdg -> do let g = jGoal jdg fresh_ty <- newUnivar a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg - f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [fresh_ty] g) jdg + f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [unrestricted fresh_ty] g) jdg pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a diff --git a/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs b/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs index a3164f713f..11ba11e2ae 100644 --- a/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs +++ b/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs @@ -7,11 +7,10 @@ module AutoTupleSpec where import Control.Monad (replicateM) import Control.Monad.State (evalState) import Data.Either (isRight) -import OccName (mkVarOcc) +import Development.IDE.GHC.Compat.Core ( mkVarOcc, mkBoxedTupleTy ) import System.IO.Unsafe import Test.Hspec import Test.QuickCheck -import TysWiredIn (mkBoxedTupleTy) import Wingman.Judgements (mkFirstJudgement) import Wingman.Machinery import Wingman.Tactics (auto') diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index cc97666a2a..9322b0912b 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -59,7 +59,7 @@ spec = do describe "theta" $ do autoTest 12 10 "AutoThetaFix" - autoTest 7 20 "AutoThetaRankN" + autoTest 7 27 "AutoThetaRankN" autoTest 6 10 "AutoThetaGADT" autoTest 6 8 "AutoThetaGADTDestruct" autoTest 4 8 "AutoThetaEqCtx" diff --git a/plugins/hls-tactics-plugin/test/UnificationSpec.hs b/plugins/hls-tactics-plugin/test/UnificationSpec.hs index db39fdfe10..148a40eaaa 100644 --- a/plugins/hls-tactics-plugin/test/UnificationSpec.hs +++ b/plugins/hls-tactics-plugin/test/UnificationSpec.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module UnificationSpec where @@ -12,14 +14,19 @@ import Data.Maybe (mapMaybe) import qualified Data.Set as S import Data.Traversable import Data.Tuple (swap) -import TcType (substTy, tcGetTyVar_maybe) +import Development.IDE.GHC.Compat.Core (substTy, mkBoxedTupleTy) import Test.Hspec import Test.QuickCheck -import TysWiredIn (mkBoxedTupleTy) import Wingman.GHC import Wingman.Machinery (newUnivar) import Wingman.Types +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Tc.Utils.TcType (tcGetTyVar_maybe) +#else +import TcType (tcGetTyVar_maybe) +#endif + spec :: Spec spec = describe "unification" $ do diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 82ab426b4f..08ecb83c2e 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -24,6 +24,7 @@ import qualified Data.Text.IO as T import Ide.Plugin.Tactic as Tactic import Language.LSP.Types import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) +import qualified Language.LSP.Types.Lens as J import System.Directory (doesFileExist) import System.FilePath import Test.Hls @@ -64,7 +65,7 @@ runSessionForTactics = runSessionWithServer' [plugin] def - (def { messageTimeout = 5 } ) + (def { messageTimeout = 20 } ) fullCaps tacticPath @@ -137,6 +138,7 @@ mkGoldenTest eq invocations input = expected <- liftIO $ T.readFile expected_name liftIO $ edited `eq` expected + mkCodeLensTest :: FilePath -> SpecWith () diff --git a/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.expected.hs b/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.expected.hs index 3f0d534fe3..23d96223f3 100644 --- a/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.expected.hs @@ -4,5 +4,5 @@ showMe :: (forall x. Show x => x -> String) -> Int -> String showMe f = f showedYou :: Int -> String -showedYou = showMe show +showedYou = showMe (\x -> show x) diff --git a/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.hs b/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.hs index 8385d1ebcd..0e92ac35f3 100644 --- a/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.hs +++ b/plugins/hls-tactics-plugin/test/golden/AutoThetaRankN.hs @@ -4,5 +4,5 @@ showMe :: (forall x. Show x => x -> String) -> Int -> String showMe f = f showedYou :: Int -> String -showedYou = showMe _ +showedYou = showMe (\x -> _) diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 6d23c2ffb9..bda42f3e00 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -19,7 +19,7 @@ packages: - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin -# - ./plugins/hls-tactics-plugin +- ./plugins/hls-tactics-plugin - ./plugins/hls-brittany-plugin # - ./plugins/hls-stylish-haskell-plugin - ./plugins/hls-floskell-plugin @@ -49,6 +49,7 @@ extra-deps: - monad-dijkstra-0.1.1.3 - multistate-0.8.0.3 - retrie-1.1.0.0 +- refinery-0.4.0.0 # shake-bench dependencies - Chart-1.9.3 @@ -77,7 +78,6 @@ flags: pedantic: true ignore-plugins-ghc-bounds: true - tactic: false # Dependencies fail stylishHaskell: false retrie: diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 9c0beaeb7a..fd12fe39d1 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -231,7 +231,7 @@ typedHoleTests = testGroup "typed hole code actions" [ , "foo x = maxBound" ] - , expectFailIfGhc9 "The wingman plugin doesn't yet compile in GHC9" $ + , expectFailIfGhc92 "The wingman plugin doesn't yet compile in GHC92" $ testCase "doesn't work when wingman is active" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles.hs" "haskell" @@ -266,8 +266,8 @@ typedHoleTests = testGroup "typed hole code actions" [ , " stuff (A a) = A (a + 1)" ] - , expectFailIfGhc9 "The wingman plugin doesn't yet compile in GHC9" $ - testCase "doesnt show more suggestions when wingman is active" $ + , expectFailIfGhc92 "The wingman plugin doesn't yet compile in GHC92" $ + testCase "doesnt show more suggestions when wingman is active" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "TypedHoles2.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" @@ -355,12 +355,8 @@ unusedTermTests = testGroup "unused term code actions" [ $ Just CodeActionQuickFix `notElem` kinds ] -expectFailIfGhc9 :: String -> TestTree -> TestTree -expectFailIfGhc9 reason = - case ghcVersion of - GHC90 -> expectFailBecause reason - GHC92 -> expectFailBecause reason - _ -> id +expectFailIfGhc92 :: String -> TestTree -> TestTree +expectFailIfGhc92 = knownBrokenForGhcVersions [GHC92] disableWingman :: Session () disableWingman =