Skip to content

Commit 9a76346

Browse files
eddiejessupeddiejessup
committed
Doit
1 parent a913f47 commit 9a76346

File tree

3 files changed

+56
-47
lines changed

3 files changed

+56
-47
lines changed

‎.github/workflows/test.yml‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,7 @@ jobs:
106106
os: ${{ runner.os }}
107107

108108
- name: Build
109-
run: cabal build
109+
run: cabal build
110110

111111
- name: Set test options
112112
# run the tests without parallelism, otherwise tasty will attempt to run
@@ -148,7 +148,7 @@ jobs:
148148
env:
149149
HLS_TEST_EXE: hls
150150
HLS_WRAPPER_TEST_EXE: hls-wrapper
151-
run: cabal test wrapper-test --test-options="$TEST_OPTS --rerun-log-file .tasty-rerun-log-wrapper"
151+
run: cabal test wrapper-test --test-options="$TEST_OPTS --rerun-log-file .tasty-rerun-log-wrapper"
152152

153153
- if: matrix.test && matrix.ghc != '9.2.4' && matrix.ghc != '9.4.2'
154154
name: Test hls-brittany-plugin
@@ -178,7 +178,7 @@ jobs:
178178
name: Test hls-haddock-comments-plugin
179179
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"
180180

181-
- if: matrix.test && matrix.ghc != '9.2.4' && matrix.ghc != '9.4.2'
181+
- if: matrix.test && matrix.ghc != '9.4.2'
182182
name: Test hls-splice-plugin
183183
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"
184184

‎plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs‎

Lines changed: 18 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ module Development.IDE.GHC.ExactPrint
2525
Annotate,
2626
setPrecedingLinesT,
2727
#else
28+
setPrecedingLines,
2829
addParens,
2930
addParensToCtxt,
3031
modifyAnns,
@@ -56,6 +57,7 @@ import Control.Monad.Trans.Except
5657
import Control.Monad.Zip
5758
import Data.Bifunctor
5859
import Data.Bool (bool)
60+
import Data.Default (Default)
5961
import qualified Data.DList as DL
6062
import Data.Either.Extra (mapLeft)
6163
import Data.Foldable (Foldable (fold))
@@ -101,7 +103,13 @@ import GHC (EpAnn (..),
101103
spanAsAnchor)
102104
import GHC.Parser.Annotation (AnnContext (..),
103105
DeltaPos (SameLine),
104-
EpaLocation (EpaDelta))
106+
EpaLocation (EpaDelta),
107+
deltaPos)
108+
#endif
109+
110+
#if MIN_VERSION_ghc(9,2,0)
111+
setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a
112+
setPrecedingLines ast n c = setEntryDP ast (deltaPos n c)
105113
#endif
106114

107115
------------------------------------------------------------------------------
@@ -114,10 +122,10 @@ instance Pretty Log where
114122

115123
instance Show (Annotated ParsedSource) where
116124
show _ = "<Annotated ParsedSource>"
117-
125+
118126
instance NFData (Annotated ParsedSource) where
119127
rnf = rwhnf
120-
128+
121129
data GetAnnotatedParsedSource = GetAnnotatedParsedSource
122130
deriving (Eq, Show, Typeable, GHC.Generic)
123131

@@ -374,7 +382,7 @@ graftWithM dst trans = Graft $ \dflags a -> do
374382
#if MIN_VERSION_ghc(9,2,0)
375383
val'' <-
376384
hoistTransform (either Fail.fail pure) $
377-
annotate dflags True $ maybeParensAST val'
385+
annotate dflags False $ maybeParensAST val'
378386
pure val''
379387
#else
380388
(anns, val'') <-
@@ -468,7 +476,7 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do
468476
modifyDeclsT (fmap DL.toList . go) a
469477

470478

