From bda2d651bb9e5829622c2b9a811a5659c6d0f9f1 Mon Sep 17 00:00:00 2001 From: Elliot Marsden Date: Sat, 29 Oct 2022 23:10:41 +0100 Subject: [PATCH 1/3] Compile and get all tests passing --- .github/workflows/test.yml | 6 +- .../src/Development/IDE/GHC/ExactPrint.hs | 36 +++++------ .../src/Ide/Plugin/Splice.hs | 61 +++++++++++-------- 3 files changed, 56 insertions(+), 47 deletions(-) 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/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 8368efa249..bba038fe52 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,7 @@ 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 +class (Data ast, Default l, Typeable l, Outputable l, Outputable ast) => 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 +528,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 +542,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 +551,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 +564,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 +579,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..b1d4ed0f5d 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -53,12 +53,13 @@ import Development.IDE.GHC.ExactPrint import GHC.Exts 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 import qualified Language.LSP.Types.Lens as J +import GHC.Hs (SrcSpanAnn'(..)) +import qualified GHC.Types.Error as Error descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -135,7 +136,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 +237,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 @@ -267,7 +268,7 @@ findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] findSubSpansDesc srcSpan = sortOn (Down . SubSpan . fst) . mapMaybe - ( \(L spn _, e) -> do + ( \(L (SrcSpanAnn {locA = spn}) _, e) -> do guard (spn `isSubspanOf` srcSpan) pure (spn, e) ) @@ -321,7 +322,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 +349,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,15 +379,12 @@ 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') <- - either (fail . show) pure $ - parseAST @_ @(ast GhcPs) dflags uniq $ - showSDoc dflags $ ppr expr - let _anns' = setPrecedingLines expr' 0 1 anns - pure expr' + either (fail . show) pure $ + parseAST @_ @(ast GhcPs) dflags uniq $ + showSDoc dflags $ ppr expr data SearchResult r = Continue | Stop | Here r @@ -416,11 +422,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 (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) expr :: LHsExpr GhcPs) + | spanIsRelevant l -> case expr of HsSpliceE {} -> Here (spLoc, Expr) _ -> Continue @@ -430,23 +439,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 (SrcSpanAnn {locA = 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 (SrcSpanAnn {locA = 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 (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) decl :: LHsDecl GhcPs) + | spanIsRelevant l -> case decl of SpliceD {} -> Here (spLoc, HsDecl) _ -> Continue From 7b70faf42b2e9ba2ab19539085b1b036c8fdd668 Mon Sep 17 00:00:00 2001 From: Elliot Marsden Date: Sun, 30 Oct 2022 09:19:14 +0000 Subject: [PATCH 2/3] Add back-compat for GHC 9.0 --- .../src/Development/IDE/GHC/ExactPrint.hs | 12 +++++- .../src/Ide/Plugin/Splice.hs | 43 ++++++++++++++----- 2 files changed, 43 insertions(+), 12 deletions(-) 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 bba038fe52..ead2e04186 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -476,7 +476,17 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do modifyDeclsT (fmap DL.toList . go) a -class (Data ast, Default l, 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 diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index b1d4ed0f5d..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,6 +52,10 @@ 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 (uniqueSrcSpanT) @@ -58,8 +63,6 @@ import Language.LSP.Server import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as J -import GHC.Hs (SrcSpanAnn'(..)) -import qualified GHC.Types.Error as Error descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -264,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 (SrcSpanAnn {locA = spn}) _, e) -> do + ( \(L (AsSrcSpan spn) _, e) -> do guard (spn `isSubspanOf` srcSpan) pure (spn, e) ) @@ -354,11 +369,11 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e Right y -> unRenamedE dflags y _ -> pure Nothing let (warns, errs) = - #if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 902 (Error.getWarningMessages msgs, Error.getErrorMessages msgs) - #else +#else msgs - #endif +#endif pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl unless @@ -382,9 +397,15 @@ unRenamedE :: TransformT m (LocatedAn l (ast GhcPs)) unRenamedE dflags expr = do uniq <- show <$> uniqueSrcSpanT - either (fail . show) pure $ +#if __GLASGOW_HASKELL__ >= 902 + expr' <- +#else + (_anns, expr') <- +#endif + either (fail . show) pure $ parseAST @_ @(ast GhcPs) dflags uniq $ showSDoc dflags $ ppr expr + pure expr' data SearchResult r = Continue | Stop | Here r @@ -428,7 +449,7 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ mkQ Continue ( \case - (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) expr :: LHsExpr GhcPs) + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) expr :: LHsExpr GhcPs) | spanIsRelevant l -> case expr of HsSpliceE {} -> Here (spLoc, Expr) @@ -439,7 +460,7 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ #if __GLASGOW_HASKELL__ == 808 (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs)) #else - (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) pat :: LPat GhcPs) + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) pat :: LPat GhcPs) #endif | spanIsRelevant l -> case pat of @@ -447,14 +468,14 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ _ -> Continue _ -> Stop `extQ` \case - (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) ty :: LHsType GhcPs) + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) ty :: LHsType GhcPs) | spanIsRelevant l -> case ty of HsSpliceTy {} -> Here (spLoc, HsType) _ -> Continue _ -> Stop `extQ` \case - (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) decl :: LHsDecl GhcPs) + (L (AsSrcSpan l@(RealSrcSpan spLoc _)) decl :: LHsDecl GhcPs) | spanIsRelevant l -> case decl of SpliceD {} -> Here (spLoc, HsDecl) From 9aa3760eaf4f55f17d337b1d86554430ed812d05 Mon Sep 17 00:00:00 2001 From: Elliot Marsden Date: Sun, 30 Oct 2022 10:32:27 +0000 Subject: [PATCH 3/3] Update docs and build flags to enable for 9.2 --- docs/support/plugin-support.md | 2 +- haskell-language-server.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) 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