Make splice plugin compatible with GHC 9.2 (#2816)

eddiejessup · web-flow · commit 4cb9ff13912b · 2022-11-03T16:23:50.000Z
* Compile and get all tests passing

* Add back-compat for GHC 9.0

* Update docs and build flags to enable for 9.2
diff --git 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
@@ -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
@@ -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
@@ -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
diff --git 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
