diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index bae4d974a8..6a11cb2edc 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -106,7 +106,7 @@ jobs: os: ${{ runner.os }} - name: Build - run: cabal build + run: cabal build - name: Set test options # run the tests without parallelism, otherwise tasty will attempt to run @@ -148,7 +148,7 @@ jobs: env: HLS_TEST_EXE: hls HLS_WRAPPER_TEST_EXE: hls-wrapper - run: cabal test wrapper-test --test-options="$TEST_OPTS --rerun-log-file .tasty-rerun-log-wrapper" + run: cabal test wrapper-test --test-options="$TEST_OPTS --rerun-log-file .tasty-rerun-log-wrapper" - if: matrix.test && matrix.ghc != '9.2.4' && matrix.ghc != '9.4.2' name: Test hls-brittany-plugin @@ -178,7 +178,7 @@ jobs: name: Test hls-haddock-comments-plugin run: cabal test hls-haddock-comments-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-haddock-comments-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.2.4' && matrix.ghc != '9.4.2' + - if: matrix.test && matrix.ghc != '9.4.2' name: Test hls-splice-plugin run: cabal test hls-splice-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-splice-plugin --test-options="$TEST_OPTS" diff --git a/docs/support/plugin-support.md b/docs/support/plugin-support.md index 1bab3b4b90..4aa8530cf2 100644 --- a/docs/support/plugin-support.md +++ b/docs/support/plugin-support.md @@ -65,4 +65,4 @@ For example, a plugin to provide a formatter which has itself been abandoned has | `hls-haddock-comments-plugin` | 3 | 9.2, 9.4 | | `hls-stan-plugin` | 3 | 8.6, 9.0, 9.2, 9.4 | | `hls-retrie-plugin` | 3 | 9.2, 9.4 | -| `hls-splice-plugin` | 3 | 9.2, 9.4 | +| `hls-splice-plugin` | 3 | 9.4 | diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c2938ed6e7..ec62f7cd6d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -266,7 +266,7 @@ common pragmas cpp-options: -Dhls_pragmas common splice - if flag(splice) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) + if flag(splice) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-splice-plugin ^>=1.0.0.1 cpp-options: -Dhls_splice diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 8368efa249..ead2e04186 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -25,6 +25,7 @@ module Development.IDE.GHC.ExactPrint Annotate, setPrecedingLinesT, #else + setPrecedingLines, addParens, addParensToCtxt, modifyAnns, @@ -56,6 +57,7 @@ import Control.Monad.Trans.Except import Control.Monad.Zip import Data.Bifunctor import Data.Bool (bool) +import Data.Default (Default) import qualified Data.DList as DL import Data.Either.Extra (mapLeft) import Data.Foldable (Foldable (fold)) @@ -101,7 +103,13 @@ import GHC (EpAnn (..), spanAsAnchor) import GHC.Parser.Annotation (AnnContext (..), DeltaPos (SameLine), - EpaLocation (EpaDelta)) + EpaLocation (EpaDelta), + deltaPos) +#endif + +#if MIN_VERSION_ghc(9,2,0) +setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a +setPrecedingLines ast n c = setEntryDP ast (deltaPos n c) #endif ------------------------------------------------------------------------------ @@ -114,10 +122,10 @@ instance Pretty Log where instance Show (Annotated ParsedSource) where show _ = "" - + instance NFData (Annotated ParsedSource) where rnf = rwhnf - + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) @@ -374,7 +382,7 @@ graftWithM dst trans = Graft $ \dflags a -> do #if MIN_VERSION_ghc(9,2,0) val'' <- hoistTransform (either Fail.fail pure) $ - annotate dflags True $ maybeParensAST val' + annotate dflags False $ maybeParensAST val' pure val'' #else (anns, val'') <- @@ -468,7 +476,17 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do modifyDeclsT (fmap DL.toList . go) a -class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where +-- In 9.2+, we need `Default l` to do `setPrecedingLines` on annotated elements. +-- In older versions, we pass around annotations explicitly, so the instance isn't needed. +class + ( Data ast + , Typeable l + , Outputable l + , Outputable ast +#if MIN_VERSION_ghc(9,2,0) + , Default l +#endif + ) => ASTElement l ast | ast -> l where parseAST :: Parser (LocatedAn l ast) maybeParensAST :: LocatedAn l ast -> LocatedAn l ast {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with @@ -520,6 +538,7 @@ fixAnns ParsedModule {..} = ------------------------------------------------------------------------------ + -- | Given an 'LHSExpr', compute its exactprint annotations. -- Note that this function will throw away any existing annotations (and format) annotate :: (ASTElement l ast, Outputable l) @@ -533,7 +552,7 @@ annotate dflags needs_space ast = do let rendered = render dflags ast #if MIN_VERSION_ghc(9,2,0) expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered - pure expr' + pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space) #else (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns @@ -542,6 +561,7 @@ annotate dflags needs_space ast = do -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) +#if !MIN_VERSION_ghc(9,2,0) -- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain -- multiple matches. To work around this, we split the single -- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', @@ -554,17 +574,6 @@ annotateDecl dflags let set_matches matches = ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} -#if MIN_VERSION_ghc(9,2,0) - alts' <- for alts $ \alt -> do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags $ set_matches [alt] - lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case - (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) - -> pure alt' - _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" - - pure $ L src $ set_matches alts' -#else (anns', alts') <- fmap unzip $ for alts $ \alt -> do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags $ set_matches [alt] @@ -580,7 +589,8 @@ annotateDecl dflags ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast #if MIN_VERSION_ghc(9,2,0) - lift $ mapLeft show $ parseDecl dflags uniq rendered + expr' <- lift $ mapLeft show $ parseDecl dflags uniq rendered + pure $ setPrecedingLines expr' 1 0 #else (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered let anns' = setPrecedingLines expr' 1 0 anns diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index aabb3b09ee..9b817ec898 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -51,10 +52,13 @@ import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint import GHC.Exts +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Parser.Annotation (SrcSpanAnn'(..)) +import qualified GHC.Types.Error as Error +#endif import Ide.Plugin.Splice.Types import Ide.Types -import Language.Haskell.GHC.ExactPrint (setPrecedingLines, - uniqueSrcSpanT) +import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) import Language.LSP.Server import Language.LSP.Types import Language.LSP.Types.Capabilities @@ -135,7 +139,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do graftSpliceWith :: forall ast. HasSplice AnnListItem ast => - Maybe (SrcSpan, Located (ast GhcPs)) -> + Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs)) -> Maybe (Either String WorkspaceEdit) graftSpliceWith expandeds = expandeds <&> \(_, expanded) -> @@ -236,11 +240,11 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) = where adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit adjustTextEdits eds = - let Just minStart = - L.fold - (L.premap (view J.range) L.minimum) - eds - in adjustLine minStart <$> eds + let minStart = + case L.fold (L.premap (view J.range) L.minimum) eds of + Nothing -> error "impossible" + Just v -> v + in adjustLine minStart <$> eds adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit) adjustATextEdits = fmap $ \case @@ -263,11 +267,23 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) = J.range %~ \r -> if r == bad then ran else bad +-- Define a pattern to get hold of a `SrcSpan` from the location part of a +-- `GenLocated`. In GHC >= 9.2 this will be a SrcSpanAnn', with annotations; +-- earlier it will just be a plain `SrcSpan`. +{-# COMPLETE AsSrcSpan #-} +#if __GLASGOW_HASKELL__ >= 902 +pattern AsSrcSpan :: SrcSpan -> SrcSpanAnn' a +pattern AsSrcSpan locA <- SrcSpanAnn {locA} +#else +pattern AsSrcSpan :: SrcSpan -> SrcSpan +pattern AsSrcSpan loc <- loc +#endif + findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] findSubSpansDesc srcSpan = sortOn (Down . SubSpan . fst) . mapMaybe - ( \(L spn _, e) -> do + ( \(L (AsSrcSpan spn) _, e) -> do guard (spn `isSubspanOf` srcSpan) pure (spn, e) ) @@ -321,7 +337,7 @@ manualCalcEdit :: manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do (warns, resl) <- ExceptT $ do - ((warns, errs), eresl) <- + (msgs, eresl) <- initTcWithGbl hscEnv typechkd srcSpan $ case classifyAST spliceContext of IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ @@ -348,8 +364,16 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e Util.try @_ @SomeException $ (fst <$> expandSplice astP spl) ) - Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr + Just <$> case eExpr of + Left x -> pure $ L _spn x + Right y -> unRenamedE dflags y _ -> pure Nothing + let (warns, errs) = +#if __GLASGOW_HASKELL__ >= 902 + (Error.getWarningMessages msgs, Error.getErrorMessages msgs) +#else + msgs +#endif pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl unless @@ -370,14 +394,17 @@ unRenamedE :: (Fail.MonadFail m, HasSplice l ast) => DynFlags -> ast GhcRn -> - TransformT m (Located (ast GhcPs)) + TransformT m (LocatedAn l (ast GhcPs)) unRenamedE dflags expr = do uniq <- show <$> uniqueSrcSpanT - (anns, expr') <- +#if __GLASGOW_HASKELL__ >= 902 + expr' <- +#else + (_anns, expr') <- +#endif either (fail . show) pure $ - parseAST @_ @(ast GhcPs) dflags uniq $ - showSDoc dflags $ ppr expr - let _anns' = setPrecedingLines expr' 0 1 anns + parseAST @_ @(ast GhcPs) dflags uniq $ + showSDoc dflags $ ppr expr pure expr' data SearchResult r = @@ -416,11 +443,14 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ RealSrcSpan -> GenericQ (SearchResult (RealSrcSpan, SpliceContext)) detectSplice spn = + let + spanIsRelevant x = RealSrcSpan spn Nothing `isSubspanOf` x + in mkQ Continue ( \case - (L l@(RealSrcSpan spLoc _) expr :: LHsExpr GhcPs) - | RealSrcSpan spn Nothing `isSubspanOf` l -> + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) expr :: LHsExpr GhcPs) + | spanIsRelevant l -> case expr of HsSpliceE {} -> Here (spLoc, Expr) _ -> Continue @@ -430,23 +460,23 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ #if __GLASGOW_HASKELL__ == 808 (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs)) #else - (L l@(RealSrcSpan spLoc _) pat :: LPat GhcPs) + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) pat :: LPat GhcPs) #endif - | RealSrcSpan spn Nothing `isSubspanOf` l -> + | spanIsRelevant l -> case pat of SplicePat{} -> Here (spLoc, Pat) _ -> Continue _ -> Stop `extQ` \case - (L l@(RealSrcSpan spLoc _) ty :: LHsType GhcPs) - | RealSrcSpan spn Nothing `isSubspanOf` l -> + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) ty :: LHsType GhcPs) + | spanIsRelevant l -> case ty of HsSpliceTy {} -> Here (spLoc, HsType) _ -> Continue _ -> Stop `extQ` \case - (L l@(RealSrcSpan spLoc _) decl :: LHsDecl GhcPs) - | RealSrcSpan spn Nothing `isSubspanOf` l -> + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) decl :: LHsDecl GhcPs) + | spanIsRelevant l -> case decl of SpliceD {} -> Here (spLoc, HsDecl) _ -> Continue