{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Ide.Plugin.Splice
    ( descriptor,
    )
where

import           Control.Applicative             (Alternative ((<|>)))
import           Control.Arrow                   ( Arrow(first) )
import           Control.Exception              ( SomeException )
import qualified Control.Foldl                   as L
import           Control.Lens                    (Identity (..), ix, view, (%~),
                                                  (<&>), (^.))
import           Control.Monad                   ( guard, unless, forM )
import           Control.Monad.Error.Class       ( MonadError(throwError) )
import           Control.Monad.Extra             (eitherM)
import qualified Control.Monad.Fail              as Fail
import           Control.Monad.IO.Unlift         ( MonadIO(..), askRunInIO )
import           Control.Monad.Trans.Class       ( MonadTrans(lift) )
import           Control.Monad.Trans.Except      ( ExceptT(..), runExceptT )
import           Control.Monad.Trans.Maybe
import           Data.Aeson                      hiding (Null)
import qualified Data.Bifunctor                  as B (first)
import           Data.Foldable                   (Foldable (foldl'))
import           Data.Function
import           Data.Generics
import qualified Data.Kind                       as Kinds
import           Data.List                       (sortOn)
import           Data.Maybe                      (fromMaybe, listToMaybe,
                                                  mapMaybe)
import qualified Data.Text                       as T
import           Development.IDE
import           Development.IDE.Core.PluginUtils
import           Development.IDE.GHC.Compat      as Compat hiding (getLoc)
import           Development.IDE.GHC.Compat.ExactPrint
import qualified Development.IDE.GHC.Compat.Util as Util
import           Development.IDE.GHC.ExactPrint
import           Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT))

#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 (uniqueSrcSpanT)
import           Language.LSP.Server
import           Language.LSP.Protocol.Types
import           Language.LSP.Protocol.Message
import qualified Language.LSP.Protocol.Lens         as J
import Ide.Plugin.Error (PluginError(PluginInternalError))

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId =
    (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
        { pluginCommands :: [PluginCommand IdeState]
pluginCommands = [PluginCommand IdeState]
commands
        , pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCodeAction
SMethod_TextDocumentCodeAction PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeAction
        }

commands :: [PluginCommand IdeState]
commands :: [PluginCommand IdeState]
commands =
    [ forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
expandInplaceId Text
inplaceCmdName forall a b. (a -> b) -> a -> b
$ ExpandStyle -> CommandFunction IdeState ExpandSpliceParams
expandTHSplice ExpandStyle
Inplace
    -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented
    ]

newtype SubSpan = SubSpan {SubSpan -> SrcSpan
runSubSpan :: SrcSpan}

instance Eq SubSpan where
    == :: SubSpan -> SubSpan -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SubSpan -> SrcSpan
runSubSpan

instance Ord SubSpan where
    <= :: SubSpan -> SubSpan -> Bool
(<=) = coerce :: forall a b. Coercible a b => a -> b
coerce SrcSpan -> SrcSpan -> Bool
isSubspanOf

expandTHSplice ::
    -- | Inplace?
    ExpandStyle ->
    CommandFunction IdeState ExpandSpliceParams
expandTHSplice :: ExpandStyle -> CommandFunction IdeState ExpandSpliceParams
expandTHSplice ExpandStyle
_eStyle IdeState
ideState params :: ExpandSpliceParams
params@ExpandSpliceParams {RealSrcSpan
VersionedTextDocumentIdentifier
SpliceContext
spliceContext :: ExpandSpliceParams -> SpliceContext
spliceSpan :: ExpandSpliceParams -> RealSrcSpan
verTxtDocId :: ExpandSpliceParams -> VersionedTextDocumentIdentifier
spliceContext :: SpliceContext
spliceSpan :: RealSrcSpan
verTxtDocId :: VersionedTextDocumentIdentifier
..} = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
    ClientCapabilities
clientCapabilities <- forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
    LspT Config IO () -> IO ()
rio <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    let reportEditor :: ReportEditor
        reportEditor :: ReportEditor
reportEditor MessageType
msgTy [Text]
msgs = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LspT Config IO () -> IO ()
rio forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage (MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
msgTy ([Text] -> Text
T.unlines [Text]
msgs))
        expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit
        expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit
expandManually NormalizedFilePath
fp = do
            Maybe (TcModuleResult, PositionMapping)
mresl <-
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"expandTHSplice.fallback.TypeCheck (stale)" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale TypeCheck
TypeCheck NormalizedFilePath
fp
            (TcModuleResult {Bool
RenamedSource
ParsedModule
TcGblEnv
ModuleEnv ByteString
Splices
tmrParsed :: TcModuleResult -> ParsedModule
tmrRenamed :: TcModuleResult -> RenamedSource
tmrTypechecked :: TcModuleResult -> TcGblEnv
tmrTopLevelSplices :: TcModuleResult -> Splices
tmrDeferredError :: TcModuleResult -> Bool
tmrRuntimeModules :: TcModuleResult -> ModuleEnv ByteString
tmrRuntimeModules :: ModuleEnv ByteString
tmrDeferredError :: Bool
tmrTopLevelSplices :: Splices
tmrTypechecked :: TcGblEnv
tmrRenamed :: RenamedSource
tmrParsed :: ParsedModule
..}, PositionMapping
_) <-
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"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."
                )
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TcModuleResult, PositionMapping)
mresl
            ReportEditor
reportEditor
                MessageType
MessageType_Warning
                [ Text
"Expansion in type-checking phase failed;"
                , Text
"trying to expand manually, but note that it is less rigorous."
                ]
            ParsedModule
pm <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"expandTHSplice.fallback.GetParsedModule" IdeState
ideState forall a b. (a -> b) -> a -> b
$
                        forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetParsedModule
GetParsedModule NormalizedFilePath
fp
            (Annotated ParsedSource
ps, HscEnv
hscEnv, DynFlags
_dflags) <- IdeState
-> NormalizedFilePath
-> ParsedModule
-> ExceptT
     PluginError IO (Annotated ParsedSource, HscEnv, DynFlags)
