{-# 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

-- | Parameters for the runRetrie PluginCommand.
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
    -- What we do here:
    --   Find the identifier in the given position
    --   Construct an inline rewrite for it
    --   Run retrie to get a list of changes
    --   Select the change that inlines the identifier in the given position
    --   Apply the edit
    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

-- Override to skip adding binders to the context, which prevents inlining
-- nested defined functions
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

    -- override to skip the HsLet case
    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 }
    -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right)
    -- In left child, prec is 10, so HsApp child will NOT get paren'd
    -- In right child, prec is 11, so every child gets paren'd (unless atomic)
    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 }
    -- Deal with Trees-That-Grow adding extension points
    -- as the first child everywhere.
    firstChild :: Int
    firstChild :: Int
firstChild = Int
1

extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]
extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]
extractImports 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
-- TODO handle imports for all rewrites
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
  -- we use the typechecked source instead of the parsed source
  -- to be able to extract module names from the Ids,
  -- so that we can include adding the required imports in the retrie command
  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
_ = []

  -- find all the identifiers in the AST for which have source definitions
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 =
        -- we search for candidates to inline in RHSs only, skipping LHSs
        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{} =
        -- we only select candidates for which we have source code
        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

-------------------------------------------------------------------------------
-- Retrie driving code

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
      -- TODO cover all workspaceFolders
      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
    -- TODO add the imports to the resulting edits
    (()
_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)
  -- retrie needs the libdir for `parseRewriteSpecs`
  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
    -- traceShowM $ map showQuery urewrites
    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
-- showQuery :: Rewrite (LHsExpr GhcPs) -> String
-- showQuery q = unlines
--     [ "template: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . tTemplate . fst . qResult $ q))
--     , "quantifiers: " <> show (hash (T.pack (show(Ext.toList $ qQuantifiers q))))
--     , "matcher: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . qPattern $ q))
--     ]

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
    -- traceM $ s $ astA originParsedModule
    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}
                --  | trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined
                | 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)
  ]

-------------------------------------------------------------------------------
-- Rule wrappers

_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)

-- | Chosen approach for calling ghcide Shake rules
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)

-------------------------------------------------------------------------------
-- Serialization wrappers and instances

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)