Skip to content

Commit

Permalink
Workaround for GHC 8.8
Browse files Browse the repository at this point in the history
  • Loading branch information
@konn
konn committed Jan 1, 2021
1 parent 45a1388 commit 056f769
Show file tree
Hide file tree
Showing 2 changed files with 85 additions and 34 deletions.
92 changes: 72 additions & 20 deletions hls-exactprint-utils/src/Ide/TreeTransform.hs
View file
Original file line number Diff line number Diff line change
@@ -1,11 +1,16 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Ide.TreeTransform
( Graft(..),
Expand Down Expand Up @@ -47,9 +52,10 @@ import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities)
import Outputable (Outputable, ppr, showSDoc, trace)
import Outputable (Outputable, ppr, showSDoc)
import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType)
import Control.Arrow (Arrow(second))
import qualified "ghc" SrcLoc

------------------------------------------------------------------------------

-- | Get the latest version of the annotated parse source.
Expand Down Expand Up @@ -152,7 +158,7 @@ graft ::
forall ast a.
(Data a, ASTElement ast) =>
SrcSpan ->
Located ast ->
ToL ast GhcPs ->
Graft (Either String) a
graft dst val = Graft $ \dflags a -> do
(anns, val') <- annotate dflags $ maybeParensAST val
Expand All @@ -161,7 +167,7 @@ graft dst val = Graft $ \dflags a -> do
everywhere'
( mkT $
\case
(L src _ :: Located ast) | src == dst -> val'
(src :: ToL ast GhcPs) | location src == dst -> val'
l -> l
)
a
Expand All @@ -172,14 +178,14 @@ graftWithM ::
forall ast m a.
(Fail.MonadFail m, Data a, ASTElement ast) =>
SrcSpan ->
(Located ast -> TransformT m (Maybe (Located ast))) ->
(ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) ->
Graft m a
graftWithM dst trans = Graft $ \dflags a -> do
everywhereM'
( mkM $
\case
val@(L src _ :: Located ast)
| src == dst -> do
(val :: ToL ast GhcPs)
| getLoc val == dst -> do
mval <- trans val
case mval of
Just val' -> do
Expand All @@ -197,14 +203,14 @@ graftWithSmallestM ::
forall ast m a.
(Fail.MonadFail m, Data a, ASTElement ast) =>
SrcSpan ->
(Located ast -> TransformT m (Maybe (Located ast))) ->
(ToL ast GhcPs -> TransformT m (Maybe (ToL ast GhcPs))) ->
Graft m a
graftWithSmallestM dst trans = Graft $ \dflags a -> do
everywhereM'
( mkM $
\case
val@(L src _ :: Located ast)
| dst `isSubspanOf` src -> do
(val :: ToL ast GhcPs)
| dst `isSubspanOf` getLoc val -> do
mval <- trans val
case mval of
Just val' -> do
Expand Down Expand Up @@ -264,23 +270,64 @@ everywhereM' f = go
go :: GenericM m
go = gmapM go <=< f

class (Data ast, Outputable ast) => ASTElement ast where
parseAST :: Parser (Located ast)
maybeParensAST :: Located ast -> Located ast

instance p ~ GhcPs => ASTElement (HsExpr p) where
class
( Data (ast GhcPs), Outputable (ast GhcPs),
HasSrcSpan (ToL ast GhcPs), Data (ToL ast GhcPs),
Outputable (ToL ast GhcPs)
)
=> ASTElement ast where
-- | This is to absorb the implementation difference of 'LPat',
-- which is equal to Located Pat in 8.6 and 8.10, but
-- is isomorphic to Pat in 8.8.
type ToL ast p = (r :: *) | r -> ast
type ToL ast p = Located (ast p)
withL :: SrcSpan -> ast GhcPs -> ToL ast GhcPs
default withL
:: ToL ast GhcPs ~ Located (ast GhcPs)
=> SrcSpan -> ast GhcPs -> ToL ast GhcPs
withL = L
toLocated :: ToL ast GhcPs -> Located (ast GhcPs)
default toLocated
:: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> Located (ast GhcPs)
toLocated = id
unLocated :: ToL ast GhcPs -> ast GhcPs
default unLocated
:: ToL ast GhcPs ~ Located (ast GhcPs) => ToL ast GhcPs -> ast GhcPs
unLocated = unLoc
location :: ToL ast GhcPs -> SrcSpan
location = SrcLoc.getLoc . toLocated

parseAST :: Parser (ToL ast GhcPs)
maybeParensAST :: ToL ast GhcPs -> ToL ast GhcPs

instance ASTElement HsExpr where
type ToL HsExpr p = LHsExpr p
parseAST = parseExpr
maybeParensAST = parenthesize

instance p ~ GhcPs => ASTElement (Pat p) where
instance ASTElement Pat where
type ToL Pat p = LPat p
#if __GLASGOW_HASKELL__ == 808
toLocated p@(XPat (L loc _))= L loc p
toLocated p = L noSrcSpan p
unLocated = id
withL = flip const
#else
toLocated = id
unLocated = unLoc
#endif

parseAST = parsePattern
maybeParensAST = parenthesizePat appPrec

instance p ~ GhcPs => ASTElement (HsType p) where

instance ASTElement HsType where
type ToL HsType p = LHsType p
parseAST = parseType
maybeParensAST = parenthesizeHsType appPrec

instance p ~ GhcPs => ASTElement (HsDecl p) where
instance ASTElement HsDecl where
type ToL HsDecl p = LHsDecl p
parseAST = parseDecl
maybeParensAST = id

Expand All @@ -295,12 +342,17 @@ fixAnns ParsedModule {..} =
------------------------------------------------------------------------------

-- | Given an 'LHSExpr', compute its exactprint annotations.
annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast)
annotate
:: forall ast. ASTElement ast
=> DynFlags -> ToL ast GhcPs
-> TransformT (Either String) (Anns, ToL ast GhcPs)
annotate dflags ast = do
uniq <- show <$> uniqueSrcSpanT
let rendered = render dflags ast
(anns, expr') <- lift $ either (Left . show) Right $ parseAST dflags uniq rendered
let anns' = setPrecedingLines expr' 0 1 anns
let anns' = setPrecedingLines
(toLocated expr' :: Located (ast GhcPs))
0 1 anns
pure (anns', expr')

-- | Given an 'LHsDecl', compute its exactprint annotations.
Expand Down
27 changes: 13 additions & 14 deletions plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,6 @@ where

import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (Arrow (first))
import Control.Exception (SomeException)
import qualified Control.Foldl as L
import Control.Lens (ix, view, (%~), (<&>), (^.))
import Control.Monad
Expand Down Expand Up @@ -167,7 +166,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} =
graftSpliceWith ::
forall ast.
HasSplice ast =>
Maybe (SrcSpan, Located (ast GhcPs)) ->
Maybe (SrcSpan, ToL ast GhcPs) ->
Maybe (Either String WorkspaceEdit)
graftSpliceWith expandeds =
expandeds <&> \(_, expanded) ->
Expand All @@ -180,7 +179,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} =
maybe (throwE "No splcie information found") (either throwE pure) $
case spliceContext of
Expr -> graftSpliceWith exprSuperSpans
Pat -> graftSpliceWith patSuperSpans
Pat -> graftSpliceWith @Pat patSuperSpans
HsType -> graftSpliceWith typeSuperSpans
HsDecl ->
declSuperSpans <&> \(_, expanded) ->
Expand Down Expand Up @@ -253,7 +252,7 @@ data SpliceClass where
OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass
IsHsDecl :: SpliceClass

class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where
class (Outputable (ast GhcRn), ASTElement ast) => HasSplice ast where
type SpliceOf ast :: Kinds.Type -> Kinds.Type
type SpliceOf ast = HsSplice
matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs)
Expand Down Expand Up @@ -322,15 +321,15 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..
OneToOneAST astP ->
flip (transformM dflags (clientCapabilities lsp) uri) ps $
graftWithM (RealSrcSpan srcSpan) $ \case
(L _spn (matchSplice astP -> Just spl)) -> do
(toLocated -> L _spn (matchSplice astP -> Just spl)) -> do
eExpr <-
either (fail . show) pure
=<< lift
( lift $
gtry @_ @SomeException $
(fst <$> expandSplice astP spl)
)
Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr
Just <$> either (pure . withL _spn) (unRenamedE dflags) eExpr
_ -> pure Nothing
pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl

Expand All @@ -353,14 +352,14 @@ unRenamedE ::
(Fail.MonadFail m, HasSplice ast) =>
DynFlags ->
ast GhcRn ->
TransformT m (Located (ast GhcPs))
TransformT m (ToL ast GhcPs)
unRenamedE dflags expr = do
uniq <- show <$> uniqueSrcSpanT
(anns, expr') <-
(anns, expr' :: ToL ast GhcPs) <-
either (fail . show) pure $
parseAST @(ast GhcPs) dflags uniq $
parseAST @ast dflags uniq $
showSDoc dflags $ ppr expr
let _anns' = setPrecedingLines expr' 0 1 anns
let _anns' = setPrecedingLines (toLocated expr') 0 1 anns
pure expr'

-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)
Expand Down Expand Up @@ -397,20 +396,20 @@ codeAction _ state plId docId ran _ =
mkQ
Nothing
( \case
(L l@(RealSrcSpan spLoc) HsSpliceE {} :: LHsExpr GhcPs)
((toLocated @HsExpr -> L l@(RealSrcSpan spLoc) HsSpliceE {}) :: LHsExpr GhcPs)
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Expr)
_ -> Nothing
)
`extQ` \case
(L l@(RealSrcSpan spLoc) SplicePat {} :: LPat GhcPs)
((toLocated @Pat -> L l@(RealSrcSpan spLoc) SplicePat {}) :: LPat GhcPs)
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, Pat)
_ -> Nothing
`extQ` \case
(L l@(RealSrcSpan spLoc) HsSpliceTy {} :: LHsType GhcPs)
((toLocated @HsType -> L l@(RealSrcSpan spLoc) HsSpliceTy {}) :: LHsType GhcPs)
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsType)
_ -> Nothing
`extQ` \case
(L l@(RealSrcSpan spLoc) SpliceD {} :: LHsDecl GhcPs)
((toLocated @HsDecl -> L l@(RealSrcSpan spLoc) SpliceD {}) :: LHsDecl GhcPs)
| RealSrcSpan spn `isSubspanOf` l -> Just (spLoc, HsDecl)
_ -> Nothing

Expand Down

0 comments on commit 056f769

Please sign in to comment.