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.2.0 +version: 1.0.3.0 synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes @@ -22,11 +22,11 @@ test/testdata/*.hs test/testdata/*.yaml +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + library - if impl(ghc >= 9.3) - buildable: False - else - buildable: True exposed-modules: Ide.Plugin.Splice Ide.Plugin.Splice.Types @@ -42,8 +42,8 @@ , foldl , ghc , ghc-exactprint - , ghcide ^>=1.8 - , hls-plugin-api ^>= 1.5 + , ghcide ^>=1.9 + , hls-plugin-api ^>= 1.6 , hls-refactor-plugin , lens , lsp @@ -60,10 +60,6 @@ TypeOperators test-suite tests - if impl(ghc >= 9.3) - buildable: False - else - buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -73,5 +69,5 @@ , base , filepath , hls-splice-plugin - , hls-test-utils ^>= 1.4 + , hls-test-utils ^>= 1.5 , text 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 @@ -15,6 +15,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -50,11 +51,17 @@ import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint +#if MIN_VERSION_ghc(9,4,1) +import GHC.Data.Bag (Bag) +#endif import GHC.Exts +#if MIN_VERSION_ghc(9,2,0) +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 @@ -95,7 +102,7 @@ liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp (TcModuleResult {..}, _) <- maybe - (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (errornous) macro and expand splice again." + (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." ) pure mresl reportEditor @@ -126,9 +133,6 @@ let exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices _patSuperSpans = -#if __GLASGOW_HASKELL__ == 808 - fmap (second dL) $ -#endif listToMaybe $ findSubSpansDesc srcSpan patSplices typeSuperSpans = listToMaybe $ findSubSpansDesc srcSpan typeSplices @@ -138,7 +142,7 @@ 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) -> @@ -165,7 +169,7 @@ (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) ps <&> - -- FIXME: Why ghc-exactprint sweeps preceeding comments? + -- FIXME: Why ghc-exactprint sweeps preceding comments? adjustToRange uri range res <- liftIO $ runMaybeT $ do @@ -239,11 +243,11 @@ 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 @@ -266,11 +270,23 @@ 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 MIN_VERSION_ghc(9,2,0) +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) ) @@ -324,7 +340,7 @@ 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) $ @@ -351,9 +367,17 @@ 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 - pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl + let (warns, errs) = +#if MIN_VERSION_ghc(9,2,0) + (Error.getWarningMessages msgs, Error.getErrorMessages msgs) +#else + msgs +#endif + pure $ (warns,) <$> fromMaybe (Left $ showErrors errs) eresl unless (null warns) @@ -361,27 +385,55 @@ MtWarning [ "Warning during expanding: " , "" - , T.pack (show warns) + , T.pack (showErrors warns) ] pure resl where dflags = hsc_dflags hscEnv +#if MIN_VERSION_ghc(9,4,1) + showErrors = showBag +#else + showErrors = show +#endif + +#if MIN_VERSION_ghc(9,4,1) +showBag :: Error.Diagnostic a => Bag (Error.MsgEnvelope a) -> String +showBag = show . fmap (fmap toDiagnosticMessage) + +toDiagnosticMessage :: Error.Diagnostic a => a -> Error.DiagnosticMessage +toDiagnosticMessage message = + Error.DiagnosticMessage + { diagMessage = Error.diagnosticMessage message + , diagReason = Error.diagnosticReason message + , diagHints = Error.diagnosticHints message + } +#endif + -- | FIXME: Is thereAny "clever" way to do this exploiting TTG? unRenamedE :: forall ast m l. (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 +#if MIN_VERSION_ghc(9,2,0) + expr' <- +#else + (_anns, expr') <- +#endif + either (fail . showErrors) pure $ + parseAST @_ @(ast GhcPs) dflags uniq $ + showSDoc dflags $ ppr expr pure expr' + where +#if MIN_VERSION_ghc(9,4,1) + showErrors = showBag . Error.getMessages +#else + showErrors = show +#endif data SearchResult r = Continue | Stop | Here r @@ -419,11 +471,14 @@ 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 @@ -433,30 +488,30 @@ #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 _ -> Stop -- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received, --- and picks inenrmost result. +-- and picks innermost result. something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a) something' f = go where diff --git a/src/Ide/Plugin/Splice/Types.hs b/src/Ide/Plugin/Splice/Types.hs --- a/src/Ide/Plugin/Splice/Types.hs +++ b/src/Ide/Plugin/Splice/Types.hs @@ -51,4 +51,4 @@ inplaceCmdName = "expand TemplateHaskell Splice (in-place)" commentedCmdName :: T.Text -commentedCmdName = "expand TemplateHaskell Splice (comented-out)" +commentedCmdName = "expand TemplateHaskell Splice (commented-out)" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -21,8 +21,8 @@ main :: IO () main = defaultTestRunner tests -splicePlugin :: PluginDescriptor IdeState -splicePlugin = Splice.descriptor "splice" +splicePlugin :: PluginTestDescriptor () +splicePlugin = mkPluginTestDescriptor' Splice.descriptor "splice" tests :: TestTree tests = testGroup "splice"