setupHscEnv IdeState
ideState NormalizedFilePath
fp ParsedModule
pm

            ClientCapabilities
-> ReportEditor
-> Range
-> Annotated ParsedSource
-> HscEnv
-> TcGblEnv
-> RealSrcSpan
-> ExpandStyle
-> ExpandSpliceParams
-> ExceptT PluginError IO WorkspaceEdit
manualCalcEdit
                ClientCapabilities
clientCapabilities
                ReportEditor
reportEditor
                Range
range
                Annotated ParsedSource
ps
                HscEnv
hscEnv
                TcGblEnv
tmrTypechecked
                RealSrcSpan
spliceSpan
                ExpandStyle
_eStyle
                ExpandSpliceParams
params

        withTypeChecked :: NormalizedFilePath
-> TcModuleResult -> ExceptT PluginError IO WorkspaceEdit
withTypeChecked NormalizedFilePath
fp TcModuleResult {Bool
RenamedSource
ParsedModule
TcGblEnv
ModuleEnv ByteString
Splices
tmrRuntimeModules :: ModuleEnv ByteString
tmrDeferredError :: Bool
tmrTopLevelSplices :: Splices
tmrTypechecked :: TcGblEnv
tmrRenamed :: RenamedSource
tmrParsed :: ParsedModule
tmrParsed :: TcModuleResult -> ParsedModule
tmrRenamed :: TcModuleResult -> RenamedSource
tmrTypechecked :: TcModuleResult -> TcGblEnv
tmrTopLevelSplices :: TcModuleResult -> Splices
tmrDeferredError :: TcModuleResult -> Bool
tmrRuntimeModules :: TcModuleResult -> ModuleEnv ByteString
..} = do
            (Annotated ParsedSource
ps, HscEnv
_hscEnv, DynFlags
dflags) <- IdeState
-> NormalizedFilePath
-> ParsedModule
-> ExceptT
     PluginError IO (Annotated ParsedSource, HscEnv, DynFlags)
setupHscEnv IdeState
ideState NormalizedFilePath
fp ParsedModule
tmrParsed
            let Splices {[(LHsExpr GhcTc, [LHsDecl GhcPs])]
[(LHsExpr GhcTc, Serialized)]
[(LHsExpr GhcTc, LHsType GhcPs)]
[(LHsExpr GhcTc, LPat GhcPs)]
[(LHsExpr GhcTc, LHsExpr GhcPs)]
exprSplices :: Splices -> [(LHsExpr GhcTc, LHsExpr GhcPs)]
patSplices :: Splices -> [(LHsExpr GhcTc, LPat GhcPs)]
typeSplices :: Splices -> [(LHsExpr GhcTc, LHsType GhcPs)]
declSplices :: Splices -> [(LHsExpr GhcTc, [LHsDecl GhcPs])]
awSplices :: Splices -> [(LHsExpr GhcTc, Serialized)]
awSplices :: [(LHsExpr GhcTc, Serialized)]
declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])]
typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)]
patSplices :: [(LHsExpr GhcTc, LPat GhcPs)]
exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)]
..} = Splices
tmrTopLevelSplices
            let exprSuperSpans :: Maybe (SrcSpan, LocatedAn AnnListItem (HsExpr GhcPs))
exprSuperSpans =
                    forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
findSubSpansDesc SrcSpan
srcSpan [(LHsExpr GhcTc, LHsExpr GhcPs)]
exprSplices
                _patSuperSpans :: Maybe (SrcSpan, LocatedAn AnnListItem (Pat GhcPs))
_patSuperSpans =
                    forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
findSubSpansDesc SrcSpan
srcSpan [(LHsExpr GhcTc, LPat GhcPs)]
patSplices
                typeSuperSpans :: Maybe (SrcSpan, LocatedAn AnnListItem (HsType GhcPs))
typeSuperSpans =
                    forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
findSubSpansDesc SrcSpan
srcSpan [(LHsExpr GhcTc, LHsType GhcPs)]
typeSplices
                declSuperSpans :: Maybe (SrcSpan, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
declSuperSpans =
                    forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
findSubSpansDesc SrcSpan
srcSpan [(LHsExpr GhcTc, [LHsDecl GhcPs])]
declSplices

                graftSpliceWith ::
                    forall ast.
                    HasSplice AnnListItem ast =>
                    Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs)) ->
                    Maybe (Either String WorkspaceEdit)
                graftSpliceWith :: forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs))
-> Maybe (Either String WorkspaceEdit)
graftSpliceWith Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs))
expandeds =
                    Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs))
expandeds forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SrcSpan
_, LocatedAn AnnListItem (ast GhcPs)
expanded) ->
                        DynFlags
-> ClientCapabilities
-> VersionedTextDocumentIdentifier
-> Graft (Either String) ParsedSource
-> Annotated ParsedSource
-> Either String WorkspaceEdit
transform
                            DynFlags
dflags
                            ClientCapabilities
clientCapabilities
                            VersionedTextDocumentIdentifier
verTxtDocId
                            (forall l ast a.
(ASTElement l ast, Data a) =>
SrcSpan -> LocatedAn l ast -> Graft (Either String) a
graft (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
spliceSpan forall a. Maybe a
Nothing) LocatedAn AnnListItem (ast GhcPs)
expanded)
                            Annotated ParsedSource
ps
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"No splice information found") (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PluginError
PluginInternalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall a b. (a -> b) -> a -> b
$
                case SpliceContext
spliceContext of
                    SpliceContext
Expr -> forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs))
-> Maybe (Either String WorkspaceEdit)
graftSpliceWith Maybe (SrcSpan, LocatedAn AnnListItem (HsExpr GhcPs))
exprSuperSpans
                    SpliceContext
Pat ->

                        forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs))
-> Maybe (Either String WorkspaceEdit)
graftSpliceWith Maybe (SrcSpan, LocatedAn AnnListItem (Pat GhcPs))
_patSuperSpans

                    SpliceContext
