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.0.4 +version: 1.0.0.5 synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes @@ -38,7 +38,7 @@ , foldl , ghc , ghc-exactprint - , ghcide >=1.2 && <1.5 + , ghcide >=1.2 && <1.6 , hls-plugin-api >=1.1 && <1.3 , lens , lsp 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 @@ -23,6 +23,7 @@ import Control.Applicative (Alternative ((<|>))) import Control.Arrow +import Control.Exception import qualified Control.Foldl as L import Control.Lens (Identity (..), ix, view, (%~), (<&>), (^.)) @@ -43,12 +44,10 @@ mapMaybe) import qualified Data.Text as T import Development.IDE -import Development.IDE.GHC.Compat hiding (getLoc) +import Development.IDE.GHC.Compat as Compat hiding (getLoc) +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint -import Exception import GHC.Exts -import GhcMonad -import GhcPlugins hiding (Var, getLoc, (<>)) import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (setPrecedingLines, @@ -57,8 +56,6 @@ import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as J -import RnSplice -import TcRnMonad descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -146,7 +143,7 @@ dflags clientCapabilities uri - (graft (RealSrcSpan spliceSpan) expanded) + (graft (RealSrcSpan spliceSpan Nothing) expanded) ps maybe (throwE "No splice information found") (either throwE pure) $ case spliceContext of @@ -162,7 +159,7 @@ dflags clientCapabilities uri - (graftDecls (RealSrcSpan spliceSpan) expanded) + (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) ps <&> -- FIXME: Why ghc-exactprint sweeps preceeding comments? @@ -195,7 +192,7 @@ where range = realSrcSpanToRange spliceSpan - srcSpan = RealSrcSpan spliceSpan + srcSpan = RealSrcSpan spliceSpan Nothing setupHscEnv @@ -211,33 +208,27 @@ let ps = annotateParsedSource pm hscEnv0 = hscEnvWithImportPaths hscEnvEq modSum = pm_mod_summary pm - df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum - let hscEnv = hscEnv0 { hsc_dflags = df' } - pure (ps, hscEnv, df') + hscEnv <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum + pure (ps, hscEnv, hsc_dflags hscEnv) -setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO HscEnv setupDynFlagsForGHCiLike env dflags = do - let dflags3 = - dflags - { hscTarget = HscInterpreted - , ghcMode = CompManager - , ghcLink = LinkInMemory - } + let dflags3 = setInterpreterLinkerOptions dflags platform = targetPlatform dflags3 - dflags3a = updateWays $ dflags3 {ways = interpWays} + dflags3a = setWays hostFullWays dflags3 dflags3b = foldl gopt_set dflags3a $ - concatMap (wayGeneralFlags platform) interpWays + concatMap (wayGeneralFlags platform) hostFullWays dflags3c = foldl gopt_unset dflags3b $ - concatMap (wayUnsetGeneralFlags platform) interpWays + concatMap (wayUnsetGeneralFlags platform) hostFullWays dflags4 = dflags3c `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges `gopt_unset` Opt_DiagnosticsShowCaret - initializePlugins env dflags4 + initializePlugins (hscSetFlags dflags4 env) adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit adjustToRange uri ran (WorkspaceEdit mhult mlt x) = @@ -335,26 +326,26 @@ case classifyAST spliceContext of IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ flip (transformM dflags clientCapabilities uri) ps $ - graftDeclsWithM (RealSrcSpan srcSpan) $ \case + graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- eitherM (fail . show) pure $ lift ( lift $ - gtry @_ @SomeException $ + Util.try @_ @SomeException $ (fst <$> rnTopSpliceDecls spl) ) pure $ Just eExpr _ -> pure Nothing OneToOneAST astP -> flip (transformM dflags clientCapabilities uri) ps $ - graftWithM (RealSrcSpan srcSpan) $ \case + graftWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- eitherM (fail . show) pure $ lift ( lift $ - gtry @_ @SomeException $ + Util.try @_ @SomeException $ (fst <$> expandSplice astP spl) ) Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr @@ -428,8 +419,8 @@ mkQ Continue ( \case - (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> + (L l@(RealSrcSpan spLoc _) expr :: LHsExpr GhcPs) + | RealSrcSpan spn Nothing `isSubspanOf` l -> case expr of HsSpliceE {} -> Here (spLoc, Expr) _ -> Continue @@ -437,25 +428,25 @@ ) `extQ` \case #if __GLASGOW_HASKELL__ == 808 - (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs)) + (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs)) #else - (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) + (L l@(RealSrcSpan spLoc _) pat :: LPat GhcPs) #endif - | RealSrcSpan spn `isSubspanOf` l -> + | RealSrcSpan spn Nothing `isSubspanOf` l -> case pat of SplicePat{} -> Here (spLoc, Pat) _ -> Continue _ -> Stop `extQ` \case - (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> + (L l@(RealSrcSpan spLoc _) ty :: LHsType GhcPs) + | RealSrcSpan spn Nothing `isSubspanOf` l -> case ty of HsSpliceTy {} -> Here (spLoc, HsType) _ -> Continue _ -> Stop `extQ` \case - (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> + (L l@(RealSrcSpan spLoc _) decl :: LHsDecl GhcPs) + | RealSrcSpan spn Nothing `isSubspanOf` l -> case decl of SpliceD {} -> Here (spLoc, HsDecl) _ -> Continue diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -64,7 +64,9 @@ goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree goldenTest fp tc line col = goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do - _ <- waitForDiagnostics + -- wait for the entire build to finish, so that code actions that + -- use stale data will get uptodate stuff + void waitForBuildQueue actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do @@ -83,12 +85,14 @@ { _start = Position 0 0 , _end = Position (length lns + 1) 1 } - waitForProgressDone -- cradle - waitForProgressDone + waitForAllProgressDone -- cradle + waitForAllProgressDone alt <- liftIO $ T.readFile (fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] void waitForDiagnostics + -- wait for the entire build to finish + void waitForBuildQueue actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do