{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS -Wno-orphans #-}
{-# LANGUAGE TupleSections #-}
module Ide.Plugin.Retrie (descriptor) where
import Control.Concurrent.STM (readTVarIO)
import Control.Exception.Safe (Exception (..),
SomeException, assert,
catch, throwIO, try)
import Control.Monad (forM, unless, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Except (ExceptT (ExceptT),
runExceptT, throwE)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Writer.Strict
import Data.Aeson (FromJSON (..),
ToJSON (..),
Value (Null))
import Data.Bifunctor (second)
import qualified Data.ByteString as BS
import Data.Coerce
import Data.Data
import Data.Either (partitionEithers)
import Data.Hashable (Hashable (hash),
unhashed)
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as Set
import Data.IORef.Extra (atomicModifyIORef'_,
newIORef, readIORef)
import Data.List.Extra (find, nubOrdOn)
import Data.Maybe (catMaybes, fromJust,
listToMaybe)
import Data.String (IsString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import Debug.Trace
import Development.IDE hiding (pluginHandlers)
import Development.IDE.Core.PositionMapping
import Development.IDE.Core.Shake (ShakeExtras (ShakeExtras, knownTargetsVar),
clientCapabilities,
getShakeExtras,
hiedbWriter,
toKnownFiles, withHieDb)
import Development.IDE.GHC.Compat (GRHSs (GRHSs),
GenLocated (L), GhcPs,
GhcRn, GhcTc,
HsBindLR (FunBind),
HsExpr (HsApp, OpApp),
HsGroup (..),
HsValBindsLR (..),
HscEnv, IdP,
ImportDecl (..), LHsExpr,
LRuleDecls, Match,
ModIface,
ModSummary (ModSummary, ms_hspp_buf, ms_mod),
Name, Outputable,
ParsedModule (..),
RealSrcLoc,
RuleDecl (HsRule),
RuleDecls (HsRules),
SourceText (..),
TyClDecl (SynDecl),
TyClGroup (..), fun_id,
hm_iface, isQual,
isQual_maybe, isVarOcc,
locA, mi_fixities,
moduleName,
moduleNameString,
ms_hspp_opts,
nameModule_maybe,
nameOccName, nameRdrName,
noLocA, occNameFS,
occNameString,
pattern IsBoot,
pattern NotBoot,
pattern RealSrcSpan,
pm_parsed_source,
printWithoutUniques,
rdrNameOcc, rds_rules,
srcSpanFile, topDir,
unLoc, unLocA)
import qualified Development.IDE.GHC.Compat as GHC
import Development.IDE.GHC.Compat.Util hiding (catch, try)
import Development.IDE.GHC.Dump (showAstDataHtml)
import Development.IDE.GHC.ExactPrint (ExceptStringT (ExceptStringT),
GetAnnotatedParsedSource (GetAnnotatedParsedSource),
TransformT,
graftExprWithM,
graftSmallestDeclsWithM,
hoistGraft, transformM)
import qualified GHC (Module, ParsedSource,
moduleName, parseModule)
import qualified GHC as GHCGHC
import GHC.Generics (Generic)
import GHC.Hs.Dump
import Ide.PluginUtils
import Ide.Types
import Language.LSP.Server (LspM,
ProgressCancellable (Cancellable),
sendNotification,
sendRequest,
withIndefiniteProgress)
import Language.LSP.Types as J hiding
(SemanticTokenAbsolute (length, line),
SemanticTokenRelative (length),
SemanticTokensEdit (_start))
import Retrie (Annotated (astA),
AnnotatedModule,
Fixity (Fixity),
FixityDirection (InfixL),
Options, Options_ (..),
RewriteSpec,
Verbosity (Loud),
addImports, apply,
applyWithUpdate)
import Retrie.Context
import Retrie.CPP (CPP (NoCPP), parseCPP)
import Retrie.ExactPrint (Annotated, fix,
transformA, unsafeMkA)
import Retrie.Expr (mkLocatedHsVar)
import Retrie.Fixity (FixityEnv, lookupOp,
mkFixityEnv)
import Retrie.Monad (getGroundTerms,
runRetrie)
import Retrie.Options (defaultOptions,
getTargetFiles)
import Retrie.Replace (Change (..),
Replacement (..))
import Retrie.Rewrites
import Retrie.Rewrites.Function (matchToRewrites)
import Retrie.SYB (everything, extQ,
listify, mkQ)
import Retrie.Types
import Retrie.Universe (Universe)
import System.Directory (makeAbsolute)
#if MIN_VERSION_ghc(9,3,0)
import GHC.Types.PkgQual
#endif
#if MIN_VERSION_ghc(9,2,0)
import Control.Exception (evaluate)
import Data.Monoid (First (First))
import Retrie.ExactPrint (makeDeltaAst)
import Retrie.GHC (ann)
#else
import Data.Monoid (First (..))
import qualified GHC.Exts as Ext
import Retrie.AlphaEnv (extendAlphaEnv)
import Retrie.ExactPrint (relativiseApiAnns)
#endif
import Control.Arrow ((&&&))
import Development.IDE.Core.Actions (lookupMod)
import Development.IDE.Spans.AtPoint (LookupModule,
getNamesAtPoint,
nameToLocation)
import Development.IDE.Types.Shake (WithHieDb)
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId =
(forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
provider,
pluginCommands :: [PluginCommand IdeState]
pluginCommands = [PluginCommand IdeState
retrieCommand, PluginCommand IdeState
retrieInlineThisCommand]
}
retrieCommandName :: T.Text
retrieCommandName :: Text
retrieCommandName = Text
"retrieCommand"
retrieInlineThisCommandName :: T.Text
retrieInlineThisCommandName :: Text
retrieInlineThisCommandName = Text
"retrieInlineThisCommand"
retrieCommand :: PluginCommand IdeState
retrieCommand :: PluginCommand IdeState
retrieCommand =
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand (coerce :: forall a b. Coercible a b => a -> b
coerce Text
retrieCommandName) Text
"run the refactoring" forall c.
IdeState -> RunRetrieParams -> LspM c (Either ResponseError Value)
runRetrieCmd
retrieInlineThisCommand :: PluginCommand IdeState
retrieInlineThisCommand :: PluginCommand IdeState
retrieInlineThisCommand =
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand (coerce :: forall a b. Coercible a b => a -> b
coerce Text
retrieInlineThisCommandName) Text
"inline function call"
forall c.
IdeState
-> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value)
runRetrieInlineThisCmd
data RunRetrieParams = RunRetrieParams
{ RunRetrieParams -> Text
description :: T.Text,
RunRetrieParams -> [RewriteSpec]
rewrites :: [RewriteSpec],
RunRetrieParams -> Uri
originatingFile :: Uri,
RunRetrieParams -> Bool
restrictToOriginatingFile :: Bool
}
deriving (RunRetrieParams -> RunRetrieParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunRetrieParams -> RunRetrieParams -> Bool
$c/= :: RunRetrieParams -> RunRetrieParams -> Bool
== :: RunRetrieParams -> RunRetrieParams -> Bool
$c== :: RunRetrieParams -> RunRetrieParams -> Bool
Eq, Int -> RunRetrieParams -> ShowS
[RunRetrieParams] -> ShowS
RunRetrieParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunRetrieParams] -> ShowS
$cshowList :: [RunRetrieParams] -> ShowS
show :: RunRetrieParams -> String
$cshow :: RunRetrieParams -> String
showsPrec :: Int -> RunRetrieParams -> ShowS
$cshowsPrec :: Int -> RunRetrieParams -> ShowS
Show, forall x. Rep RunRetrieParams x -> RunRetrieParams
forall x. RunRetrieParams -> Rep RunRetrieParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RunRetrieParams x -> RunRetrieParams
$cfrom :: forall x. RunRetrieParams -> Rep RunRetrieParams x
Generic, Value -> Parser [RunRetrieParams]
Value -> Parser RunRetrieParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RunRetrieParams]
$cparseJSONList :: Value -> Parser [RunRetrieParams]
parseJSON :: Value -> Parser RunRetrieParams
$cparseJSON :: Value -> Parser RunRetrieParams
FromJSON, [RunRetrieParams] -> Encoding
[RunRetrieParams] -> Value
RunRetrieParams -> Encoding
RunRetrieParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RunRetrieParams] -> Encoding
$ctoEncodingList :: [RunRetrieParams] -> Encoding
toJSONList :: [RunRetrieParams] -> Value
$ctoJSONList :: [RunRetrieParams] -> Value
toEncoding :: RunRetrieParams -> Encoding
$ctoEncoding :: RunRetrieParams -> Encoding
toJSON :: RunRetrieParams -> Value
$ctoJSON :: RunRetrieParams -> Value
ToJSON)
runRetrieCmd ::
IdeState ->
RunRetrieParams ->
LspM c (Either ResponseError Value)
runRetrieCmd :: forall c.
IdeState -> RunRetrieParams -> LspM c (Either ResponseError Value)
runRetrieCmd IdeState
state RunRetrieParams{originatingFile :: RunRetrieParams -> Uri
originatingFile = Uri
uri, Bool
[RewriteSpec]
Text
restrictToOriginatingFile :: Bool
rewrites :: [RewriteSpec]
description :: Text
restrictToOriginatingFile :: RunRetrieParams -> Bool
rewrites :: RunRetrieParams -> [RewriteSpec]
description :: RunRetrieParams -> Text
..} =
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
description ProgressCancellable
Cancellable forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
NormalizedFilePath
nfp <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
(HscEnvEq
session, PositionMapping
_) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ 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
"Retrie.GhcSessionDeps" IdeState
state forall a b. (a -> b) -> a -> b
$
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GhcSessionDeps
GhcSessionDeps
NormalizedFilePath
nfp
(ModSummary
ms, [HsBindLR GhcRn GhcRn]
binds, PositionMapping
_, [GenLocated SrcSpanAnnA (RuleDecls GhcRn)]
_, [TyClGroup GhcRn]
_) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ 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
"Retrie.getBinds" IdeState
state forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> Action
(Maybe
(ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
[LRuleDecls GhcRn], [TyClGroup GhcRn]))
getBinds NormalizedFilePath
nfp
let importRewrites :: [ImportSpec]
importRewrites = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]
extractImports ModSummary
ms [HsBindLR GhcRn GhcRn]
binds) [RewriteSpec]
rewrites
([CallRetrieError]
errors, WorkspaceEdit
edits) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
IdeState
-> HscEnv
-> [Either ImportSpec RewriteSpec]
-> NormalizedFilePath
-> Bool
-> IO ([CallRetrieError], WorkspaceEdit)
callRetrie
IdeState
state
(HscEnvEq -> HscEnv
hscEnv HscEnvEq
session)
(forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [RewriteSpec]
rewrites forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [ImportSpec]
importRewrites)
NormalizedFilePath
nfp
Bool
restrictToOriginatingFile
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CallRetrieError]
errors) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SMethod 'WindowShowMessage
SWindowShowMessage forall a b. (a -> b) -> a -> b
$
MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
MtWarning forall a b. (a -> b) -> a -> b
$
[Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
Text
"## Found errors during rewrite:" forall a. a -> [a] -> [a]
:
[Text
"-" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show CallRetrieError
e) | CallRetrieError
e <- [CallRetrieError]
errors]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edits) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null
data RunRetrieInlineThisParams = RunRetrieInlineThisParams
{ RunRetrieInlineThisParams -> Location
inlineIntoThisLocation :: !Location,
RunRetrieInlineThisParams -> Location
inlineFromThisLocation :: !Location,
RunRetrieInlineThisParams -> Text
inlineThisDefinition :: !T.Text
}
deriving (RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
$c/= :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
== :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
$c== :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
Eq, Int -> RunRetrieInlineThisParams -> ShowS
[RunRetrieInlineThisParams] -> ShowS
RunRetrieInlineThisParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunRetrieInlineThisParams] -> ShowS
$cshowList :: [RunRetrieInlineThisParams] -> ShowS
show :: RunRetrieInlineThisParams -> String
$cshow :: RunRetrieInlineThisParams -> String
showsPrec :: Int -> RunRetrieInlineThisParams -> ShowS
$cshowsPrec :: Int -> RunRetrieInlineThisParams -> ShowS
Show, forall x.
Rep RunRetrieInlineThisParams x -> RunRetrieInlineThisParams
forall x.
RunRetrieInlineThisParams -> Rep RunRetrieInlineThisParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep RunRetrieInlineThisParams x -> RunRetrieInlineThisParams
$cfrom :: forall x.
RunRetrieInlineThisParams -> Rep RunRetrieInlineThisParams x
Generic, Value -> Parser [RunRetrieInlineThisParams]
Value -> Parser RunRetrieInlineThisParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RunRetrieInlineThisParams]
$cparseJSONList :: Value -> Parser [RunRetrieInlineThisParams]
parseJSON :: Value -> Parser RunRetrieInlineThisParams
$cparseJSON :: Value -> Parser RunRetrieInlineThisParams
FromJSON, [RunRetrieInlineThisParams] -> Encoding
[RunRetrieInlineThisParams] -> Value
RunRetrieInlineThisParams -> Encoding
RunRetrieInlineThisParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RunRetrieInlineThisParams] -> Encoding
$ctoEncodingList :: [RunRetrieInlineThisParams] -> Encoding
toJSONList :: [RunRetrieInlineThisParams] -> Value
$ctoJSONList :: [RunRetrieInlineThisParams] -> Value
toEncoding :: RunRetrieInlineThisParams -> Encoding
$ctoEncoding :: RunRetrieInlineThisParams -> Encoding
toJSON :: RunRetrieInlineThisParams -> Value
$ctoJSON :: RunRetrieInlineThisParams -> Value
ToJSON)
runRetrieInlineThisCmd :: IdeState
-> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value)
runRetrieInlineThisCmd :: forall c.
IdeState
-> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value)
runRetrieInlineThisCmd IdeState
state RunRetrieInlineThisParams{Text
Location
inlineThisDefinition :: Text
inlineFromThisLocation :: Location
inlineIntoThisLocation :: Location
inlineThisDefinition :: RunRetrieInlineThisParams -> Text
inlineFromThisLocation :: RunRetrieInlineThisParams -> Location
inlineIntoThisLocation :: RunRetrieInlineThisParams -> Location
..} = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
NormalizedFilePath
nfp <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"uri" forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri forall a b. (a -> b) -> a -> b
$ Location -> Uri
getLocationUri Location
inlineIntoThisLocation
NormalizedFilePath
nfpSource <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"sourceUri" forall a b. (a -> b) -> a -> b
$
NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri forall a b. (a -> b) -> a -> b
$ Location -> Uri
getLocationUri Location
inlineFromThisLocation
Annotated ParsedSource
ast <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"ast" forall a b. (a -> b) -> a -> b
$ 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
"retrie" IdeState
state forall a b. (a -> b) -> a -> b
$
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetAnnotatedParsedSource
GetAnnotatedParsedSource NormalizedFilePath
nfp
Annotated ParsedSource
astSrc <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"ast" forall a b. (a -> b) -> a -> b
$ 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
"retrie" IdeState
state forall a b. (a -> b) -> a -> b
$
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetAnnotatedParsedSource
GetAnnotatedParsedSource NormalizedFilePath
nfpSource
ModSummaryResult
msr <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"modSummary" forall a b. (a -> b) -> a -> b
$ 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
"retrie" IdeState
state forall a b. (a -> b) -> a -> b
$
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
nfp
HiFileResult
hiFileRes <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"modIface" forall a b. (a -> b) -> a -> b
$ 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
"retrie" IdeState
state forall a b. (a -> b) -> a -> b
$
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModIface
GetModIface NormalizedFilePath
nfpSource
let fixityEnv :: FixityEnv
fixityEnv = ModIface -> FixityEnv
fixityEnvFromModIface (HiFileResult -> ModIface
hirModIface HiFileResult
hiFileRes)
fromRange :: RealSrcSpan
fromRange = NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan NormalizedFilePath
nfpSource forall a b. (a -> b) -> a -> b
$ Location -> Range
getLocationRange Location
inlineFromThisLocation
intoRange :: RealSrcSpan
intoRange = NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan NormalizedFilePath
nfp forall a b. (a -> b) -> a -> b
$ Location -> Range
getLocationRange Location
inlineIntoThisLocation
[Rewrite Universe]
inlineRewrite <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {a} {l}.
Data a =>
Annotated (GenLocated l a) -> RealSrcSpan -> IO [Rewrite Universe]
constructInlineFromIdentifer Annotated ParsedSource
astSrc RealSrcSpan
fromRange
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Rewrite Universe]
inlineRewrite) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Empty rewrite"
let ShakeExtras{TVar (Hashed KnownTargets)
HieDbWriter
ClientCapabilities
WithHieDb
hiedbWriter :: HieDbWriter
withHieDb :: WithHieDb
clientCapabilities :: ClientCapabilities
knownTargetsVar :: TVar (Hashed KnownTargets)
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
$sel:clientCapabilities:ShakeExtras :: ShakeExtras -> ClientCapabilities
$sel:knownTargetsVar:ShakeExtras :: ShakeExtras -> TVar (Hashed KnownTargets)
..}= IdeState -> ShakeExtras
shakeExtras IdeState
state
(HscEnvEq
session, PositionMapping
_) <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"GHCSession" forall a b. (a -> b) -> a -> b
$ 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
"retrie" IdeState
state forall a b. (a -> b) -> a -> b
$
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
(FixityEnv
fixityEnv, CPP (Annotated ParsedSource)
cpp) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IdeState
-> HscEnv -> String -> IO (FixityEnv, CPP (Annotated ParsedSource))
getCPPmodule IdeState
state (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
Either SomeException ((), CPP (Annotated ParsedSource), Change)
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$
forall a.
FixityEnv
-> Retrie a
-> CPP (Annotated ParsedSource)
-> IO (a, CPP (Annotated ParsedSource), Change)
runRetrie FixityEnv
fixityEnv (ContextUpdater -> [Rewrite Universe] -> Retrie ()
applyWithUpdate ContextUpdater
myContextUpdater [Rewrite Universe]
inlineRewrite) CPP (Annotated ParsedSource)
cpp
case Either SomeException ((), CPP (Annotated ParsedSource), Change)
result of
Left SomeException
err -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ String
"Retrie - crashed with: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
err
Right (()
_,CPP (Annotated ParsedSource)
_,Change
NoChange) -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Retrie - inline produced no changes"
Right (()
_,CPP (Annotated ParsedSource)
_,Change [Replacement]
replacements [AnnotatedImports]
imports) -> do
let edits :: WorkspaceEditMap
edits = [(Uri, TextEdit)] -> WorkspaceEditMap
asEditMap forall a b. (a -> b) -> a -> b
$ Change -> [(Uri, TextEdit)]
asTextEdits forall a b. (a -> b) -> a -> b
$ [Replacement] -> [AnnotatedImports] -> Change
Change [Replacement]
ourReplacement [AnnotatedImports]
imports
wedit :: WorkspaceEdit
wedit = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just WorkspaceEditMap
edits) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
ourReplacement :: [Replacement]
ourReplacement = [ Replacement
r
| r :: Replacement
r@Replacement{String
SrcSpan
replLocation :: Replacement -> SrcSpan
replOriginal :: Replacement -> String
replReplacement :: Replacement -> String
replReplacement :: String
replOriginal :: String
replLocation :: SrcSpan
..} <- [Replacement]
replacements
, RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
intoRange forall a. Maybe a
Nothing SrcSpan -> SrcSpan -> Bool
`GHC.isSubspanOf` SrcSpan
replLocation]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit
(Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
myContextUpdater :: ContextUpdater
myContextUpdater :: ContextUpdater
myContextUpdater Context
c Int
i =
ContextUpdater
updateContext Context
c Int
i
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> Context
updExp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a (m :: * -> *). Monad m => a -> TransformT m Context
skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs)))
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall a (m :: * -> *). Monad m => a -> TransformT m Context
skipUpdate @(Match GhcPs (LHsExpr GhcPs)))
where
skipUpdate :: forall a m . Monad m => a -> TransformT m Context
skipUpdate :: forall a (m :: * -> *). Monad m => a -> TransformT m Context
skipUpdate a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Context
c
updExp :: HsExpr GhcPs -> Context
updExp :: HsExpr GhcPs -> Context
updExp HsApp{} =
Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = Fixity -> ParentPrec
HasPrec forall a b. (a -> b) -> a -> b
$ SourceText -> Int -> FixityDirection -> Fixity
Retrie.Fixity (String -> SourceText
SourceText String
"HsApp") (Int
10 forall a. Num a => a -> a -> a
+ Int
i forall a. Num a => a -> a -> a
- Int
firstChild) FixityDirection
InfixL }
updExp (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
op LHsExpr GhcPs
_) = Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = Fixity -> ParentPrec
HasPrec forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> FixityEnv -> Fixity
lookupOp LHsExpr GhcPs
op (Context -> FixityEnv
ctxtFixityEnv Context
c) }
updExp HsExpr GhcPs
_ = Context
c { ctxtParentPrec :: ParentPrec
ctxtParentPrec = ParentPrec
NeverParen }
firstChild :: Int
firstChild :: Int
firstChild = Int
1
extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]
ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod} [HsBindLR GhcRn GhcRn]
topLevelBinds (Unfold String
thing)
| Just FunBind {MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches}
<- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\case FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
n} -> Text -> String
T.unpack (forall a. Outputable a => a -> Text
printOutputable Name
n) forall a. Eq a => a -> a -> Bool
== String
thing ; HsBindLR GhcRn GhcRn
_ -> Bool
False) [HsBindLR GhcRn GhcRn]
topLevelBinds
, [Name]
names <- forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify Name -> Bool
p MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches
=
[ AddImport {Bool
String
Maybe String
Maybe (IE String)
ideclThing :: Maybe (IE String)
ideclAsString :: Maybe String
ideclQualifiedBool :: Bool
ideclSource :: Bool
ideclNameString :: String
ideclNameString :: String
ideclThing :: Maybe (IE String)
ideclAsString :: Maybe String
ideclQualifiedBool :: Bool
ideclSource :: Bool
..}
| let ideclSource :: Bool
ideclSource = Bool
False,
Name
name <- [Name]
names,
let r :: RdrName
r = Name -> RdrName
nameRdrName Name
name,
let ideclQualifiedBool :: Bool
ideclQualifiedBool = RdrName -> Bool
isQual RdrName
r,
let ideclAsString :: Maybe String
ideclAsString = ModuleName -> String
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RdrName -> Maybe (ModuleName, OccName)
isQual_maybe RdrName
r,
let ideclThing :: Maybe (IE String)
ideclThing = forall a. a -> Maybe a
Just (forall name. name -> IE name
IEVar forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
r),
Just String
ideclNameString <-
[ModuleName -> String
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe Module
nameModule_maybe Name
name]
]
where
p :: Name -> Bool
p Name
name = Name -> Maybe Module
nameModule_maybe Name
name forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Module
ms_mod
extractImports ModSummary
_ [HsBindLR GhcRn GhcRn]
_ RewriteSpec
_ = []
provider :: PluginMethodHandler IdeState TextDocumentCodeAction
provider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
provider IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ (TextDocumentIdentifier Uri
uri) Range
range CodeActionContext
ca) = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
let (J.CodeActionContext List Diagnostic
_diags Maybe (List CodeActionKind)
_monly) = CodeActionContext
ca
nuri :: NormalizedUri
nuri = Uri -> NormalizedUri
toNormalizedUri Uri
uri
NormalizedFilePath
nfp <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"uri" forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath NormalizedUri
nuri
(ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod}, [HsBindLR GhcRn GhcRn]
topLevelBinds, PositionMapping
posMapping, [GenLocated SrcSpanAnnA (RuleDecls GhcRn)]
hs_ruleds, [TyClGroup GhcRn]
hs_tyclds)
<- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"typecheck" forall a b. (a -> b) -> a -> b
$ 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
"retrie" IdeState
state forall a b. (a -> b) -> a -> b
$
NormalizedFilePath
-> Action
(Maybe
(ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
[LRuleDecls GhcRn], [TyClGroup GhcRn]))
getBinds NormalizedFilePath
nfp
extras :: ShakeExtras
extras@ShakeExtras{ WithHieDb
withHieDb :: WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb, HieDbWriter
hiedbWriter :: HieDbWriter
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
hiedbWriter } <- 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
"" IdeState
state Action ShakeExtras
getShakeExtras
Range
range <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"range" forall a b. (a -> b) -> a -> b
$ PositionMapping -> Range -> Maybe Range
fromCurrentRange PositionMapping
posMapping Range
range
let pos :: Position
pos = Range -> Position
_start Range
range
let rewrites :: [(Text, CodeActionKind, RunRetrieParams)]
rewrites =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Uri
-> Position
-> Module
-> HsBindLR GhcRn GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestBindRewrites Uri
uri Position
pos Module
ms_mod) [HsBindLR GhcRn GhcRn]
topLevelBinds
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Uri
-> Position
-> Module
-> LRuleDecls GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestRuleRewrites Uri
uri Position
pos Module
ms_mod) [GenLocated SrcSpanAnnA (RuleDecls GhcRn)]
hs_ruleds
forall a. [a] -> [a] -> [a]
++ [ (Text, CodeActionKind, RunRetrieParams)
r
| TyClGroup {[LTyClDecl GhcRn]
group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds :: [LTyClDecl GhcRn]
group_tyclds} <- [TyClGroup GhcRn]
hs_tyclds,
L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
l) TyClDecl GhcRn
g <- [LTyClDecl GhcRn]
group_tyclds,
Position
pos Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
l,
(Text, CodeActionKind, RunRetrieParams)
r <- Outputable (IdP GhcRn) =>
Uri
-> Module
-> TyClDecl GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites Uri
uri Module
ms_mod TyClDecl GhcRn
g
]
[CodeAction]
retrieCommands <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, CodeActionKind, RunRetrieParams)]
rewrites forall a b. (a -> b) -> a -> b
$ \(Text
title, CodeActionKind
kind, RunRetrieParams
params) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let c :: Command
c = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId (coerce :: forall a b. Coercible a b => a -> b
coerce Text
retrieCommandName) Text
title (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON RunRetrieParams
params])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
CodeAction Text
title (forall a. a -> Maybe a
Just CodeActionKind
kind) 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
c) forall a. Maybe a
Nothing
[Command]
inlineSuggestions <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"" ShakeExtras
extras forall a b. (a -> b) -> a -> b
$
PluginId
-> Uri
-> [HsBindLR GhcRn GhcRn]
-> Range
-> WithHieDb
-> LookupModule IdeAction
-> IdeAction [Command]
suggestBindInlines PluginId
plId Uri
uri [HsBindLR GhcRn GhcRn]
topLevelBinds Range
range WithHieDb
withHieDb (HieDbWriter -> LookupModule IdeAction
lookupMod HieDbWriter
hiedbWriter)
let inlineCommands :: [Maybe CodeAction]
inlineCommands =
[ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
CodeAction Text
_title (forall a. a -> Maybe a
Just CodeActionKind
CodeActionRefactorInline) 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
c) forall a. Maybe a
Nothing
| c :: Command
c@Command{Maybe (List Value)
Text
$sel:_title:Command :: Command -> Text
$sel:_command:Command :: Command -> Text
$sel:_arguments:Command :: Command -> Maybe (List Value)
_arguments :: Maybe (List Value)
_command :: Text
_title :: Text
..} <- [Command]
inlineSuggestions
]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
J.List [forall a b. b -> a |? b
InR CodeAction
c | CodeAction
c <- [CodeAction]
retrieCommands forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe CodeAction]
inlineCommands]
getLocationUri :: Location -> Uri
getLocationUri :: Location -> Uri
getLocationUri Location{Uri
_uri :: Location -> Uri
_uri :: Uri
_uri} = Uri
_uri
getLocationRange :: Location -> Range
getLocationRange Location{Range
_range :: Location -> Range
_range :: Range
_range} = Range
_range
getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn]))
getBinds :: NormalizedFilePath
-> Action
(Maybe
(ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
[LRuleDecls GhcRn], [TyClGroup GhcRn]))
getBinds NormalizedFilePath
nfp = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
(TcModuleResult
tm, PositionMapping
posMapping) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale TypeCheck
TypeCheck NormalizedFilePath
nfp
let rn :: RenamedSource
rn = TcModuleResult -> RenamedSource
tmrRenamed TcModuleResult
tm
( HsGroup
{ hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds =
XValBindsLR
(GHC.NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
_sigs :: GHC.NHsValBindsLR GhcRn),
[LRuleDecls GhcRn]
hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds :: [LRuleDecls GhcRn]
hs_ruleds,
[TyClGroup GhcRn]
hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds
},
[LImportDecl GhcRn]
_,
Maybe [(LIE GhcRn, Avails)]
_,
Maybe LHsDocString
_
) = RenamedSource
rn
topLevelBinds :: [HsBindLR GhcRn GhcRn]
topLevelBinds =
[ HsBindLR GhcRn GhcRn
decl
| (RecFlag
_, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
bagBinds) <- [(RecFlag, LHsBinds GhcRn)]
binds,
L SrcSpanAnnA
_ HsBindLR GhcRn GhcRn
decl <- forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
bagBinds
]
forall (m :: * -> *) a. Monad m => a -> m a
return (TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tm, [HsBindLR GhcRn GhcRn]
topLevelBinds, PositionMapping
posMapping, [LRuleDecls GhcRn]
hs_ruleds, [TyClGroup GhcRn]
hs_tyclds)
suggestBindRewrites ::
Uri ->
Position ->
GHC.Module ->
HsBindLR GhcRn GhcRn ->
[(T.Text, CodeActionKind, RunRetrieParams)]
suggestBindRewrites :: Uri
-> Position
-> Module
-> HsBindLR GhcRn GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestBindRewrites Uri
originatingFile Position
pos Module
ms_mod FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
l') Name
rdrName}
| Position
pos Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
l' =
let pprNameText :: Text
pprNameText = forall a. Outputable a => a -> Text
printOutputable Name
rdrName
pprName :: String
pprName = Text -> String
T.unpack Text
pprNameText
unfoldRewrite :: Bool -> (Text, CodeActionKind, RunRetrieParams)
unfoldRewrite Bool
restrictToOriginatingFile =
let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
Unfold (forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
description :: Text
description = Text
"Unfold " forall a. Semigroup a => a -> a -> a
<> Text
pprNameText forall a. Semigroup a => a -> a -> a
<> forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
in (Text
description, CodeActionKind
CodeActionRefactorInline, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
rewrites :: [RewriteSpec]
description :: Text
..})
foldRewrite :: Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
restrictToOriginatingFile =
let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
Fold (forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
description :: Text
description = Text
"Fold " forall a. Semigroup a => a -> a -> a
<> Text
pprNameText forall a. Semigroup a => a -> a -> a
<> forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
in (Text
description, CodeActionKind
CodeActionRefactorExtract, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
rewrites :: [RewriteSpec]
description :: Text
..})
in [Bool -> (Text, CodeActionKind, RunRetrieParams)
unfoldRewrite Bool
False, Bool -> (Text, CodeActionKind, RunRetrieParams)
unfoldRewrite Bool
True, Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
False, Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
True]
suggestBindRewrites Uri
_ Position
_ Module
_ HsBindLR GhcRn GhcRn
_ = []
suggestBindInlines :: PluginId -> Uri -> [HsBindLR GhcRn GhcRn] -> Range -> WithHieDb -> _ -> IdeAction [Command]
suggestBindInlines :: PluginId
-> Uri
-> [HsBindLR GhcRn GhcRn]
-> Range
-> WithHieDb
-> LookupModule IdeAction
-> IdeAction [Command]
suggestBindInlines PluginId
plId Uri
uri [HsBindLR GhcRn GhcRn]
binds Range
range WithHieDb
hie LookupModule IdeAction
lookupMod = do
HashSet (OccName, Location, Location)
identifiers <- IdeAction (HashSet (OccName, Location, Location))
definedIdentifiers
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(OccName
name, Location
siteLoc, Location
srcLoc) ->
let
title :: Text
title = Text
"Inline " forall a. Semigroup a => a -> a -> a
<> Text
printedName
printedName :: Text
printedName = forall a. Outputable a => a -> Text
printOutputable OccName
name
params :: RunRetrieInlineThisParams
params = RunRetrieInlineThisParams
{ inlineIntoThisLocation :: Location
inlineIntoThisLocation = Location
siteLoc
, inlineFromThisLocation :: Location
inlineFromThisLocation = Location
srcLoc
, inlineThisDefinition :: Text
inlineThisDefinition= Text
printedName
}
in PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId (coerce :: forall a b. Coercible a b => a -> b
coerce Text
retrieInlineThisCommandName) Text
title (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON RunRetrieInlineThisParams
params])
)
(forall a. HashSet a -> [a]
Set.toList HashSet (OccName, Location, Location)
identifiers)
where
definedIdentifiers :: IdeAction (HashSet (OccName, Location, Location))
definedIdentifiers =
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything forall a. Semigroup a => a -> a -> a
(<>) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` WithHieDb
-> LookupModule IdeAction
-> GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> IdeAction (HashSet (OccName, Location, Location))
getGRHSIdentifierDetails WithHieDb
hie LookupModule IdeAction
lookupMod) [HsBindLR GhcRn GhcRn]
binds
getGRHSIdentifierDetails :: WithHieDb -> _ -> GRHSs GhcRn (LHsExpr GhcRn) -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))
getGRHSIdentifierDetails :: WithHieDb
-> LookupModule IdeAction
-> GRHSs GhcRn (LHsExpr GhcRn)
-> IdeAction (HashSet (OccName, Location, Location))
getGRHSIdentifierDetails WithHieDb
a LookupModule IdeAction
b it :: GRHSs GhcRn (LHsExpr GhcRn)
it@GRHSs{} =
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything forall a. Semigroup a => a -> a -> a
(<>) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` WithHieDb
-> LookupModule IdeAction
-> LIdP GhcRn
-> IdeAction (HashSet (OccName, Location, Location))
getDefinedIdentifierDetailsViaHieDb WithHieDb
a LookupModule IdeAction
b) GRHSs GhcRn (LHsExpr GhcRn)
it
getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))
getDefinedIdentifierDetailsViaHieDb :: WithHieDb
-> LookupModule IdeAction
-> LIdP GhcRn
-> IdeAction (HashSet (OccName, Location, Location))
getDefinedIdentifierDetailsViaHieDb WithHieDb
withHieDb LookupModule IdeAction
lookupModule LIdP GhcRn
lname | Name
name <- forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
lname =
case SrcSpan -> Maybe Location
srcSpanToLocation (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LIdP GhcRn
lname) of
Just Location
siteLoc
| Range
siteRange <- Location -> Range
getLocationRange Location
siteLoc
, Range
range Range -> Range -> Bool
`isSubrangeOf` Range
siteRange -> do
Maybe [Location]
mbSrcLocation <- forall (m :: * -> *).
MonadIO m =>
WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation WithHieDb
withHieDb LookupModule IdeAction
lookupModule Name
name
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Name -> OccName
nameOccName Name
name, Location
siteLoc,)) Maybe [Location]
mbSrcLocation
Maybe Location
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
describeRestriction :: IsString p => Bool -> p
describeRestriction :: forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile =
if Bool
restrictToOriginatingFile then p
" in current file" else p
""
suggestTypeRewrites ::
(Outputable (IdP GhcRn)) =>
Uri ->
GHC.Module ->
TyClDecl GhcRn ->
[(T.Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites :: Outputable (IdP GhcRn) =>
Uri
-> Module
-> TyClDecl GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites Uri
originatingFile Module
ms_mod SynDecl {LIdP GhcRn
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName :: LIdP GhcRn
tcdLName} =
let pprNameText :: Text
pprNameText = forall a. Outputable a => a -> Text
printOutputable (forall (pass :: Pass) a. XRec (GhcPass pass) a -> a
unLocA LIdP GhcRn
tcdLName)
pprName :: String
pprName = Text -> String
T.unpack Text
pprNameText
unfoldRewrite :: Bool -> (Text, CodeActionKind, RunRetrieParams)
unfoldRewrite Bool
restrictToOriginatingFile =
let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
TypeForward (forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
description :: Text
description = Text
"Unfold " forall a. Semigroup a => a -> a -> a
<> Text
pprNameText forall a. Semigroup a => a -> a -> a
<> forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
in (Text
description, CodeActionKind
CodeActionRefactorInline, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
rewrites :: [RewriteSpec]
description :: Text
..})
foldRewrite :: Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
restrictToOriginatingFile =
let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
TypeBackward (forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
description :: Text
description = Text
"Fold " forall a. Semigroup a => a -> a -> a
<> Text
pprNameText forall a. Semigroup a => a -> a -> a
<> forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
in (Text
description, CodeActionKind
CodeActionRefactorExtract, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
rewrites :: [RewriteSpec]
description :: Text
..})
in [Bool -> (Text, CodeActionKind, RunRetrieParams)
unfoldRewrite Bool
False, Bool -> (Text, CodeActionKind, RunRetrieParams)
unfoldRewrite Bool
True, Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
False, Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
True]
suggestTypeRewrites Uri
_ Module
_ TyClDecl GhcRn
_ = []
suggestRuleRewrites ::
Uri ->
Position ->
GHC.Module ->
LRuleDecls GhcRn ->
[(T.Text, CodeActionKind, RunRetrieParams)]
suggestRuleRewrites :: Uri
-> Position
-> Module
-> LRuleDecls GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestRuleRewrites Uri
originatingFile Position
pos Module
ms_mod (L SrcSpanAnnA
_ HsRules {[LRuleDecl GhcRn]
rds_rules :: [LRuleDecl GhcRn]
rds_rules :: forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules}) =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
forwardRewrite String
ruleName Bool
True
, String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
forwardRewrite String
ruleName Bool
False
, String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
backwardsRewrite String
ruleName Bool
True
, String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
backwardsRewrite String
ruleName Bool
False
]
| L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
l) RuleDecl GhcRn
r <- [LRuleDecl GhcRn]
rds_rules,
Position
pos Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
l,
#if MIN_VERSION_ghc(9,5,0)
let HsRule {rd_name = L _ rn} = r,
#else
let HsRule {rd_name :: forall pass. RuleDecl pass -> XRec pass (SourceText, RuleName)
rd_name = L SrcSpan
_ (SourceText
_, RuleName
rn)} = RuleDecl GhcRn
r,
#endif
let ruleName :: String
ruleName = RuleName -> String
unpackFS RuleName
rn
]
where
forwardRewrite :: String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
forwardRewrite String
ruleName Bool
restrictToOriginatingFile =
let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
RuleForward (forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
ruleName)]
description :: Text
description = Text
"Apply rule " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
ruleName forall a. Semigroup a => a -> a -> a
<> Text
" forward" forall a. Semigroup a => a -> a -> a
<>
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
in ( Text
description,
CodeActionKind
CodeActionRefactor,
RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
rewrites :: [RewriteSpec]
description :: Text
..}
)
backwardsRewrite :: String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
backwardsRewrite String
ruleName Bool
restrictToOriginatingFile =
let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
RuleBackward (forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
ruleName)]
description :: Text
description = Text
"Apply rule " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
ruleName forall a. Semigroup a => a -> a -> a
<> Text
" backwards" forall a. Semigroup a => a -> a -> a
<>
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
in ( Text
description,
CodeActionKind
CodeActionRefactor,
RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
rewrites :: [RewriteSpec]
description :: Text
..}
)
qualify :: Outputable mod => mod -> String -> String
qualify :: forall mod. Outputable mod => mod -> ShowS
qualify mod
ms_mod String
x = Text -> String
T.unpack (forall a. Outputable a => a -> Text
printOutputable mod
ms_mod) forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> String
x
data CallRetrieError
= CallRetrieInternalError String NormalizedFilePath
| NoParse NormalizedFilePath
| GHCParseError NormalizedFilePath String
| NoTypeCheck NormalizedFilePath
deriving (CallRetrieError -> CallRetrieError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallRetrieError -> CallRetrieError -> Bool
$c/= :: CallRetrieError -> CallRetrieError -> Bool
== :: CallRetrieError -> CallRetrieError -> Bool
$c== :: CallRetrieError -> CallRetrieError -> Bool
Eq, Typeable)
instance Show CallRetrieError where
show :: CallRetrieError -> String
show (CallRetrieInternalError String
msg NormalizedFilePath
f) = String
msg forall a. Semigroup a => a -> a -> a
<> String
" - " forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f
show (NoParse NormalizedFilePath
f) = String
"Cannot parse: " forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f
show (GHCParseError NormalizedFilePath
f String
m) = String
"Cannot parse " forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f forall a. Semigroup a => a -> a -> a
<> String
" : " forall a. Semigroup a => a -> a -> a
<> String
m
show (NoTypeCheck NormalizedFilePath
f) = String
"File does not typecheck: " forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f
instance Exception CallRetrieError
callRetrie ::
IdeState ->
HscEnv ->
[Either ImportSpec RewriteSpec] ->
NormalizedFilePath ->
Bool ->
IO ([CallRetrieError], WorkspaceEdit)
callRetrie :: IdeState
-> HscEnv
-> [Either ImportSpec RewriteSpec]
-> NormalizedFilePath
-> Bool
-> IO ([CallRetrieError], WorkspaceEdit)
callRetrie IdeState
state HscEnv
session [Either ImportSpec RewriteSpec]
rewrites NormalizedFilePath
origin Bool
restrictToOriginatingFile = do
HashSet NormalizedFilePath
knownFiles <- KnownTargets -> HashSet NormalizedFilePath
toKnownFiles forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashed a -> a
unhashed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO (ShakeExtras -> TVar (Hashed KnownTargets)
knownTargetsVar forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
state)
let
target :: String
target = String
"."
retrieOptions :: Retrie.Options
retrieOptions :: Options
retrieOptions = (forall rewrites imports.
(Default rewrites, Default imports) =>
String -> Options_ rewrites imports
defaultOptions String
target)
{verbosity :: Verbosity
Retrie.verbosity = Verbosity
Loud
,targetFiles :: [String]
Retrie.targetFiles = forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> String
fromNormalizedFilePath forall a b. (a -> b) -> a -> b
$
if Bool
restrictToOriginatingFile
then [NormalizedFilePath
origin]
else forall a. HashSet a -> [a]
Set.toList HashSet NormalizedFilePath
knownFiles
}
([ImportSpec]
theImports, [RewriteSpec]
theRewrites) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ImportSpec RewriteSpec]
rewrites
annotatedImports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
annotatedImports =
#if MIN_VERSION_ghc(9,2,0)
forall ast. ast -> Int -> Annotated ast
unsafeMkA (forall a b. (a -> b) -> [a] -> [b]
map (forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportSpec -> ImportDecl GhcPs
toImportDecl) [ImportSpec]
theImports) Int
0
#else
unsafeMkA (map (noLocA . toImportDecl) theImports) mempty 0
#endif
(FixityEnv
originFixities, Annotated ParsedSource
originParsedModule) <- IdeState
-> NormalizedFilePath -> IO (FixityEnv, Annotated ParsedSource)
reuseParsedModule IdeState
state NormalizedFilePath
origin
Retrie ()
retrie <-
(\[Rewrite Universe]
specs -> [Rewrite Universe] -> Retrie ()
apply [Rewrite Universe]
specs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AnnotatedImports -> Retrie ()
addImports Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
annotatedImports)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdeState
-> NormalizedFilePath
-> Annotated ParsedSource
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite Universe]
parseSpecs IdeState
state NormalizedFilePath
origin Annotated ParsedSource
originParsedModule FixityEnv
originFixities [RewriteSpec]
theRewrites
[String]
targets <- forall a b. Options_ a b -> [GroundTerms] -> IO [String]
getTargetFiles Options
retrieOptions (forall a. Retrie a -> [GroundTerms]
getGroundTerms Retrie ()
retrie)
[Either CallRetrieError [(Uri, TextEdit)]]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
targets forall a b. (a -> b) -> a -> b
$ \String
t -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
(FixityEnv
fixityEnv, CPP (Annotated ParsedSource)
cpp) <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ IdeState
-> HscEnv -> String -> IO (FixityEnv, CPP (Annotated ParsedSource))
getCPPmodule IdeState
state HscEnv
session String
t
(()
_user, CPP (Annotated ParsedSource)
ast, change :: Change
change@(Change [Replacement]
_replacements [AnnotatedImports]
_imports)) <-
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
FixityEnv
-> Retrie a
-> CPP (Annotated ParsedSource)
-> IO (a, CPP (Annotated ParsedSource), Change)
runRetrie FixityEnv
fixityEnv Retrie ()
retrie CPP (Annotated ParsedSource)
cpp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Change -> [(Uri, TextEdit)]
asTextEdits Change
change
let ([CallRetrieError]
errors :: [CallRetrieError], [[(Uri, TextEdit)]]
replacements) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CallRetrieError [(Uri, TextEdit)]]
results
editParams :: WorkspaceEdit
editParams :: WorkspaceEdit
editParams =
Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [(Uri, TextEdit)] -> WorkspaceEditMap
asEditMap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Uri, TextEdit)]]
replacements) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return ([CallRetrieError]
errors, WorkspaceEdit
editParams)
useOrFail ::
IdeRule r v =>
IdeState ->
String ->
(NormalizedFilePath -> CallRetrieError) ->
r ->
NormalizedFilePath ->
IO (RuleResult r)
useOrFail :: forall r v.
IdeRule r v =>
IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> r
-> NormalizedFilePath
-> IO (RuleResult r)
useOrFail IdeState
state String
lbl NormalizedFilePath -> CallRetrieError
mkException r
rule NormalizedFilePath
f =
forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
useRule String
lbl IdeState
state r
rule NormalizedFilePath
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> CallRetrieError
mkException NormalizedFilePath
f) forall (m :: * -> *) a. Monad m => a -> m a
return
fixityEnvFromModIface :: ModIface -> FixityEnv
fixityEnvFromModIface :: ModIface -> FixityEnv
fixityEnvFromModIface ModIface
modIface =
[(RuleName, (RuleName, Fixity))] -> FixityEnv
mkFixityEnv
[ (RuleName
fs, (RuleName
fs, Fixity
fixity))
| (OccName
n, Fixity
fixity) <- forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities ModIface
modIface,
let fs :: RuleName
fs = OccName -> RuleName
occNameFS OccName
n
]
fixFixities :: Data ast =>
IdeState
-> NormalizedFilePath
-> Annotated ast
-> IO (FixityEnv, Annotated ast)
fixFixities :: forall ast.
Data ast =>
IdeState
-> NormalizedFilePath
-> Annotated ast
-> IO (FixityEnv, Annotated ast)
fixFixities IdeState
state NormalizedFilePath
f Annotated ast
pm = do
HiFileResult {ModIface
hirModIface :: ModIface
hirModIface :: HiFileResult -> ModIface
hirModIface} <-
forall r v.
IdeRule r v =>
IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> r
-> NormalizedFilePath
-> IO (RuleResult r)
useOrFail IdeState
state String
"GetModIface" NormalizedFilePath -> CallRetrieError
NoTypeCheck GetModIface
GetModIface NormalizedFilePath
f
let fixities :: FixityEnv
fixities = ModIface -> FixityEnv
fixityEnvFromModIface ModIface
hirModIface
Annotated ast
res <- forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated ast
pm (forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixities)
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ast
res)
fixAnns :: ParsedModule -> Annotated GHC.ParsedSource
#if MIN_VERSION_ghc(9,2,0)
fixAnns :: ParsedModule -> Annotated ParsedSource
fixAnns GHC.ParsedModule{ParsedSource
pm_parsed_source :: ParsedSource
pm_parsed_source :: ParsedModule -> ParsedSource
pm_parsed_source} = forall ast. ast -> Int -> Annotated ast
unsafeMkA (forall ast. ExactPrint ast => ast -> ast
makeDeltaAst ParsedSource
pm_parsed_source) Int
0
#else
fixAnns GHC.ParsedModule {..} =
let ranns = relativiseApiAnns pm_parsed_source pm_annotations
in unsafeMkA pm_parsed_source ranns 0
#endif
parseSpecs
:: IdeState
-> NormalizedFilePath
-> AnnotatedModule
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite Universe]
parseSpecs :: IdeState
-> NormalizedFilePath
-> Annotated ParsedSource
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite Universe]
parseSpecs IdeState
state NormalizedFilePath
origin Annotated ParsedSource
originParsedModule FixityEnv
originFixities [RewriteSpec]
specs = do
#if MIN_VERSION_ghc(9,2,0)
String
libdir <- DynFlags -> String
topDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> DynFlags
ms_hspp_opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummaryResult -> ModSummary
msrModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r v.
IdeRule r v =>
IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> r
-> NormalizedFilePath
-> IO (RuleResult r)
useOrFail IdeState
state String
"Retrie.GetModSummary" (String -> NormalizedFilePath -> CallRetrieError
CallRetrieInternalError String
"file not found") GetModSummary
GetModSummary NormalizedFilePath
origin
#endif
String
-> (String -> IO (CPP (Annotated ParsedSource)))
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite Universe]
parseRewriteSpecs
#if MIN_VERSION_ghc(9,2,0)
String
libdir
#endif
(\String
_f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CPP a
NoCPP Annotated ParsedSource
originParsedModule)
FixityEnv
originFixities
[RewriteSpec]
specs
constructfromFunMatches :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> GenLocated SrcSpanAnnN RdrName
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT IO [Rewrite Universe]
constructfromFunMatches Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps GenLocated SrcSpanAnnN RdrName
fun_id MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches = do
let fName :: RuleName
fName = OccName -> RuleName
occNameFS (forall name. HasOccName name => name -> OccName
GHC.occName (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
fun_id))
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fe <- forall (m :: * -> *).
Monad m =>
GenLocated SrcSpanAnnN RdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar GenLocated SrcSpanAnnN RdrName
fun_id
[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
rewrites <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall p body. MatchGroup p body -> XRec p [LMatch p body]
GHC.mg_alts MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches) (LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
matchToRewrites GenLocated SrcSpanAnnA (HsExpr GhcPs)
fe Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps Direction
LeftToRight)
let urewrites :: [Rewrite Universe]
urewrites = forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
rewrites
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Rewrite Universe]
urewrites) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => a -> m a
return [Rewrite Universe]
urewrites
showQuery :: Rewrite Universe -> String
showQuery = Rewrite Universe -> String
ppRewrite
s :: Data a => a -> String
s :: forall a. Data a => a -> String
s = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan
#if MIN_VERSION_ghc(9,2,0)
BlankEpAnnotations
NoBlankEpAnnotations
#endif
constructInlineFromIdentifer :: Annotated (GenLocated l a) -> RealSrcSpan -> IO [Rewrite Universe]
constructInlineFromIdentifer Annotated (GenLocated l a)
originParsedModule RealSrcSpan
originSpan = do
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Annotated ast -> ast
astA forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated (GenLocated l a)
originParsedModule forall a b. (a -> b) -> a -> b
$ \(L l
_ a
m) -> do
let ast :: First
(GenLocated SrcSpanAnnN RdrName,
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
ast = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything forall a. Semigroup a => a -> a -> a
(<>) (forall a. Maybe a -> First a
First forall a. Maybe a
Nothing forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` HsBindLR GhcPs GhcPs
-> First
(GenLocated SrcSpanAnnN RdrName,
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
matcher) a
m
matcher :: HsBindLR GhcPs GhcPs -> First _
matcher :: HsBindLR GhcPs GhcPs
-> First
(GenLocated SrcSpanAnnN RdrName,
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
matcher FunBind{LIdP GhcPs
fun_id :: LIdP GhcPs
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id, MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches}
| RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_ <- forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LIdP GhcPs
fun_id
, RealSrcSpan
sp forall a. Eq a => a -> a -> Bool
== RealSrcSpan
originSpan =
forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (LIdP GhcPs
fun_id, MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches)
matcher HsBindLR GhcPs GhcPs
_ = forall a. Maybe a -> First a
First forall a. Maybe a
Nothing
case First
(GenLocated SrcSpanAnnN RdrName,
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
ast of
First (Just (GenLocated SrcSpanAnnN RdrName
fun_id, MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches))
->
let imports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imports = forall a. Monoid a => a
mempty in
Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> GenLocated SrcSpanAnnN RdrName
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT IO [Rewrite Universe]
constructfromFunMatches Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imports GenLocated SrcSpanAnnN RdrName
fun_id MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches
First
(GenLocated SrcSpanAnnN RdrName,
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => String -> a
error String
"cound not find source code to inline"
asEditMap :: [(Uri, TextEdit)] -> WorkspaceEditMap
asEditMap :: [(Uri, TextEdit)] -> WorkspaceEditMap
asEditMap = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (f :: * -> *) a. Applicative f => a -> f a
pure)
asTextEdits :: Change -> [(Uri, TextEdit)]
asTextEdits :: Change -> [(Uri, TextEdit)]
asTextEdits Change
NoChange = []
asTextEdits (Change [Replacement]
reps [AnnotatedImports]
_imports) =
[ (String -> Uri
filePathToUri String
spanLoc, TextEdit
edit)
| Replacement {String
SrcSpan
replReplacement :: String
replOriginal :: String
replLocation :: SrcSpan
replLocation :: Replacement -> SrcSpan
replOriginal :: Replacement -> String
replReplacement :: Replacement -> String
..} <- forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (SrcSpan -> Maybe RealSrcSpan
realSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. Replacement -> SrcSpan
replLocation) [Replacement]
reps,
(RealSrcSpan RealSrcSpan
rspan Maybe BufSpan
_) <- [SrcSpan
replLocation],
let spanLoc :: String
spanLoc = RuleName -> String
unpackFS forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RuleName
srcSpanFile RealSrcSpan
rspan,
let edit :: TextEdit
edit = Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
rspan) (String -> Text
T.pack String
replReplacement)
]
_useRuleBlocking,
_useRuleStale,
useRule ::
(IdeRule k v) =>
String ->
IdeState ->
k ->
NormalizedFilePath ->
IO (Maybe (RuleResult k))
_useRuleBlocking :: forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
_useRuleBlocking String
label IdeState
state k
rule NormalizedFilePath
f = forall a. String -> IdeState -> Action a -> IO a
runAction String
label IdeState
state (forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
rule NormalizedFilePath
f)
_useRuleStale :: forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
_useRuleStale String
label IdeState
state k
rule NormalizedFilePath
f =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
label (IdeState -> ShakeExtras
shakeExtras IdeState
state) (forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast k
rule NormalizedFilePath
f)
useRule :: forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
useRule String
label = forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
_useRuleStale (String
"Retrie." forall a. Semigroup a => a -> a -> a
<> String
label)
deriving instance Eq RewriteSpec
deriving instance Show RewriteSpec
deriving instance Generic RewriteSpec
deriving instance FromJSON RewriteSpec
deriving instance ToJSON RewriteSpec
newtype IE name
= IEVar name
deriving (IE name -> IE name -> Bool
forall name. Eq name => IE name -> IE name -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IE name -> IE name -> Bool
$c/= :: forall name. Eq name => IE name -> IE name -> Bool
== :: IE name -> IE name -> Bool
$c== :: forall name. Eq name => IE name -> IE name -> Bool
Eq, Int -> IE name -> ShowS
forall name. Show name => Int -> IE name -> ShowS
forall name. Show name => [IE name] -> ShowS
forall name. Show name => IE name -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IE name] -> ShowS
$cshowList :: forall name. Show name => [IE name] -> ShowS
show :: IE name -> String
$cshow :: forall name. Show name => IE name -> String
showsPrec :: Int -> IE name -> ShowS
$cshowsPrec :: forall name. Show name => Int -> IE name -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall name x. Rep (IE name) x -> IE name
forall name x. IE name -> Rep (IE name) x
$cto :: forall name x. Rep (IE name) x -> IE name
$cfrom :: forall name x. IE name -> Rep (IE name) x
Generic, forall name. FromJSON name => Value -> Parser [IE name]
forall name. FromJSON name => Value -> Parser (IE name)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [IE name]
$cparseJSONList :: forall name. FromJSON name => Value -> Parser [IE name]
parseJSON :: Value -> Parser (IE name)
$cparseJSON :: forall name. FromJSON name => Value -> Parser (IE name)
FromJSON, forall name. ToJSON name => [IE name] -> Encoding
forall name. ToJSON name => [IE name] -> Value
forall name. ToJSON name => IE name -> Encoding
forall name. ToJSON name => IE name -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [IE name] -> Encoding
$ctoEncodingList :: forall name. ToJSON name => [IE name] -> Encoding
toJSONList :: [IE name] -> Value
$ctoJSONList :: forall name. ToJSON name => [IE name] -> Value
toEncoding :: IE name -> Encoding
$ctoEncoding :: forall name. ToJSON name => IE name -> Encoding
toJSON :: IE name -> Value
$ctoJSON :: forall name. ToJSON name => IE name -> Value
ToJSON)
data ImportSpec = AddImport
{ ImportSpec -> String
ideclNameString :: String,
ImportSpec -> Bool
ideclSource :: Bool,
ImportSpec -> Bool
ideclQualifiedBool :: Bool,
ImportSpec -> Maybe String
ideclAsString :: Maybe String,
ImportSpec -> Maybe (IE String)
ideclThing :: Maybe (IE String)
}
deriving (ImportSpec -> ImportSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportSpec -> ImportSpec -> Bool
$c/= :: ImportSpec -> ImportSpec -> Bool
== :: ImportSpec -> ImportSpec -> Bool
$c== :: ImportSpec -> ImportSpec -> Bool
Eq, Int -> ImportSpec -> ShowS
[ImportSpec] -> ShowS
ImportSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImportSpec] -> ShowS
$cshowList :: [ImportSpec] -> ShowS
show :: ImportSpec -> String
$cshow :: ImportSpec -> String
showsPrec :: Int -> ImportSpec -> ShowS
$cshowsPrec :: Int -> ImportSpec -> ShowS
Show, forall x. Rep ImportSpec x -> ImportSpec
forall x. ImportSpec -> Rep ImportSpec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ImportSpec x -> ImportSpec
$cfrom :: forall x. ImportSpec -> Rep ImportSpec x
Generic, Value -> Parser [ImportSpec]
Value -> Parser ImportSpec
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ImportSpec]
$cparseJSONList :: Value -> Parser [ImportSpec]
parseJSON :: Value -> Parser ImportSpec
$cparseJSON :: Value -> Parser ImportSpec
FromJSON, [ImportSpec] -> Encoding
[ImportSpec] -> Value
ImportSpec -> Encoding
ImportSpec -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ImportSpec] -> Encoding
$ctoEncodingList :: [ImportSpec] -> Encoding
toJSONList :: [ImportSpec] -> Value
$ctoJSONList :: [ImportSpec] -> Value
toEncoding :: ImportSpec -> Encoding
$ctoEncoding :: ImportSpec -> Encoding
toJSON :: ImportSpec -> Value
$ctoJSON :: ImportSpec -> Value
ToJSON)
toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs
toImportDecl :: ImportSpec -> ImportDecl GhcPs
toImportDecl AddImport {Bool
String
Maybe String
Maybe (IE String)
ideclThing :: Maybe (IE String)
ideclAsString :: Maybe String
ideclQualifiedBool :: Bool
ideclSource :: Bool
ideclNameString :: String
ideclThing :: ImportSpec -> Maybe (IE String)
ideclAsString :: ImportSpec -> Maybe String
ideclQualifiedBool :: ImportSpec -> Bool
ideclSource :: ImportSpec -> Bool
ideclNameString :: ImportSpec -> String
..} = GHC.ImportDecl {ideclSource :: IsBootInterface
ideclSource = IsBootInterface
ideclSource', Bool
Maybe (LocatedAn AnnListItem ModuleName)
ImportDeclQualifiedStyle
SourceText
LocatedAn AnnListItem ModuleName
forall a. Maybe a
forall {ann}. EpAnn ann
ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclExt :: XCImportDecl GhcPs
ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclImplicit :: Bool
ideclName :: XRec GhcPs ModuleName
ideclPkgQual :: Maybe StringLiteral
ideclQualified :: ImportDeclQualifiedStyle
ideclSafe :: Bool
ideclSourceSrc :: SourceText
ideclQualified :: ImportDeclQualifiedStyle
ideclAs :: Maybe (LocatedAn AnnListItem ModuleName)
ideclExt :: forall {ann}. EpAnn ann
ideclSourceSrc :: SourceText
ideclHiding :: forall a. Maybe a
ideclImplicit :: Bool
ideclSafe :: Bool
ideclPkgQual :: forall a. Maybe a
ideclName :: LocatedAn AnnListItem ModuleName
..}
where
ideclSource' :: IsBootInterface
ideclSource' = if Bool
ideclSource then IsBootInterface
IsBoot else IsBootInterface
NotBoot
toMod :: String -> LocatedAn an ModuleName
toMod = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
GHC.mkModuleName
ideclName :: LocatedAn AnnListItem ModuleName
ideclName = forall {an}. String -> LocatedAn an ModuleName
toMod String
ideclNameString
#if MIN_VERSION_ghc(9,3,0)
ideclPkgQual = NoRawPkgQual
#else
ideclPkgQual :: Maybe a
ideclPkgQual = forall a. Maybe a
Nothing
#endif
ideclSafe :: Bool
ideclSafe = Bool
False
ideclImplicit :: Bool
ideclImplicit = Bool
False
ideclHiding :: Maybe a
ideclHiding = forall a. Maybe a
Nothing
ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText
#if MIN_VERSION_ghc(9,5,0)
ideclExt = GHCGHC.XImportDeclPass
{ ideclAnn = GHCGHC.EpAnnNotUsed
, ideclSourceText = ideclSourceSrc
, ideclImplicit = ideclImplicit
}
#elif MIN_VERSION_ghc(9,2,0)
ideclExt :: EpAnn ann
ideclExt = forall {ann}. EpAnn ann
GHCGHC.EpAnnNotUsed
#else
ideclExt = GHC.noExtField
#endif
ideclAs :: Maybe (LocatedAn AnnListItem ModuleName)
ideclAs = forall {an}. String -> LocatedAn an ModuleName
toMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
ideclAsString
ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if Bool
ideclQualifiedBool then ImportDeclQualifiedStyle
GHC.QualifiedPre else ImportDeclQualifiedStyle
GHC.NotQualified
reuseParsedModule :: IdeState
-> NormalizedFilePath -> IO (FixityEnv, Annotated ParsedSource)
reuseParsedModule IdeState
state NormalizedFilePath
f = do
ParsedModule
pm <- forall r v.
IdeRule r v =>
IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> r
-> NormalizedFilePath
-> IO (RuleResult r)
useOrFail IdeState
state String
"Retrie.GetParsedModule" NormalizedFilePath -> CallRetrieError
NoParse GetParsedModule
GetParsedModule NormalizedFilePath
f
(FixityEnv
fixities, Annotated ParsedSource
pm') <- forall ast.
Data ast =>
IdeState
-> NormalizedFilePath
-> Annotated ast
-> IO (FixityEnv, Annotated ast)
fixFixities IdeState
state NormalizedFilePath
f (ParsedModule -> Annotated ParsedSource
fixAnns ParsedModule
pm)
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ParsedSource
pm')
getCPPmodule :: IdeState
-> HscEnv -> String -> IO (FixityEnv, CPP (Annotated ParsedSource))
getCPPmodule IdeState
state HscEnv
session String
t = do
NormalizedFilePath
nt <- String -> NormalizedFilePath
toNormalizedFilePath' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute String
t
let getParsedModule :: NormalizedFilePath
-> String -> IO (FixityEnv, Annotated ParsedSource)
getParsedModule NormalizedFilePath
f String
contents = do
ModSummary
modSummary <- ModSummaryResult -> ModSummary
msrModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall r v.
IdeRule r v =>
IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> r
-> NormalizedFilePath
-> IO (RuleResult r)
useOrFail IdeState
state String
"Retrie.GetModSummary" (String -> NormalizedFilePath -> CallRetrieError
CallRetrieInternalError String
"file not found") GetModSummary
GetModSummary NormalizedFilePath
nt
let ms' :: ModSummary
ms' =
ModSummary
modSummary
{ ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf =
forall a. a -> Maybe a
Just (String -> StringBuffer
stringToStringBuffer String
contents)
}
Logger -> Priority -> Text -> IO ()
logPriority (IdeState -> Logger
ideLogger IdeState
state) Priority
Info forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Parsing module: " forall a. Semigroup a => a -> a -> a
<> String
t
ParsedModule
parsed <- forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
session (forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
GHCGHC.parseModule ModSummary
ms')
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (NormalizedFilePath -> String -> CallRetrieError
GHCParseError NormalizedFilePath
nt (forall a. Show a => a -> String
show @SomeException SomeException
e))
(FixityEnv
fixities, Annotated ParsedSource
parsed) <- forall ast.
Data ast =>
IdeState
-> NormalizedFilePath
-> Annotated ast
-> IO (FixityEnv, Annotated ast)
fixFixities IdeState
state NormalizedFilePath
f (ParsedModule -> Annotated ParsedSource
fixAnns ParsedModule
parsed)
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ParsedSource
parsed)
Text
contents <- do
(UTCTime
_, Maybe Text
mbContentsVFS) <-
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Retrie.GetFileContents" IdeState
state forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nt
case Maybe Text
mbContentsVFS of
Just Text
contents -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
contents
Maybe Text
Nothing -> ByteString -> Text
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nt)
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
T.isPrefixOf Text
"#if" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower) (Text -> [Text]
T.lines Text
contents)
then do
IORef FixityEnv
fixitiesRef <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
let parseModule :: String -> IO (Annotated ParsedSource)
parseModule String
x = do
(FixityEnv
fix, Annotated ParsedSource
res) <- NormalizedFilePath
-> String -> IO (FixityEnv, Annotated ParsedSource)
getParsedModule NormalizedFilePath
nt String
x
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef FixityEnv
fixitiesRef (FixityEnv
fix forall a. Semigroup a => a -> a -> a
<>)
forall (m :: * -> *) a. Monad m => a -> m a
return Annotated ParsedSource
res
CPP (Annotated ParsedSource)
res <- forall (m :: * -> *).
Monad m =>
(String -> m (Annotated ParsedSource))
-> Text -> m (CPP (Annotated ParsedSource))
parseCPP String -> IO (Annotated ParsedSource)
parseModule Text
contents
FixityEnv
fixities <- forall a. IORef a -> IO a
readIORef IORef FixityEnv
fixitiesRef
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, CPP (Annotated ParsedSource)
res)
else do
(FixityEnv
fixities, Annotated ParsedSource
pm) <- IdeState
-> NormalizedFilePath -> IO (FixityEnv, Annotated ParsedSource)
reuseParsedModule IdeState
state NormalizedFilePath
nt
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, forall a. a -> CPP a
NoCPP Annotated ParsedSource
pm)