HsType -> forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Maybe (SrcSpan, LocatedAn AnnListItem (ast GhcPs))
-> Maybe (Either String WorkspaceEdit)
graftSpliceWith Maybe (SrcSpan, LocatedAn AnnListItem (HsType GhcPs))
typeSuperSpans
                    SpliceContext
HsDecl ->
                        Maybe (SrcSpan, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
declSuperSpans forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SrcSpan
_, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
expanded) ->
                            DynFlags
-> ClientCapabilities
-> VersionedTextDocumentIdentifier
-> Graft (Either String) ParsedSource
-> Annotated ParsedSource
-> Either String WorkspaceEdit
transform
                                DynFlags
dflags
                                ClientCapabilities
clientCapabilities
                                VersionedTextDocumentIdentifier
verTxtDocId
                                (forall a.
HasDecls a =>
SrcSpan -> [LHsDecl GhcPs] -> Graft (Either String) a
graftDecls (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
spliceSpan forall a. Maybe a
Nothing) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
expanded)
                                Annotated ParsedSource
ps
                                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
                                -- FIXME: Why ghc-exactprint sweeps preceding comments?
                                Uri -> Range -> WorkspaceEdit -> WorkspaceEdit
adjustToRange (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
J.uri) Range
range

    Maybe (Either PluginError WorkspaceEdit)
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do

            NormalizedFilePath
fp <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
J.uri)
            Either PluginError WorkspaceEdit
eedits <-
                ( forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath
-> TcModuleResult -> ExceptT PluginError IO WorkspaceEdit
withTypeChecked NormalizedFilePath
fp
                        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT
                            (forall a. String -> IdeState -> Action a -> IO a
runAction String
"expandTHSplice.TypeCheck" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
fp)
                    )
                    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit
expandManually NormalizedFilePath
fp)

            case Either PluginError WorkspaceEdit
eedits of
                Left PluginError
err -> do
                    ReportEditor
reportEditor
                        MessageType
MessageType_Error
                        [String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Error during expanding splice: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a ann. Pretty a => a -> Doc ann
pretty PluginError
err)]
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left PluginError
err)
                Right WorkspaceEdit
edits ->
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right WorkspaceEdit
edits)
    case Maybe (Either PluginError WorkspaceEdit)
res of
      Maybe (Either PluginError WorkspaceEdit)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null
      Just (Left PluginError
err) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PluginError
err
      Just (Right WorkspaceEdit
edit) -> do
        LspId 'Method_WorkspaceApplyEdit
_ <- forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null

    where
        range :: Range
range = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
spliceSpan
        srcSpan :: SrcSpan
srcSpan = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
spliceSpan forall a. Maybe a
Nothing


setupHscEnv
    :: IdeState
    -> NormalizedFilePath
    -> ParsedModule
    -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags)
setupHscEnv :: IdeState
-> NormalizedFilePath
-> ParsedModule
-> ExceptT
     PluginError IO (Annotated ParsedSource, HscEnv, DynFlags)
setupHscEnv IdeState
ideState NormalizedFilePath
fp ParsedModule
pm = do
    HscEnvEq
hscEnvEq <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"expandTHSplice.fallback.ghcSessionDeps" IdeState
ideState forall a b. (a -> b) -> a -> b
$
                    forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
fp
    let ps :: Annotated ParsedSource
ps = ParsedModule -> Annotated ParsedSource
annotateParsedSource ParsedModule
pm
        hscEnv0 :: HscEnv
hscEnv0 = HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq
hscEnvEq
        modSum :: ModSummary
modSum = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pm
    HscEnv
hscEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags -> IO HscEnv
setupDynFlagsForGHCiLike HscEnv
hscEnv0 forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
modSum
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotated ParsedSource
ps, HscEnv
hscEnv, HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv)

setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO HscEnv
setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO HscEnv
setupDynFlagsForGHCiLike HscEnv
env DynFlags
dflags = do
    let dflags3 :: DynFlags
dflags3 = DynFlags -> DynFlags
setInterpreterLinkerOptions DynFlags
dflags
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags3
        dflags3a :: DynFlags
dflags3a = Ways -> DynFlags -> DynFlags
setWays Ways
hostFullWays DynFlags
dflags3
        dflags3b :: DynFlags
dflags3b =
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags3a forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform) Ways
hostFullWays
        dflags3c :: DynFlags
dflags3c =
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags3b forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform) Ways
hostFullWays
        dflags4 :: DynFlags
dflags4 =
            DynFlags
dflags3c
                DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_ImplicitImportQualified
                DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_IgnoreOptimChanges
                DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_IgnoreHpcChanges
                DynFlags -> GeneralFlag -> DynFlags
`gopt_unset` GeneralFlag
Opt_DiagnosticsShowCaret
    HscEnv -> IO HscEnv
initializePlugins (DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags4 HscEnv
env)

adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit
adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit
adjustToRange Uri
uri Range
ran (WorkspaceEdit Maybe (Map Uri [TextEdit])
mhult Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
mlt Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
x) =
    Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (Map Uri [TextEdit] -> Map Uri [TextEdit]
adjustWS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Map Uri [TextEdit])
mhult) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
adjustDoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
mlt) Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
x
    where
        adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit
        adjustTextEdits :: forall (f :: * -> *). Traversable f => f TextEdit -> f TextEdit
adjustTextEdits f TextEdit
eds =
            let minStart :: Range
minStart =
                    case forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b
L.fold (forall a b r. (a -> b) -> Fold b r -> Fold a r
L.premap (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasRange s a => Lens' s a
J.range) forall a. Ord a => Fold a (Maybe a)
L.minimum) f TextEdit
eds of
                        Maybe Range
Nothing -> forall a. HasCallStack => String -> a
error String
"impossible"
                        Just Range
v -> Range
v
            in Range -> TextEdit -> TextEdit
adjustLine Range
minStart forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f TextEdit
eds

        adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit)
        adjustATextEdits :: forall (f :: * -> *).
Traversable f =>
f (TextEdit |? AnnotatedTextEdit)
-> f (TextEdit |? AnnotatedTextEdit)
adjustATextEdits = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \case
          InL TextEdit