471-
class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where
479+
class (Data ast, Default l, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where
472480
parseAST :: Parser (LocatedAn l ast)
473481
maybeParensAST :: LocatedAn l ast -> LocatedAn l ast
474482
{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with
@@ -520,6 +528,7 @@ fixAnns ParsedModule {..} =
520528

521529
------------------------------------------------------------------------------
522530

531+
523532
-- | Given an 'LHSExpr', compute its exactprint annotations.
524533
-- Note that this function will throw away any existing annotations (and format)
525534
annotate :: (ASTElement l ast, Outputable l)
@@ -533,7 +542,7 @@ annotate dflags needs_space ast = do
533542
let rendered = render dflags ast
534543
#if MIN_VERSION_ghc(9,2,0)
535544
expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered
536-
pure expr'
545+
pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space)
537546
#else
538547
(anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered
539548
let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns
@@ -542,6 +551,7 @@ annotate dflags needs_space ast = do
542551

543552
-- | Given an 'LHsDecl', compute its exactprint annotations.
544553
annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)
554+
#if !MIN_VERSION_ghc(9,2,0)
545555
-- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain
546556
-- multiple matches. To work around this, we split the single
547557
-- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match',
@@ -554,17 +564,6 @@ annotateDecl dflags
554564
let set_matches matches =
555565
ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }}
556566

557-
#if MIN_VERSION_ghc(9,2,0)
558-
alts' <- for alts $ \alt -> do
559-
uniq <- show <$> uniqueSrcSpanT
560-
let rendered = render dflags $ set_matches [alt]
561-
lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case
562-
(L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))
563-
-> pure alt'
564-
_ -> lift $ Left "annotateDecl: didn't parse a single FunBind match"
565-
566-
pure $ L src $ set_matches alts'
567-
#else
568567
(anns', alts') <- fmap unzip $ for alts $ \alt -> do
569568
uniq <- show <$> uniqueSrcSpanT
570569
let rendered = render dflags $ set_matches [alt]
@@ -580,7 +579,8 @@ annotateDecl dflags ast = do
580579
uniq <- show <$> uniqueSrcSpanT
581580
let rendered = render dflags ast
582581
#if MIN_VERSION_ghc(9,2,0)
583-
lift $ mapLeft show $ parseDecl dflags uniq rendered
582+
expr' <- lift $ mapLeft show $ parseDecl dflags uniq rendered
583+
pure $ setPrecedingLines expr' 1 0
584584
#else
585585
(anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered
586586
let anns' = setPrecedingLines expr' 1 0 anns

‎plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs‎

Lines changed: 35 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -53,12 +53,13 @@ import Development.IDE.GHC.ExactPrint
5353
import GHC.Exts
5454
import Ide.Plugin.Splice.Types
5555
import Ide.Types
56-
import Language.Haskell.GHC.ExactPrint (setPrecedingLines,
57-
uniqueSrcSpanT)
56+
import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT)
5857
import Language.LSP.Server
5958
import Language.LSP.Types
6059
import Language.LSP.Types.Capabilities
6160
import qualified Language.LSP.Types.Lens as J
61+
import GHC.Hs (SrcSpanAnn'(..))
62+
import qualified GHC.Types.Error as Error
6263

6364
descriptor :: PluginId -> PluginDescriptor IdeState
6465
descriptor plId =
@@ -135,7 +136,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do
135136
graftSpliceWith ::
136137
forall ast.
137138
HasSplice AnnListItem ast =>
138-
Maybe (SrcSpan, Located (ast GhcPs)) ->
139+
Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs)) ->
139140
Maybe (Either String WorkspaceEdit)
140141
graftSpliceWith expandeds =
141142
expandeds <&> \(_, expanded) ->
@@ -236,11 +237,11 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) =
236237
where
237238
adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit
238239
adjustTextEdits eds =
239-
let Just minStart =
240-
L.fold
241-
(L.premap (view J.range) L.minimum)
242-
eds
243-
in adjustLine minStart <$> eds
240+
let minStart =
241+
case L.fold (L.premap (view J.range) L.minimum) eds of
242+
Nothing -> error "impossible"
243+
Just v -> v
244+
in adjustLine minStart <$> eds
244245

