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 <anka.213@gmail.com> Co-authored-by: Javier Neira <atreyu.bbb@gmail.com>

Author: 3 people

.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"
 

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

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

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)

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

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

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

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
 
 
 ------------------------------------------------------------------------------

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

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,31 +176,52 @@ 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 _ _ = []
 
 
 ------------------------------------------------------------------------------
 -- | 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 _ = []