t -> forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Traversable f => f TextEdit -> f TextEdit
adjustTextEdits (forall a. a -> Identity a
Identity TextEdit
t)
          InR AnnotatedTextEdit{Range
$sel:_range:AnnotatedTextEdit :: AnnotatedTextEdit -> Range
_range :: Range
_range, Text
$sel:_newText:AnnotatedTextEdit :: AnnotatedTextEdit -> Text
_newText :: Text
_newText, ChangeAnnotationIdentifier
$sel:_annotationId:AnnotatedTextEdit :: AnnotatedTextEdit -> ChangeAnnotationIdentifier
_annotationId :: ChangeAnnotationIdentifier
_annotationId} ->
            let oldTE :: TextEdit
oldTE = TextEdit{Range
$sel:_range:TextEdit :: Range
_range :: Range
_range,Text
$sel:_newText:TextEdit :: Text
_newText :: Text
_newText}
              in let TextEdit{Range
_range :: Range
$sel:_range:TextEdit :: TextEdit -> Range
_range,Text
_newText :: Text
$sel:_newText:TextEdit :: TextEdit -> Text
_newText} = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Traversable f => f TextEdit -> f TextEdit
adjustTextEdits (forall a. a -> Identity a
Identity TextEdit
oldTE)
                in forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ AnnotatedTextEdit{Range
_range :: Range
$sel:_range:AnnotatedTextEdit :: Range
_range,Text
_newText :: Text
$sel:_newText:AnnotatedTextEdit :: Text
_newText,ChangeAnnotationIdentifier
$sel:_annotationId:AnnotatedTextEdit :: ChangeAnnotationIdentifier
_annotationId :: ChangeAnnotationIdentifier
_annotationId}

        adjustWS :: Map Uri [TextEdit] -> Map Uri [TextEdit]
adjustWS = forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Uri
uri forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *). Traversable f => f TextEdit -> f TextEdit
adjustTextEdits
        adjustDoc :: DocumentChange -> DocumentChange
        adjustDoc :: (TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
adjustDoc (InR CreateFile |? (RenameFile |? DeleteFile)
es) = forall a b. b -> a |? b
InR CreateFile |? (RenameFile |? DeleteFile)
es
        adjustDoc (InL TextDocumentEdit
es)
            | TextDocumentEdit
es forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
J.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
J.uri forall a. Eq a => a -> a -> Bool
== Uri
uri =
                forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ TextDocumentEdit
es forall a b. a -> (a -> b) -> b
& forall s a. HasEdits s a => Lens' s a
J.edits forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *).
Traversable f =>
f (TextEdit |? AnnotatedTextEdit)
-> f (TextEdit |? AnnotatedTextEdit)
adjustATextEdits
            | Bool
otherwise = forall a b. a -> a |? b
InL TextDocumentEdit
es

        adjustLine :: Range -> TextEdit -> TextEdit
        adjustLine :: Range -> TextEdit -> TextEdit
adjustLine Range
bad =
            forall s a. HasRange s a => Lens' s a
J.range forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Range
r ->
                if Range
r forall a. Eq a => a -> a -> Bool
== Range
bad then Range
ran else Range
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 $mAsSrcSpan :: forall {r} {a}.
SrcSpanAnn' a -> (SrcSpan -> r) -> ((# #) -> r) -> r
AsSrcSpan locA <- SrcSpanAnn {locA}
#else
pattern AsSrcSpan :: SrcSpan -> SrcSpan
pattern AsSrcSpan loc <- loc
#endif

findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
findSubSpansDesc :: forall a. SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
findSubSpansDesc SrcSpan
srcSpan =
    forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SubSpan
SubSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            ( \(L (AsSrcSpan SrcSpan
spn) HsExpr GhcTc
_, a
e) -> do
                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SrcSpan
spn SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
srcSpan)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
spn, a
e)
            )

data SpliceClass where
    OneToOneAST :: HasSplice AnnListItem ast => Proxy# ast -> SpliceClass
    IsHsDecl :: SpliceClass

#if MIN_VERSION_ghc(9,5,0)
data HsSpliceCompat pass
  = UntypedSplice (HsUntypedSplice pass)
  | TypedSplice (LHsExpr pass)
#endif


class (Outputable (ast GhcRn), ASTElement l (ast GhcPs)) => HasSplice l ast where
    type SpliceOf ast :: Kinds.Type -> Kinds.Type
    matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs)
    expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars)

instance HasSplice AnnListItem HsExpr where
#if MIN_VERSION_ghc(9,5,0)
    type SpliceOf HsExpr = HsSpliceCompat
    matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl)
    matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl)
#else
    type SpliceOf HsExpr = HsSplice
    matchSplice :: Proxy# HsExpr -> HsExpr GhcPs -> Maybe (SpliceOf HsExpr GhcPs)
matchSplice Proxy# HsExpr
_ (HsSpliceE XSpliceE GhcPs
_ HsSplice GhcPs
spl) = forall a. a -> Maybe a
Just HsSplice GhcPs
spl
#endif
    matchSplice Proxy# HsExpr
_ HsExpr GhcPs
_                 = forall a. Maybe a
Nothing
#if MIN_VERSION_ghc(9,5,0)
    expandSplice _ (UntypedSplice e) = fmap (first Right) $ rnUntypedSpliceExpr e
    expandSplice _ (TypedSplice e) = fmap (first Right) $ rnTypedSplice e
#else
    expandSplice :: Proxy# HsExpr
-> SpliceOf HsExpr GhcPs
-> RnM (Either (HsExpr GhcPs) (HsExpr GhcRn), FreeVars)
expandSplice Proxy# HsExpr
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. b -> Either a b
Right) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSpliceExpr
#endif

instance HasSplice AnnListItem Pat where
#if MIN_VERSION_ghc(9,5,0)
    type SpliceOf Pat = HsUntypedSplice
#else
    type SpliceOf Pat = HsSplice
#endif
    matchSplice :: Proxy# Pat -> Pat GhcPs -> Maybe (SpliceOf Pat GhcPs)