245246
adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit)
246247
adjustATextEdits = fmap $ \case
@@ -267,7 +268,7 @@ findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
267268
findSubSpansDesc srcSpan =
268269
sortOn (Down . SubSpan . fst)
269270
. mapMaybe
270-
( \(L spn _, e) -> do
271+
( \(L (SrcSpanAnn {locA = spn}) _, e) -> do
271272
guard (spn `isSubspanOf` srcSpan)
272273
pure (spn, e)
273274
)
@@ -321,7 +322,7 @@ manualCalcEdit ::
321322
manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do
322323
(warns, resl) <-
323324
ExceptT $ do
324-
((warns, errs), eresl) <-
325+
(msgs, eresl) <-
325326
initTcWithGbl hscEnv typechkd srcSpan $
326327
case classifyAST spliceContext of
327328
IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $
@@ -348,8 +349,16 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e
348349
Util.try @_ @SomeException $
349350
(fst <$> expandSplice astP spl)
350351
)
351-
Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr
352+
Just <$> case eExpr of
353+
Left x -> pure $ L _spn x
354+
Right y -> unRenamedE dflags y
352355
_ -> pure Nothing
356+
let (warns, errs) =
357+
#if __GLASGOW_HASKELL__ >= 902
358+
(Error.getWarningMessages msgs, Error.getErrorMessages msgs)
359+
#else
360+
msgs
361+
#endif
353362
pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl
354363

355364
unless
@@ -370,15 +379,12 @@ unRenamedE ::
370379
(Fail.MonadFail m, HasSplice l ast) =>
371380
DynFlags ->
372381
ast GhcRn ->
373-
TransformT m (Located (ast GhcPs))
382+
TransformT m (LocatedAn l (ast GhcPs))
374383
unRenamedE dflags expr = do
375384
uniq <- show <$> uniqueSrcSpanT
376-
(anns, expr') <-
377-
either (fail . show) pure $
378-
parseAST @_ @(ast GhcPs) dflags uniq $
379-
showSDoc dflags $ ppr expr
380-
let _anns' = setPrecedingLines expr' 0 1 anns
381-
pure expr'
385+
either (fail . show) pure $
386+
parseAST @_ @(ast GhcPs) dflags uniq $
387+
showSDoc dflags $ ppr expr
382388

383389
data SearchResult r =
384390
Continue | Stop | Here r
@@ -416,11 +422,14 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $
416422
RealSrcSpan ->
417423
GenericQ (SearchResult (RealSrcSpan, SpliceContext))
418424
detectSplice spn =
425+
let
426+
spanIsRelevant x = RealSrcSpan spn Nothing `isSubspanOf` x
427+
in
419428
mkQ
420429
Continue
421430
( \case
422-
(L l@(RealSrcSpan spLoc _) expr :: LHsExpr GhcPs)
423-
| RealSrcSpan spn Nothing `isSubspanOf` l ->
431+
(L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) expr :: LHsExpr GhcPs)
432+
| spanIsRelevant l ->
424433
case expr of
425434
HsSpliceE {} -> Here (spLoc, Expr)
426435
_ -> Continue
@@ -430,23 +439,23 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $
430439
#if __GLASGOW_HASKELL__ == 808
431440
(dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs))
432441
#else
433-
(L l@(RealSrcSpan spLoc _) pat :: LPat GhcPs)
442+
(L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) pat :: LPat GhcPs)
434443
#endif
435-
| RealSrcSpan spn Nothing `isSubspanOf` l ->
444+
| spanIsRelevant l ->
436445
case pat of
437446
SplicePat{} -> Here (spLoc, Pat)
438447
_ -> Continue
439448
_ -> Stop
440449
`extQ` \case
441-
(L l@(RealSrcSpan spLoc _) ty :: LHsType GhcPs)
442-
| RealSrcSpan spn Nothing `isSubspanOf` l ->
450+
(L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) ty :: LHsType GhcPs)
451+
| spanIsRelevant l ->
443452
case ty of
444453
HsSpliceTy {} -> Here (spLoc, HsType)
445454
_ -> Continue
446455
_ -> Stop
447456
`extQ` \case
448-
(L l@(RealSrcSpan spLoc _) decl :: LHsDecl GhcPs)
449-
| RealSrcSpan spn Nothing `isSubspanOf` l ->
457+
(L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) decl :: LHsDecl GhcPs)
458+
| spanIsRelevant l ->
450459
case decl of
451460
SpliceD {} -> Here (spLoc, HsDecl)
452461
_ -> Continue

0 commit comments

Comments
 (0)