mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Make splice plugin compatible with GHC 9.2 (#2816)
* Compile and get all tests passing * Add back-compat for GHC 9.0 * Update docs and build flags to enable for 9.2
This commit is contained in:
parent
2b94f8581a
commit
4cb9ff1391
6
.github/workflows/test.yml
vendored
6
.github/workflows/test.yml
vendored
@ -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"
|
||||
|
||||
|
@ -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 |
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 _ = "<Annotated ParsedSource>"
|
||||
|
||||
|
||||
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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user