matchSplice Proxy# Pat
_ (SplicePat XSplicePat GhcPs
_ HsSplice GhcPs
spl) = forall a. a -> Maybe a
Just HsSplice GhcPs
spl
    matchSplice Proxy# Pat
_ Pat GhcPs
_                 = forall a. Maybe a
Nothing
    expandSplice :: Proxy# Pat
-> SpliceOf Pat GhcPs
-> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
expandSplice Proxy# Pat
_ =
#if MIN_VERSION_ghc(9,5,0)
      fmap (first (Left . unLoc . utsplice_result . snd )) .
#endif
      HsSplice GhcPs -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
rnSplicePat


instance HasSplice AnnListItem HsType where
#if MIN_VERSION_ghc(9,5,0)
    type SpliceOf HsType = HsUntypedSplice
#else
    type SpliceOf HsType = HsSplice
#endif
    matchSplice :: Proxy# HsType -> HsType GhcPs -> Maybe (SpliceOf HsType GhcPs)
matchSplice Proxy# HsType
_ (HsSpliceTy XSpliceTy GhcPs
_ HsSplice GhcPs
spl) = forall a. a -> Maybe a
Just HsSplice GhcPs
spl
    matchSplice Proxy# HsType
_ HsType GhcPs
_                  = forall a. Maybe a
Nothing
    expandSplice :: Proxy# HsType
-> SpliceOf HsType GhcPs
-> RnM (Either (HsType GhcPs) (HsType GhcRn), FreeVars)
expandSplice Proxy# HsType
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. b -> Either a b
Right) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType

classifyAST :: SpliceContext -> SpliceClass
classifyAST :: SpliceContext -> SpliceClass
classifyAST = \case
    SpliceContext
Expr   -> forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Proxy# ast -> SpliceClass
OneToOneAST @HsExpr forall {k} (a :: k). Proxy# a
proxy#
    SpliceContext
HsDecl -> SpliceClass
IsHsDecl
    SpliceContext
Pat    -> forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Proxy# ast -> SpliceClass
OneToOneAST @Pat forall {k} (a :: k). Proxy# a
proxy#
    SpliceContext
HsType -> forall (ast :: * -> *).
HasSplice AnnListItem ast =>
Proxy# ast -> SpliceClass
OneToOneAST @HsType forall {k} (a :: k). Proxy# a
proxy#

type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m ()

manualCalcEdit ::
    ClientCapabilities ->
    ReportEditor ->
    Range ->
    Annotated ParsedSource ->
    HscEnv ->
    TcGblEnv ->
    RealSrcSpan ->
    ExpandStyle ->
    ExpandSpliceParams ->
    ExceptT PluginError IO WorkspaceEdit
manualCalcEdit :: ClientCapabilities
-> ReportEditor
-> Range
-> Annotated ParsedSource
-> HscEnv
-> TcGblEnv
-> RealSrcSpan
-> ExpandStyle
-> ExpandSpliceParams
-> ExceptT PluginError IO WorkspaceEdit
manualCalcEdit ClientCapabilities
clientCapabilities ReportEditor
reportEditor Range
ran Annotated ParsedSource
ps HscEnv
hscEnv TcGblEnv
typechkd RealSrcSpan
srcSpan ExpandStyle
_eStyle ExpandSpliceParams {RealSrcSpan
VersionedTextDocumentIdentifier
SpliceContext
spliceContext :: SpliceContext
spliceSpan :: RealSrcSpan
verTxtDocId :: VersionedTextDocumentIdentifier
spliceContext :: ExpandSpliceParams -> SpliceContext
spliceSpan :: ExpandSpliceParams -> RealSrcSpan
verTxtDocId :: ExpandSpliceParams -> VersionedTextDocumentIdentifier
..} = do
    (Bag (MsgEnvelope DecoratedSDoc)
warns, WorkspaceEdit
resl) <-
        forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
            (Messages DecoratedSDoc
msgs, Maybe (Either String WorkspaceEdit)
eresl) <-
                forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hscEnv TcGblEnv
typechkd RealSrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$
                    case SpliceContext -> SpliceClass
classifyAST SpliceContext
spliceContext of
                        SpliceClass
IsHsDecl -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ Uri -> Range -> WorkspaceEdit -> WorkspaceEdit
adjustToRange (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
J.uri) Range
ran) forall a b. (a -> b) -> a -> b
$
                            forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *).
Monad m =>
DynFlags
-> ClientCapabilities
-> VersionedTextDocumentIdentifier
-> Graft (ExceptStringT m) ParsedSource
-> Annotated ParsedSource
-> m (Either String WorkspaceEdit)
transformM DynFlags
dflags ClientCapabilities
clientCapabilities VersionedTextDocumentIdentifier
verTxtDocId) Annotated ParsedSource
ps forall a b. (a -> b) -> a -> b
$
                                forall a (m :: * -> *).
(HasDecls a, MonadFail m) =>
SrcSpan
-> (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs]))
-> Graft m a
graftDeclsWithM (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
srcSpan forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ \case
                                    (L SrcSpanAnnA
_spn (SpliceD XSpliceD GhcPs
_ (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
_ HsSplice GhcPs
spl) SpliceExplicitFlag
_))) -> do
                                        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
eExpr <-
                                            forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                                forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. RWST () [String] Int m a -> TransformT m a
TransformT forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                                                    ( forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
                                                        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Util.try @_ @SomeException forall a b. (a -> b) -> a -> b
$
                                                            (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsSplice GhcPs
spl)
                                                    )
                                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
eExpr
                                    LHsDecl GhcPs
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                        OneToOneAST Proxy# ast
astP ->
                            forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *).
Monad m =>
DynFlags
-> ClientCapabilities
-> VersionedTextDocumentIdentifier
-> Graft (ExceptStringT m) ParsedSource
-> Annotated ParsedSource
-> m (Either String WorkspaceEdit)
transformM DynFlags
dflags ClientCapabilities
clientCapabilities VersionedTextDocumentIdentifier
verTxtDocId) Annotated ParsedSource
ps forall a b. (a -> b) -> a -> b
$
                                forall ast (m :: * -> *) a l.
