diff --git a/hls-splice-plugin.cabal b/hls-splice-plugin.cabal --- a/hls-splice-plugin.cabal +++ b/hls-splice-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-splice-plugin -version: 1.0.3.0 +version: 1.1.0.0 synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes @@ -42,7 +42,7 @@ , foldl , ghc , ghc-exactprint - , ghcide ^>=1.9 + , ghcide ^>=1.10 , hls-plugin-api ^>= 1.6 , hls-refactor-plugin , lens diff --git a/src/Ide/Plugin/Splice.hs b/src/Ide/Plugin/Splice.hs --- a/src/Ide/Plugin/Splice.hs +++ b/src/Ide/Plugin/Splice.hs @@ -51,6 +51,7 @@ import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT)) #if MIN_VERSION_ghc(9,4,1) import GHC.Data.Bag (Bag) #endif @@ -295,24 +296,56 @@ OneToOneAST :: HasSplice AnnListItem ast => Proxy# ast -> SpliceClass IsHsDecl :: SpliceClass +#if MIN_VERSION_ghc(9,5,0) +data HsSpliceCompat pass + = UntypedSplice (HsUntypedSplice pass) + | TypedSplice (LHsExpr pass) +#endif + + class (Outputable (ast GhcRn), ASTElement l (ast GhcPs)) => HasSplice l ast where type SpliceOf ast :: Kinds.Type -> Kinds.Type - type SpliceOf ast = HsSplice matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs) expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) instance HasSplice AnnListItem HsExpr where +#if MIN_VERSION_ghc(9,5,0) + type SpliceOf HsExpr = HsSpliceCompat + matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl) + matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl) +#else + type SpliceOf HsExpr = HsSplice matchSplice _ (HsSpliceE _ spl) = Just spl +#endif matchSplice _ _ = Nothing +#if MIN_VERSION_ghc(9,5,0) + expandSplice _ (UntypedSplice e) = fmap (first Right) $ rnUntypedSpliceExpr e + expandSplice _ (TypedSplice e) = fmap (first Right) $ rnTypedSplice e +#else expandSplice _ = fmap (first Right) . rnSpliceExpr +#endif instance HasSplice AnnListItem Pat where +#if MIN_VERSION_ghc(9,5,0) + type SpliceOf Pat = HsUntypedSplice +#else + type SpliceOf Pat = HsSplice +#endif matchSplice _ (SplicePat _ spl) = Just spl matchSplice _ _ = Nothing - expandSplice _ = rnSplicePat + expandSplice _ = +#if MIN_VERSION_ghc(9,5,0) + fmap (first (Left . unLoc . utsplice_result . snd )) . +#endif + rnSplicePat instance HasSplice AnnListItem HsType where +#if MIN_VERSION_ghc(9,5,0) + type SpliceOf HsType = HsUntypedSplice +#else + type SpliceOf HsType = HsSplice +#endif matchSplice _ (HsSpliceTy _ spl) = Just spl matchSplice _ _ = Nothing expandSplice _ = fmap (first Right) . rnSpliceType @@ -349,7 +382,7 @@ (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- eitherM (fail . show) pure - $ lift + $ TransformT $ lift ( lift $ Util.try @_ @SomeException $ (fst <$> rnTopSpliceDecls spl) @@ -362,7 +395,7 @@ (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- eitherM (fail . show) pure - $ lift + $ TransformT $ lift ( lift $ Util.try @_ @SomeException $ (fst <$> expandSplice astP spl) @@ -401,10 +434,15 @@ showBag :: Error.Diagnostic a => Bag (Error.MsgEnvelope a) -> String showBag = show . fmap (fmap toDiagnosticMessage) -toDiagnosticMessage :: Error.Diagnostic a => a -> Error.DiagnosticMessage +toDiagnosticMessage :: forall a. Error.Diagnostic a => a -> Error.DiagnosticMessage toDiagnosticMessage message = Error.DiagnosticMessage - { diagMessage = Error.diagnosticMessage message + { diagMessage = Error.diagnosticMessage +#if MIN_VERSION_ghc(9,5,0) + (Error.defaultDiagnosticOpts @a) +#endif + message + , diagReason = Error.diagnosticReason message , diagHints = Error.diagnosticHints message } @@ -480,7 +518,12 @@ (L (AsSrcSpan l@(RealSrcSpan spLoc _)) expr :: LHsExpr GhcPs) | spanIsRelevant l -> case expr of +#if MIN_VERSION_ghc(9,5,0) + HsTypedSplice{} -> Here (spLoc, Expr) + HsUntypedSplice{} -> Here (spLoc, Expr) +#else HsSpliceE {} -> Here (spLoc, Expr) +#endif _ -> Continue _ -> Stop ) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -57,8 +57,13 @@ , goldenTest "TQQTypeTypeError" Inplace 8 28 , goldenTest "TSimpleDecl" Inplace 8 1 , goldenTest "TQQDecl" Inplace 5 1 - , goldenTestWithEdit "TTypeKindError" Inplace 7 9 - , goldenTestWithEdit "TDeclKindError" Inplace 8 1 + , goldenTestWithEdit "TTypeKindError" ( + if ghcVersion >= GHC96 then + "96-expected" + else + "expected" + ) Inplace 7 9 + , goldenTestWithEdit "TDeclKindError" "expected" Inplace 8 1 ] goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree @@ -74,9 +79,9 @@ void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) _ -> liftIO $ assertFailure "No CodeAction detected" -goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree -goldenTestWithEdit fp tc line col = - goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do +goldenTestWithEdit :: FilePath -> FilePath -> ExpandStyle -> Int -> Int -> TestTree +goldenTestWithEdit fp expect tc line col = + goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp expect "hs" $ \doc -> do orig <- documentContents doc let lns = T.lines orig diff --git a/test/testdata/TTypeKindError.96-expected.hs b/test/testdata/TTypeKindError.96-expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TTypeKindError.96-expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TTypeKindError where +import Language.Haskell.TH ( numTyLit, litT ) +import Data.Proxy ( Proxy ) + +main :: 42 +main = return ()