Skip to content

Commit 056f769

Browse files
konnkonn
committed
Workaround for GHC 8.8
1 parent 45a1388 commit 056f769

File tree

2 files changed

+85
-34
lines changed

2 files changed

+85
-34
lines changed

‎hls-exactprint-utils/src/Ide/TreeTransform.hs

Lines changed: 72 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,16 @@
1+
{-# LANGUAGE DefaultSignatures #-}
2+
{-# LANGUAGE CPP #-}
13
{-# LANGUAGE DerivingStrategies #-}
4+
{-# LANGUAGE FlexibleContexts #-}
25
{-# LANGUAGE GADTs #-}
36
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
47
{-# LANGUAGE LambdaCase #-}
58
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE PackageImports #-}
610
{-# LANGUAGE RankNTypes #-}
711
{-# LANGUAGE RecordWildCards #-}
812
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TypeFamilyDependencies #-}
914

1015
module Ide.TreeTransform
1116
( Graft(..),
@@ -47,9 +52,10 @@ import Language.Haskell.GHC.ExactPrint
4752
import Language.Haskell.GHC.ExactPrint.Parsers
4853
import Language.Haskell.LSP.Types
4954
import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities)
50-
import Outputable (Outputable, ppr, showSDoc, trace)
55+
import Outputable (Outputable, ppr, showSDoc)
5156
import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType)
52-
import Control.Arrow (Arrow(second))
57+
import qualified "ghc" SrcLoc
58+
5359
------------------------------------------------------------------------------
5460

5561
-- | Get the latest version of the annotated parse source.
@@ -152,7 +158,7 @@ graft ::
152158
forall ast a.
153159
(Data a, ASTElement ast) =>
154160
SrcSpan ->
155-
Located ast ->
161+
ToL ast GhcPs ->
156162
Graft (Either String) a
157163
graft dst val = Graft $ \dflags a -> do
158164
(anns, val') <- annotate dflags $ maybeParensAST val
@@ -161,7 +167,7 @@ graft dst val = Graft $ \dflags a -> do
161167
everywhere'
162168
( mkT $
163169
\case
164-
(L src _ :: Located ast) | src == dst -> val'
170+
(src :: ToL ast GhcPs) | location src == dst -> val'
165171
l -> l
166172
)
167173
a
@@ -172,14 +178,14 @@ graftWithM ::
172178
forall ast m a.
173179
(Fail.MonadFail m, Data a, ASTElement ast) =>
174180
SrcSpan ->
175-
(Located ast -> TransformT m (Maybe (Located ast))) ->
181+
(ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) ->
176182
Graft m a
177183
graftWithM dst trans = Graft $ \dflags a -> do
178184
everywhereM'
179185
( mkM $
180186
\case
181-
val@(L src _ :: Located ast)
182-
| src == dst -> do
187+
(val :: ToL ast GhcPs)
188+
| getLoc val == dst -> do
183189
mval <- trans val
184190
case mval of
185191
Just val' -> do
@@ -197,14 +203,14 @@ graftWithSmallestM ::
197203
forall ast m a.
198204
(Fail.MonadFail m, Data a, ASTElement ast) =>
199205
SrcSpan ->
200-
(Located ast -> TransformT m (Maybe (Located ast))) ->
206+
(ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) ->
201207
Graft m a
202208
graftWithSmallestM dst trans = Graft $ \dflags a -> do
203209
everywhereM'
204210
( mkM $
205211
\case
206-
val@(L src _ :: Located ast)
207-
| dst `isSubspanOf` src -> do
212+
(val :: ToL ast GhcPs)
213+
| dst `isSubspanOf` getLoc val -> do
208214
mval <- trans val
209215
case mval of
210216
Just val' -> do
@@ -264,23 +270,64 @@ everywhereM' f = go
264270
go :: GenericM m
265271
go = gmapM go <=< f
266272

267-
class (Data ast, Outputable ast) => ASTElement ast where
268-
parseAST :: Parser (Located ast)
269-
maybeParensAST :: Located ast -> Located ast
270-
271-
instance p ~ GhcPs => ASTElement (HsExpr p) where
273+
class
274+
( Data (ast GhcPs), Outputable (ast GhcPs),
275+
HasSrcSpan (ToL ast GhcPs), Data (ToL ast GhcPs),
276+
Outputable (ToL ast GhcPs)
277+
)
278+
=> ASTElement ast where
279+
-- | This is to absorb the implementation difference of 'LPat',
280+
-- which is equal to Located Pat in 8.6 and 8.10, but
281+
-- is isomorphic to Pat in 8.8.
282+
type ToL ast p = (r :: *) | r -> ast
283+
type ToL ast p = Located (ast p)
284+
withL :: SrcSpan -> ast GhcPs -> ToL ast GhcPs
285+
default withL
286+
:: ToL ast GhcPs ~ Located (ast GhcPs)
287+
=> SrcSpan -> ast GhcPs -> ToL ast GhcPs
288+
withL = L
289+
toLocated :: ToL ast GhcPs -> Located (ast GhcPs)
290+
default toLocated
291+
:: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> Located (ast GhcPs)
292+
toLocated = id
293+
unLocated :: ToL ast GhcPs -> ast GhcPs
294+
default unLocated
295+
:: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> ast GhcPs
296+
unLocated = unLoc
297+
location :: ToL ast GhcPs -> SrcSpan
298+
location = SrcLoc.getLoc . toLocated
299+
300+
parseAST :: Parser (ToL ast GhcPs)
301+
maybeParensAST :: ToL ast GhcPs -> ToL ast GhcPs
302+
303+
instance ASTElement HsExpr where
304+
type ToL HsExpr p = LHsExpr p
272305
parseAST = parseExpr
273306
maybeParensAST = parenthesize
274307

275-
instance p ~ GhcPs => ASTElement (Pat p) where
308+
instance ASTElement Pat where
309+
type ToL Pat p = LPat p
310+
#if __GLASGOW_HASKELL__ == 808
311+
toLocated p@(XPat (L loc _))= L loc p
312+
toLocated p = L noSrcSpan p
313+
unLocated = id
314+
withL = flip const
315+
#else
316+
toLocated = id
317+
unLocated = unLoc
318+
#endif
319+
276320
parseAST = parsePattern
277321
maybeParensAST = parenthesizePat appPrec
278322

279-
instance p ~ GhcPs => ASTElement (HsType p) where
323+
324+
instance ASTElement HsType where
325+
type ToL HsType p = LHsType p
280326
parseAST = parseType
281327
maybeParensAST = parenthesizeHsType appPrec
282328

283-
instance p ~ GhcPs => ASTElement (HsDecl p) where
329+
instance ASTElement HsDecl where
330+
type ToL HsDecl p = LHsDecl p
284331
parseAST = parseDecl
285332
maybeParensAST = id
286333

@@ -295,12 +342,17 @@ fixAnns ParsedModule {..} =
295342
------------------------------------------------------------------------------
296343

297344
-- | Given an 'LHSExpr', compute its exactprint annotations.
298-
annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast)
345+
annotate
346+
:: forall ast. ASTElement ast
347+
=> DynFlags -> ToL ast GhcPs
348+
-> TransformT (Either String) (Anns, ToL ast GhcPs)
299349
annotate dflags ast = do
300350
uniq <- show <$> uniqueSrcSpanT
301351
let rendered = render dflags ast
302352
(anns, expr') <- lift $ either (Left . show) Right $ parseAST dflags uniq rendered
303-
let anns' = setPrecedingLines expr' 0 1 anns
353+
let anns' = setPrecedingLines
354+
(toLocated expr' :: Located (ast GhcPs))
355+
0 1 anns
304356
pure (anns', expr')
305357

306358
-- | Given an 'LHsDecl', compute its exactprint annotations.

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

Lines changed: 13 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ where
2121

2222
import Control.Applicative (Alternative ((<|>)))
2323
import Control.Arrow (Arrow (first))
24-
import Control.Exception (SomeException)
2524
import qualified Control.Foldl as L
2625
import Control.Lens (ix, view, (%~), (<&>), (^.))
2726
import Control.Monad
@@ -167,7 +166,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} =
167166
graftSpliceWith ::
168167
forall ast.
169168
HasSplice ast =>
170-
Maybe (SrcSpan, Located (ast GhcPs)) ->
169+
Maybe (SrcSpan, ToL ast GhcPs) ->
171170
Maybe (Either String WorkspaceEdit)
172171
graftSpliceWith expandeds =
173172
expandeds <&> \(_, expanded) ->
@@ -180,7 +179,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} =
180179
maybe (throwE "No splcie information found") (either throwE pure) $
181180
case spliceContext of
182181
Expr -> graftSpliceWith exprSuperSpans
183-
Pat -> graftSpliceWith patSuperSpans
182+
Pat -> graftSpliceWith @Pat patSuperSpans
184183
HsType -> graftSpliceWith typeSuperSpans
185184
HsDecl ->
186185
declSuperSpans <&> \(_, expanded) ->
@@ -253,7 +252,7 @@ data SpliceClass where
253252
OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass
254253
IsHsDecl :: SpliceClass
255254

256-
class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where
255+
class (Outputable (ast GhcRn), ASTElement ast) => HasSplice ast where
257256
type SpliceOf ast :: Kinds.Type -> Kinds.Type
258257
type SpliceOf ast = HsSplice
259258
matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs)
@@ -322,15 +321,15 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..
322321
OneToOneAST astP ->
323322
flip (transformM dflags (clientCapabilities lsp) uri) ps $
324323
graftWithM (RealSrcSpan srcSpan) $ \case
325-
(L _spn (matchSplice astP -> Just spl)) -> do
324+
(toLocated -> L _spn (matchSplice astP -> Just spl)) -> do
326325
eExpr <-
327326
either (fail . show) pure
328327
=<< lift
329328
( lift $
330329
gtry @_ @SomeException $
331330
(fst <$> expandSplice astP spl)
332331
)
333-
Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr
332+
Just <$> either (pure . withL _spn) (unRenamedE dflags) eExpr
334333
_ -> pure Nothing
335334
pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl
336335

@@ -353,14 +352,14 @@ unRenamedE ::
353352
(Fail.MonadFail m, HasSplice ast) =>
354353
DynFlags ->
355354
ast GhcRn ->
356-
TransformT m (Located (ast GhcPs))
355+
TransformT m (ToL ast GhcPs)
357356
unRenamedE dflags expr = do
358357
uniq <- show <$> uniqueSrcSpanT
359-
(anns, expr') <-
358+
(anns, expr' :: ToL ast GhcPs) <-
360359
either (fail . show) pure $
361-
parseAST @(ast GhcPs) dflags uniq $
360+
parseAST @ast dflags uniq $
362361
showSDoc dflags $ ppr expr
363-
let _anns' = setPrecedingLines expr' 0 1 anns
362+
let _anns' = setPrecedingLines (toLocated expr') 0 1 anns
364363
pure expr'
365364

366365
-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)
@@ -397,20 +396,20 @@ codeAction _ state plId docId ran _ =
397396
mkQ
398397
Nothing
399398
( \case
400-
(L l@(RealSrcSpan spLoc) HsSpliceE {} :: LHsExpr GhcPs)
399+
((toLocated @HsExpr -> L l@(RealSrcSpan spLoc) HsSpliceE {}) :: LHsExpr GhcPs)
401400
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr)
402401
_ -> Nothing
403402
)
404403
`extQ` \case
405-
(L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs)
404+
((toLocated @Pat -> L l@(RealSrcSpan spLoc) SplicePat {}) :: LPat GhcPs)
406405
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat)
407406
_ -> Nothing
408407
`extQ` \case
409-
(L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs)
408+
((toLocated @HsType -> L l@(RealSrcSpan spLoc) HsSpliceTy {}) :: LHsType GhcPs)
410409
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType)
411410
_ -> Nothing
412411
`extQ` \case
413-
(L l@(RealSrcSpan spLoc) SpliceD {} :: LHsDecl GhcPs)
412+
((toLocated @HsDecl -> L l@(RealSrcSpan spLoc) SpliceD {}) :: LHsDecl GhcPs)
414413
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsDecl)
415414
_ -> Nothing
416415

0 commit comments

Comments
 (0)