(MonadFail m, Data a, Typeable l, ASTElement l ast) =>
SrcSpan
-> (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast)))
-> Graft m a
graftWithM (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
srcSpan forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ \case
                                    (L SrcSpanAnnA
_spn (forall l (ast :: * -> *).
HasSplice l ast =>
Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs)
matchSplice Proxy# ast
astP -> Just SpliceOf ast GhcPs
spl)) -> do
                                        Either (ast GhcPs) (ast GhcRn)
eExpr <-
                                            forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                                forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. RWST () [String] Int m a -> TransformT m a
TransformT forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                                                    ( forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
                                                        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Util.try @_ @SomeException forall a b. (a -> b) -> a -> b
$
                                                            (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall l (ast :: * -> *).
HasSplice l ast =>
Proxy# ast
-> SpliceOf ast GhcPs
-> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars)
expandSplice Proxy# ast
astP SpliceOf ast GhcPs
spl)
                                                    )
                                        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Either (ast GhcPs) (ast GhcRn)
eExpr of
                                            Left ast GhcPs
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
_spn ast GhcPs
x
                                            Right ast GhcRn
y -> forall (ast :: * -> *) (m :: * -> *) l.
(MonadFail m, HasSplice l ast) =>
DynFlags -> ast GhcRn -> TransformT m (LocatedAn l (ast GhcPs))
unRenamedE DynFlags
dflags ast GhcRn
y
                                    LocatedAn AnnListItem (ast GhcPs)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            let (Bag (MsgEnvelope DecoratedSDoc)
warns, Bag (MsgEnvelope DecoratedSDoc)
errs) =
#if MIN_VERSION_ghc(9,2,0)
                                (forall e. Messages e -> Bag (MsgEnvelope e)
Error.getWarningMessages Messages DecoratedSDoc
msgs, forall e. Messages e -> Bag (MsgEnvelope e)
Error.getErrorMessages Messages DecoratedSDoc
msgs)
#else
                                msgs
#endif
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Bag (MsgEnvelope DecoratedSDoc)
warns,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope DecoratedSDoc) -> String
showErrors Bag (MsgEnvelope DecoratedSDoc)
errs)
                                    (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
B.first (Text -> PluginError
PluginInternalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)) Maybe (Either String WorkspaceEdit)
eresl

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag (MsgEnvelope DecoratedSDoc)
warns)
        forall a b. (a -> b) -> a -> b
$ ReportEditor
reportEditor
            MessageType
MessageType_Warning
            [ Text
"Warning during expanding: "
            , Text
""
            , String -> Text
T.pack (Bag (MsgEnvelope DecoratedSDoc) -> String
showErrors Bag (MsgEnvelope DecoratedSDoc)
warns)
            ]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure WorkspaceEdit
resl
    where
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv

#if MIN_VERSION_ghc(9,4,1)
        showErrors = showBag
#else
        showErrors :: Bag (MsgEnvelope DecoratedSDoc) -> String
showErrors = forall a. Show a => a -> String
show
#endif

#if MIN_VERSION_ghc(9,4,1)
showBag :: Error.Diagnostic a => Bag (Error.MsgEnvelope a) -> String
showBag = show . fmap (fmap toDiagnosticMessage)

toDiagnosticMessage :: forall a. Error.Diagnostic a => a -> Error.DiagnosticMessage
toDiagnosticMessage message =
    Error.DiagnosticMessage
        { diagMessage = Error.diagnosticMessage
#if MIN_VERSION_ghc(9,5,0)
                          (Error.defaultDiagnosticOpts @a)
#endif
                          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 (LocatedAn l (ast GhcPs))
unRenamedE :: forall (ast :: * -> *) (m :: * -> *) l.
(MonadFail m, HasSplice l ast) =>
DynFlags -> ast GhcRn -> TransformT m (LocatedAn l (ast GhcPs))
unRenamedE DynFlags
dflags ast GhcRn
expr = do
    String
uniq <- forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
#if MIN_VERSION_ghc(9,2,0)
    LocatedAn l (ast GhcPs)
expr' <-
#else
    (_anns, expr') <-
#endif
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope DecoratedSDoc) -> String
showErrors) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall l ast. ASTElement l ast => Parser (LocatedAn l ast)
parseAST @_ @(ast GhcPs) DynFlags
dflags String
uniq forall a b. (a -> b) -> a -> b
$
            DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr ast GhcRn
expr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedAn l (ast GhcPs)
expr'
  where
#if MIN_VERSION_ghc(9,4,1)
    showErrors = showBag . Error.getMessages
#else
    showErrors :: Bag (MsgEnvelope DecoratedSDoc) -> String
showErrors = forall a. Show a => a -> String
show
#endif

