hls-splice-plugin 1.0.2.0 → 1.0.3.0
raw patch · 4 files changed
+99/−48 lines, 4 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utils
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
Files
- hls-splice-plugin.cabal +8/−12
- src/Ide/Plugin/Splice.hs +88/−33
- src/Ide/Plugin/Splice/Types.hs +1/−1
- test/Main.hs +2/−2
hls-splice-plugin.cabal view
@@ -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
src/Ide/Plugin/Splice.hs view
@@ -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
src/Ide/Plugin/Splice/Types.hs view
@@ -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)"
test/Main.hs view
@@ -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"