data SearchResult r =
    Continue | Stop | Here r
    deriving (ReadPrec [SearchResult r]
ReadPrec (SearchResult r)
ReadS [SearchResult r]
forall r. Read r => ReadPrec [SearchResult r]
forall r. Read r => ReadPrec (SearchResult r)
forall r. Read r => Int -> ReadS (SearchResult r)
forall r. Read r => ReadS [SearchResult r]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SearchResult r]
$creadListPrec :: forall r. Read r => ReadPrec [SearchResult r]
readPrec :: ReadPrec (SearchResult r)
$creadPrec :: forall r. Read r => ReadPrec (SearchResult r)
readList :: ReadS [SearchResult r]
$creadList :: forall r. Read r => ReadS [SearchResult r]
readsPrec :: Int -> ReadS (SearchResult r)
$creadsPrec :: forall r. Read r => Int -> ReadS (SearchResult r)
Read, Int -> SearchResult r -> ShowS
forall r. Show r => Int -> SearchResult r -> ShowS
forall r. Show r => [SearchResult r] -> ShowS
forall r. Show r => SearchResult r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchResult r] -> ShowS
$cshowList :: forall r. Show r => [SearchResult r] -> ShowS
show :: SearchResult r -> String
$cshow :: forall r. Show r => SearchResult r -> String
showsPrec :: Int -> SearchResult r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> SearchResult r -> ShowS
Show, SearchResult r -> SearchResult r -> Bool
forall r. Eq r => SearchResult r -> SearchResult r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchResult r -> SearchResult r -> Bool
$c/= :: forall r. Eq r => SearchResult r -> SearchResult r -> Bool
== :: SearchResult r -> SearchResult r -> Bool
$c== :: forall r. Eq r => SearchResult r -> SearchResult r -> Bool
Eq, SearchResult r -> SearchResult r -> Bool
SearchResult r -> SearchResult r -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {r}. Ord r => Eq (SearchResult r)
forall r. Ord r => SearchResult r -> SearchResult r -> Bool
forall r. Ord r => SearchResult r -> SearchResult r -> Ordering
forall r.
Ord r =>
SearchResult r -> SearchResult r -> SearchResult r
min :: SearchResult r -> SearchResult r -> SearchResult r
$cmin :: forall r.
Ord r =>
SearchResult r -> SearchResult r -> SearchResult r
max :: SearchResult r -> SearchResult r -> SearchResult r
$cmax :: forall r.
Ord r =>
SearchResult r -> SearchResult r -> SearchResult r
>= :: SearchResult r -> SearchResult r -> Bool
$c>= :: forall r. Ord r => SearchResult r -> SearchResult r -> Bool
> :: SearchResult r -> SearchResult r -> Bool
$c> :: forall r. Ord r => SearchResult r -> SearchResult r -> Bool
<= :: SearchResult r -> SearchResult r -> Bool
$c<= :: forall r. Ord r => SearchResult r -> SearchResult r -> Bool
< :: SearchResult r -> SearchResult r -> Bool
$c< :: forall r. Ord r => SearchResult r -> SearchResult r -> Bool
compare :: SearchResult r -> SearchResult r -> Ordering
$ccompare :: forall r. Ord r => SearchResult r -> SearchResult r -> Ordering
Ord, SearchResult r -> DataType
SearchResult r -> Constr
forall {r}. Data r => Typeable (SearchResult r)
forall r. Data r => SearchResult r -> DataType
forall r. Data r => SearchResult r -> Constr
forall r.
Data r =>
(forall b. Data b => b -> b) -> SearchResult r -> SearchResult r
forall r u.
Data r =>
Int -> (forall d. Data d => d -> u) -> SearchResult r -> u
forall r u.
Data r =>
(forall d. Data d => d -> u) -> SearchResult r -> [u]
forall r r r'.
Data r =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SearchResult r -> r
forall r r r'.
Data r =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SearchResult r -> r
forall r (m :: * -> *).
(Data r, Monad m) =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
forall r (m :: * -> *).
(Data r, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
forall r (c :: * -> *).
Data r =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SearchResult r)
forall r (c :: * -> *).
Data r =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SearchResult r -> c (SearchResult r)
forall r (t :: * -> *) (c :: * -> *).
(Data r, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (SearchResult r))
forall r (t :: * -> * -> *) (c :: * -> *).
(Data r, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SearchResult r))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SearchResult r)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SearchResult r -> c (SearchResult r)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (SearchResult r))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
$cgmapMo :: forall r (m :: * -> *).
(Data r, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
$cgmapMp :: forall r (m :: * -> *).
(Data r, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
$cgmapM :: forall r (m :: * -> *).
(Data r, Monad m) =>
(forall d. Data d => d -> m d)
-> SearchResult r -> m (SearchResult r)
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> SearchResult r -> u
$cgmapQi :: forall r u.
Data r =>
Int -> (forall d. Data d => d -> u) -> SearchResult r -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> SearchResult r -> [u]
$cgmapQ :: forall r u.
Data r =>
(forall d. Data d => d -> u) -> SearchResult r -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SearchResult r -> r
$cgmapQr :: forall r r r'.
Data r =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SearchResult r -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SearchResult r -> r
$cgmapQl :: forall r r r'.
Data r =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SearchResult r -> r
gmapT :: (forall b. Data b => b -> b) -> SearchResult r -> SearchResult r
$cgmapT :: forall r.
Data r =>
(forall b. Data b => b -> b) -> SearchResult r -> SearchResult r
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SearchResult r))
$cdataCast2 :: forall r (t :: * -> * -> *) (c :: * -> *).
(Data r, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SearchResult r))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (SearchResult r))
$cdataCast1 :: forall r (t :: * -> *) (c :: * -> *).
(Data r, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (SearchResult r))
dataTypeOf :: SearchResult r -> DataType
$cdataTypeOf :: forall r. Data r => SearchResult r -> DataType
toConstr :: SearchResult r -> Constr
$ctoConstr :: forall r. Data r => SearchResult r -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SearchResult r)
$cgunfold :: forall r (c :: * -> *).
Data r =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SearchResult r)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SearchResult r -> c (SearchResult r)
$cgfoldl :: forall r (c :: * -> *).
Data r =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SearchResult r -> c (SearchResult r)
Data, Typeable)

fromSearchResult :: SearchResult a -> Maybe a
fromSearchResult :: forall a. SearchResult a -> Maybe a
fromSearchResult (Here a
r) = forall a. a -> Maybe a
Just a
r
fromSearchResult SearchResult a
_        = forall a. Maybe a
Nothing

-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)
-- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs?
codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeAction IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
ran CodeActionContext
_) = do
    VersionedTextDocumentIdentifier
verTxtDocId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc TextDocumentIdentifier
docId
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe ( forall a b. a -> a |? b
InL [])) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
            NormalizedFilePath
fp <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
theUri
            ParsedModule {[String]
()
ModSummary
ParsedSource
pm_parsed_source :: ParsedModule -> ParsedSource
pm_extra_src_files :: ParsedModule -> [String]
pm_annotations :: ParsedModule -> ()
pm_annotations :: ()
pm_extra_src_files :: [String]
pm_parsed_source :: ParsedSource
pm_mod_summary :: ModSummary
pm_mod_summary :: ParsedModule -> ModSummary
..} <-
                forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> IdeState -> Action a -> IO a
runAction String
"splice.codeAction.GitHieAst" IdeState
state forall a b. (a -> b) -> a -> b
$
                    forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
fp
            let spn :: RealSrcSpan
spn = NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan NormalizedFilePath
fp Range
ran
                mouterSplice :: Maybe (RealSrcSpan, SpliceContext)
mouterSplice = forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a)
something' (RealSrcSpan -> GenericQ (SearchResult (RealSrcSpan, SpliceContext))
detectSplice RealSrcSpan
spn) ParsedSource
pm_parsed_source
            Maybe [Command |? CodeAction]
mcmds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (RealSrcSpan, SpliceContext)
mouterSplice forall a b. (a -> b) -> a -> b
$
                \(RealSrcSpan
spliceSpan, SpliceContext
spliceContext) ->
                    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ExpandStyle, (Text, CommandId))]
expandStyles forall a b. (a -> b) -> a -> b
$ \(ExpandStyle
_, (Text
title, CommandId
cmdId)) -> do
                        let params :: ExpandSpliceParams
params = ExpandSpliceParams {VersionedTextDocumentIdentifier
verTxtDocId :: VersionedTextDocumentIdentifier
verTxtDocId :: VersionedTextDocumentIdentifier
verTxtDocId, RealSrcSpan
SpliceContext
spliceContext :: SpliceContext
spliceSpan :: RealSrcSpan
spliceContext :: SpliceContext
spliceSpan :: RealSrcSpan
..}
                            act :: Command
act = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
cmdId Text
title (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON ExpandSpliceParams
params])
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                            forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$
                                Text
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== Text) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
CodeAction Text
title (forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_RefactorRewrite) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Command
act) forall a. Maybe a
Nothing

            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe [Command |? CodeAction]
mcmds
    where
        theUri :: Uri
theUri = TextDocumentIdentifier
docId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
J.uri
        detectSplice ::
            RealSrcSpan ->
            GenericQ (SearchResult (RealSrcSpan, SpliceContext))
        detectSplice :: RealSrcSpan -> GenericQ (SearchResult (RealSrcSpan, SpliceContext))
detectSplice RealSrcSpan
spn =
          let
            spanIsRelevant :: SrcSpan -> Bool
spanIsRelevant SrcSpan
x = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
spn forall a. Maybe a
Nothing SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
x
          in
            forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ
                forall r. SearchResult r
Continue
                ( \case
                    (L (AsSrcSpan l :: SrcSpan
l@(RealSrcSpan RealSrcSpan
spLoc Maybe BufSpan
_)) HsExpr GhcPs
expr :: LHsExpr GhcPs)
                        | SrcSpan -> Bool
spanIsRelevant SrcSpan
l ->
                            case HsExpr GhcPs
expr of
#if MIN_VERSION_ghc(9,5,0)
                                HsTypedSplice{} -> Here (spLoc, Expr)
                                HsUntypedSplice{} -> Here (spLoc, Expr)
#else
                                HsSpliceE {} -> forall r. r -> SearchResult r
Here (RealSrcSpan
spLoc, SpliceContext
Expr)
#endif
                                HsExpr GhcPs
_            -> forall r. SearchResult r
Continue
                    LocatedAn AnnListItem (HsExpr GhcPs)
_ -> forall r. SearchResult r
Stop
                )
                forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` \case
#if __GLASGOW_HASKELL__ == 808
                    (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs))
#else
                    (L (AsSrcSpan l :: SrcSpan
l@(RealSrcSpan RealSrcSpan
spLoc Maybe BufSpan
_)) Pat GhcPs
pat :: LPat GhcPs)
#endif
                        | SrcSpan -> Bool
spanIsRelevant SrcSpan
l ->
                            case Pat GhcPs
pat of
                                SplicePat{} -> forall r. r -> SearchResult r
Here (RealSrcSpan
spLoc, SpliceContext
Pat)
                                Pat GhcPs
_           -> forall r. SearchResult r
Continue
                    LocatedAn AnnListItem (Pat GhcPs)
_ -> forall r. SearchResult r
Stop
                forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` \case
                    (L (AsSrcSpan l :: SrcSpan
l@(RealSrcSpan RealSrcSpan
spLoc Maybe BufSpan
_)) HsType GhcPs
ty :: LHsType GhcPs)
                        | SrcSpan -> Bool
spanIsRelevant SrcSpan
l ->
                            case HsType GhcPs
ty of
                                HsSpliceTy {} -> forall r. r -> SearchResult r
Here (RealSrcSpan
spLoc, SpliceContext
HsType)
                                HsType GhcPs
_             -> forall r. SearchResult r
Continue
                    LocatedAn AnnListItem (HsType GhcPs)
_ -> forall r. SearchResult r
Stop
                forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` \case
                    (L (AsSrcSpan l :: SrcSpan
l@(RealSrcSpan RealSrcSpan
spLoc Maybe BufSpan
_)) HsDecl GhcPs
decl :: LHsDecl GhcPs)
                        | SrcSpan -> Bool
spanIsRelevant SrcSpan
l ->
                            case HsDecl GhcPs
decl of
                                SpliceD {} -> forall r. r -> SearchResult r
Here (RealSrcSpan
spLoc, SpliceContext
HsDecl)
                                HsDecl GhcPs
_          -> forall r. SearchResult r
Continue
                    GenLocated SrcSpanAnnA (HsDecl GhcPs)
_ -> forall r. SearchResult r
Stop

-- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received,
--   and picks innermost result.
something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a)
something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a)
something' GenericQ (SearchResult a)
f =  GenericQ (Maybe a)
go
    where
        go :: GenericQ (Maybe a)
        go :: GenericQ (Maybe a)
go a
x =
            case GenericQ (SearchResult a)
f a
x of
              SearchResult a
Stop -> forall a. Maybe a
Nothing
              SearchResult a
resl -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)) (forall a. SearchResult a -> Maybe a
fromSearchResult SearchResult a
resl) (forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ GenericQ (Maybe a)
go a
x)