{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}

{-# OPTIONS -Wno-orphans #-}

module Ide.Plugin.Retrie (descriptor) where

import           Control.Concurrent.STM               (readTVarIO)
import           Control.Exception.Safe               (Exception (..),
                                                       SomeException, assert,
                                                       catch, throwIO, try)
import           Control.Lens.Operators
import           Control.Monad                        (forM, unless, when)
import           Control.Monad.Error.Class            (MonadError (throwError))
import           Control.Monad.IO.Class               (MonadIO (liftIO))
import           Control.Monad.Trans.Class            (MonadTrans (lift))
import           Control.Monad.Trans.Except           (ExceptT (..), runExceptT)

import           Control.Monad.Trans.Maybe            (MaybeT)
import           Data.Aeson                           (FromJSON (..),
                                                       ToJSON (..))
import           Data.Bifunctor                       (second)
import qualified Data.ByteString                      as BS
import           Data.Data
import           Data.Either                          (partitionEithers)
import           Data.Hashable                        (unhashed)
import qualified Data.HashSet                         as Set
import           Data.IORef.Extra                     (atomicModifyIORef'_,
                                                       newIORef, readIORef)
import           Data.List.Extra                      (find, nubOrdOn)
import qualified Data.Map                             as Map
import           Data.Maybe                           (catMaybes)
import           Data.Monoid                          (First (First))
import           Data.String                          (IsString)
import qualified Data.Text                            as T
import qualified Data.Text.Encoding                   as T
import           Development.IDE                      hiding (pluginHandlers)
import           Development.IDE.Core.Actions         (lookupMod)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.Core.PositionMapping
import           Development.IDE.Core.Shake           (ShakeExtras (ShakeExtras, knownTargetsVar),
                                                       getShakeExtras,
                                                       hiedbWriter,
                                                       toKnownFiles, withHieDb)
import           Development.IDE.GHC.Compat           (GRHSs (GRHSs),
                                                       GenLocated (L), GhcPs,
                                                       GhcRn,
                                                       HsBindLR (FunBind),
                                                       HsExpr (HsApp, OpApp),
                                                       HsGroup (..),
                                                       HsValBindsLR (..),
                                                       HscEnv, ImportDecl (..),
                                                       LHsExpr, LRuleDecls,
                                                       Match, ModIface,
                                                       ModSummary (ModSummary, ms_hspp_buf, ms_mod),
                                                       Outputable, ParsedModule,
                                                       RuleDecl (HsRule),
                                                       RuleDecls (HsRules),
                                                       SourceText (..),
                                                       TyClDecl (SynDecl),
                                                       TyClGroup (..), fun_id,
                                                       isQual, isQual_maybe,
                                                       locA, mi_fixities,
                                                       moduleNameString,
                                                       ms_hspp_opts,
                                                       nameModule_maybe,
                                                       nameOccName, nameRdrName,
                                                       noLocA, occNameFS,
                                                       occNameString,
                                                       pattern IsBoot,
                                                       pattern NotBoot,
                                                       pattern RealSrcSpan,
                                                       pm_parsed_source,
                                                       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.ExactPrint       (GetAnnotatedParsedSource (GetAnnotatedParsedSource),
                                                       TransformT)
import           Development.IDE.Spans.AtPoint        (LookupModule,
                                                       nameToLocation)
import           Development.IDE.Types.Shake          (WithHieDb)
import qualified GHC                                  as GHCGHC
import           GHC.Generics                         (Generic)
import           Ide.Plugin.Error                     (PluginError (PluginInternalError),
                                                       getNormalizedFilePathE)
import           Ide.PluginUtils
import           Ide.Types
import qualified Language.LSP.Protocol.Lens           as L
import           Language.LSP.Protocol.Message        as LSP
import           Language.LSP.Protocol.Types          as LSP
import           Language.LSP.Server                  (ProgressCancellable (Cancellable),
                                                       sendNotification,
                                                       sendRequest,
                                                       withIndefiniteProgress)
import           Retrie                               (Annotated (astA),
                                                       AnnotatedModule,
                                                       Fixity (Fixity),
                                                       FixityDirection (InfixL),
                                                       Options, Options_ (..),
                                                       Verbosity (Loud),
                                                       addImports, apply,
                                                       applyWithUpdate)
import           Retrie.Context
import           Retrie.CPP                           (CPP (NoCPP), parseCPP)
import           Retrie.ExactPrint                    (fix, makeDeltaAst,
                                                       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

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId =
  (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides code actions to inline Haskell definitions")
    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider,
      pluginCommands = [retrieCommand, retrieInlineThisCommand]
    }

retrieCommandId :: CommandId
retrieCommandId :: CommandId
retrieCommandId = CommandId
"retrieCommand"

retrieInlineThisCommandId :: CommandId
retrieInlineThisCommandId :: CommandId
retrieInlineThisCommandId = CommandId
"retrieInlineThisCommand"

retrieCommand :: PluginCommand IdeState
retrieCommand :: PluginCommand IdeState
retrieCommand =
  CommandId
-> Text
-> CommandFunction IdeState RunRetrieParams
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
retrieCommandId Text
"run the refactoring" CommandFunction IdeState RunRetrieParams
runRetrieCmd

retrieInlineThisCommand :: PluginCommand IdeState
retrieInlineThisCommand :: PluginCommand IdeState
retrieInlineThisCommand =
  CommandId
-> Text
-> CommandFunction IdeState RunRetrieInlineThisParams
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
retrieInlineThisCommandId Text
"inline function call"
     CommandFunction IdeState RunRetrieInlineThisParams
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
(RunRetrieParams -> RunRetrieParams -> Bool)
-> (RunRetrieParams -> RunRetrieParams -> Bool)
-> Eq RunRetrieParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunRetrieParams -> RunRetrieParams -> Bool
== :: RunRetrieParams -> RunRetrieParams -> Bool
$c/= :: RunRetrieParams -> RunRetrieParams -> Bool
/= :: RunRetrieParams -> RunRetrieParams -> Bool
Eq, Int -> RunRetrieParams -> ShowS
[RunRetrieParams] -> ShowS
RunRetrieParams -> String
(Int -> RunRetrieParams -> ShowS)
-> (RunRetrieParams -> String)
-> ([RunRetrieParams] -> ShowS)
-> Show RunRetrieParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunRetrieParams -> ShowS
showsPrec :: Int -> RunRetrieParams -> ShowS
$cshow :: RunRetrieParams -> String
show :: RunRetrieParams -> String
$cshowList :: [RunRetrieParams] -> ShowS
showList :: [RunRetrieParams] -> ShowS
Show, (forall x. RunRetrieParams -> Rep RunRetrieParams x)
-> (forall x. Rep RunRetrieParams x -> RunRetrieParams)
-> Generic RunRetrieParams
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
$cfrom :: forall x. RunRetrieParams -> Rep RunRetrieParams x
from :: forall x. RunRetrieParams -> Rep RunRetrieParams x
$cto :: forall x. Rep RunRetrieParams x -> RunRetrieParams
to :: forall x. Rep RunRetrieParams x -> RunRetrieParams
Generic, Maybe RunRetrieParams
Value -> Parser [RunRetrieParams]
Value -> Parser RunRetrieParams
(Value -> Parser RunRetrieParams)
-> (Value -> Parser [RunRetrieParams])
-> Maybe RunRetrieParams
-> FromJSON RunRetrieParams
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser RunRetrieParams
parseJSON :: Value -> Parser RunRetrieParams
$cparseJSONList :: Value -> Parser [RunRetrieParams]
parseJSONList :: Value -> Parser [RunRetrieParams]
$comittedField :: Maybe RunRetrieParams
omittedField :: Maybe RunRetrieParams
FromJSON, [RunRetrieParams] -> Value
[RunRetrieParams] -> Encoding
RunRetrieParams -> Bool
RunRetrieParams -> Value
RunRetrieParams -> Encoding
(RunRetrieParams -> Value)
-> (RunRetrieParams -> Encoding)
-> ([RunRetrieParams] -> Value)
-> ([RunRetrieParams] -> Encoding)
-> (RunRetrieParams -> Bool)
-> ToJSON RunRetrieParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: RunRetrieParams -> Value
toJSON :: RunRetrieParams -> Value
$ctoEncoding :: RunRetrieParams -> Encoding
toEncoding :: RunRetrieParams -> Encoding
$ctoJSONList :: [RunRetrieParams] -> Value
toJSONList :: [RunRetrieParams] -> Value
$ctoEncodingList :: [RunRetrieParams] -> Encoding
toEncodingList :: [RunRetrieParams] -> Encoding
$comitField :: RunRetrieParams -> Bool
omitField :: RunRetrieParams -> Bool
ToJSON)

runRetrieCmd :: CommandFunction IdeState RunRetrieParams
runRetrieCmd :: CommandFunction IdeState RunRetrieParams
runRetrieCmd IdeState
state Maybe ProgressToken
token RunRetrieParams{originatingFile :: RunRetrieParams -> Uri
originatingFile = Uri
uri, Bool
[RewriteSpec]
Text
description :: RunRetrieParams -> Text
rewrites :: RunRetrieParams -> [RewriteSpec]
restrictToOriginatingFile :: RunRetrieParams -> Bool
description :: Text
rewrites :: [RewriteSpec]
restrictToOriginatingFile :: Bool
..} = LspM Config (Either PluginError (Value |? Null))
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LspM Config (Either PluginError (Value |? Null))
 -> ExceptT PluginError (LspM Config) (Value |? Null))
-> LspM Config (Either PluginError (Value |? Null))
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$
  Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> LspT Config IO ())
    -> LspM Config (Either PluginError (Value |? Null)))
-> LspM Config (Either PluginError (Value |? Null))
forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> m ()) -> m a)
-> m a
withIndefiniteProgress Text
description Maybe ProgressToken
token ProgressCancellable
Cancellable (((Text -> LspT Config IO ())
  -> LspM Config (Either PluginError (Value |? Null)))
 -> LspM Config (Either PluginError (Value |? Null)))
-> ((Text -> LspT Config IO ())
    -> LspM Config (Either PluginError (Value |? Null)))
-> LspM Config (Either PluginError (Value |? Null))
forall a b. (a -> b) -> a -> b
$ \Text -> LspT Config IO ()
_updater -> do
    Either PluginError ()
_ <- ExceptT PluginError (LspM Config) ()
-> LspT Config IO (Either PluginError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PluginError (LspM Config) ()
 -> LspT Config IO (Either PluginError ()))
-> ExceptT PluginError (LspM Config) ()
-> LspT Config IO (Either PluginError ())
forall a b. (a -> b) -> a -> b
$ do
        NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
        (HscEnvEq
session, PositionMapping
_) <-
            String
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Retrie.GhcSessionDeps" IdeState
state (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$
                GhcSessionDeps
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSessionDeps
GhcSessionDeps
                NormalizedFilePath
nfp
        (ModSummary
ms, [HsBindLR GhcRn GhcRn]
binds, PositionMapping
_, [GenLocated SrcSpanAnnA (RuleDecls GhcRn)]
_, [TyClGroup GhcRn]
_) <- String
-> IdeState
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
-> ExceptT
     PluginError
     (LspM Config)
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Retrie.getBinds" IdeState
state (ExceptT
   PluginError
   Action
   (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
    [LRuleDecls GhcRn], [TyClGroup GhcRn])
 -> ExceptT
      PluginError
      (LspM Config)
      (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
       [LRuleDecls GhcRn], [TyClGroup GhcRn]))
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
-> ExceptT
     PluginError
     (LspM Config)
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
getBinds NormalizedFilePath
nfp
        let importRewrites :: [ImportSpec]
importRewrites = (RewriteSpec -> [ImportSpec]) -> [RewriteSpec] -> [ImportSpec]
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) <- IO ([CallRetrieError], WorkspaceEdit)
-> ExceptT
     PluginError (LspM Config) ([CallRetrieError], WorkspaceEdit)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([CallRetrieError], WorkspaceEdit)
 -> ExceptT
      PluginError (LspM Config) ([CallRetrieError], WorkspaceEdit))
-> IO ([CallRetrieError], WorkspaceEdit)
-> ExceptT
     PluginError (LspM Config) ([CallRetrieError], WorkspaceEdit)
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)
                ((RewriteSpec -> Either ImportSpec RewriteSpec)
-> [RewriteSpec] -> [Either ImportSpec RewriteSpec]
forall a b. (a -> b) -> [a] -> [b]
map RewriteSpec -> Either ImportSpec RewriteSpec
forall a b. b -> Either a b
Right [RewriteSpec]
rewrites [Either ImportSpec RewriteSpec]
-> [Either ImportSpec RewriteSpec]
-> [Either ImportSpec RewriteSpec]
forall a. Semigroup a => a -> a -> a
<> (ImportSpec -> Either ImportSpec RewriteSpec)
-> [ImportSpec] -> [Either ImportSpec RewriteSpec]
forall a b. (a -> b) -> [a] -> [b]
map ImportSpec -> Either ImportSpec RewriteSpec
forall a b. a -> Either a b
Left [ImportSpec]
importRewrites)
                NormalizedFilePath
nfp
                Bool
restrictToOriginatingFile
        Bool
-> ExceptT PluginError (LspM Config) ()
-> ExceptT PluginError (LspM Config) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CallRetrieError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CallRetrieError]
errors) (ExceptT PluginError (LspM Config) ()
 -> ExceptT PluginError (LspM Config) ())
-> ExceptT PluginError (LspM Config) ()
-> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$
            LspT Config IO () -> ExceptT PluginError (LspM Config) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspT Config IO () -> ExceptT PluginError (LspM Config) ())
-> LspT Config IO () -> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage -> LspT Config IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage (MessageParams 'Method_WindowShowMessage -> LspT Config IO ())
-> MessageParams 'Method_WindowShowMessage -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$
                    MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
MessageType_Warning (Text -> ShowMessageParams) -> Text -> ShowMessageParams
forall a b. (a -> b) -> a -> b
$
                    [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                        Text
"## Found errors during rewrite:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
                        [Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (CallRetrieError -> String
forall a. Show a => a -> String
show CallRetrieError
e) | CallRetrieError
e <- [CallRetrieError]
errors]
        LspId 'Method_WorkspaceApplyEdit
_ <- LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT
      PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit))
-> LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
edits) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        () -> ExceptT PluginError (LspM Config) ()
forall a. a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Either PluginError (Value |? Null)
-> LspM Config (Either PluginError (Value |? Null))
forall a. a -> LspT Config IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError (Value |? Null)
 -> LspM Config (Either PluginError (Value |? Null)))
-> Either PluginError (Value |? Null)
-> LspM Config (Either PluginError (Value |? Null))
forall a b. (a -> b) -> a -> b
$ (Value |? Null) -> Either PluginError (Value |? Null)
forall a b. b -> Either a b
Right ((Value |? Null) -> Either PluginError (Value |? Null))
-> (Value |? Null) -> Either PluginError (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null

data RunRetrieInlineThisParams = RunRetrieInlineThisParams
  { RunRetrieInlineThisParams -> Location
inlineIntoThisLocation :: !Location,
    RunRetrieInlineThisParams -> Location
inlineFromThisLocation :: !Location,
    RunRetrieInlineThisParams -> Text
inlineThisDefinition   :: !T.Text
  }
  deriving (RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
(RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool)
-> (RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool)
-> Eq RunRetrieInlineThisParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
== :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
$c/= :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
/= :: RunRetrieInlineThisParams -> RunRetrieInlineThisParams -> Bool
Eq, Int -> RunRetrieInlineThisParams -> ShowS
[RunRetrieInlineThisParams] -> ShowS
RunRetrieInlineThisParams -> String
(Int -> RunRetrieInlineThisParams -> ShowS)
-> (RunRetrieInlineThisParams -> String)
-> ([RunRetrieInlineThisParams] -> ShowS)
-> Show RunRetrieInlineThisParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunRetrieInlineThisParams -> ShowS
showsPrec :: Int -> RunRetrieInlineThisParams -> ShowS
$cshow :: RunRetrieInlineThisParams -> String
show :: RunRetrieInlineThisParams -> String
$cshowList :: [RunRetrieInlineThisParams] -> ShowS
showList :: [RunRetrieInlineThisParams] -> ShowS
Show, (forall x.
 RunRetrieInlineThisParams -> Rep RunRetrieInlineThisParams x)
-> (forall x.
    Rep RunRetrieInlineThisParams x -> RunRetrieInlineThisParams)
-> Generic RunRetrieInlineThisParams
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
$cfrom :: forall x.
RunRetrieInlineThisParams -> Rep RunRetrieInlineThisParams x
from :: forall x.
RunRetrieInlineThisParams -> Rep RunRetrieInlineThisParams x
$cto :: forall x.
Rep RunRetrieInlineThisParams x -> RunRetrieInlineThisParams
to :: forall x.
Rep RunRetrieInlineThisParams x -> RunRetrieInlineThisParams
Generic, Maybe RunRetrieInlineThisParams
Value -> Parser [RunRetrieInlineThisParams]
Value -> Parser RunRetrieInlineThisParams
(Value -> Parser RunRetrieInlineThisParams)
-> (Value -> Parser [RunRetrieInlineThisParams])
-> Maybe RunRetrieInlineThisParams
-> FromJSON RunRetrieInlineThisParams
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser RunRetrieInlineThisParams
parseJSON :: Value -> Parser RunRetrieInlineThisParams
$cparseJSONList :: Value -> Parser [RunRetrieInlineThisParams]
parseJSONList :: Value -> Parser [RunRetrieInlineThisParams]
$comittedField :: Maybe RunRetrieInlineThisParams
omittedField :: Maybe RunRetrieInlineThisParams
FromJSON, [RunRetrieInlineThisParams] -> Value
[RunRetrieInlineThisParams] -> Encoding
RunRetrieInlineThisParams -> Bool
RunRetrieInlineThisParams -> Value
RunRetrieInlineThisParams -> Encoding
(RunRetrieInlineThisParams -> Value)
-> (RunRetrieInlineThisParams -> Encoding)
-> ([RunRetrieInlineThisParams] -> Value)
-> ([RunRetrieInlineThisParams] -> Encoding)
-> (RunRetrieInlineThisParams -> Bool)
-> ToJSON RunRetrieInlineThisParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: RunRetrieInlineThisParams -> Value
toJSON :: RunRetrieInlineThisParams -> Value
$ctoEncoding :: RunRetrieInlineThisParams -> Encoding
toEncoding :: RunRetrieInlineThisParams -> Encoding
$ctoJSONList :: [RunRetrieInlineThisParams] -> Value
toJSONList :: [RunRetrieInlineThisParams] -> Value
$ctoEncodingList :: [RunRetrieInlineThisParams] -> Encoding
toEncodingList :: [RunRetrieInlineThisParams] -> Encoding
$comitField :: RunRetrieInlineThisParams -> Bool
omitField :: RunRetrieInlineThisParams -> Bool
ToJSON)

runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams
runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams
runRetrieInlineThisCmd IdeState
state Maybe ProgressToken
_token RunRetrieInlineThisParams{Text
Location
inlineIntoThisLocation :: RunRetrieInlineThisParams -> Location
inlineFromThisLocation :: RunRetrieInlineThisParams -> Location
inlineThisDefinition :: RunRetrieInlineThisParams -> Text
inlineIntoThisLocation :: Location
inlineFromThisLocation :: Location
inlineThisDefinition :: Text
..} = do
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath)
-> Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Location -> Uri
getLocationUri Location
inlineIntoThisLocation
    NormalizedFilePath
nfpSource <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath)
-> Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
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
astSrc <- String
-> IdeState
-> ExceptT PluginError Action (Annotated ParsedSource)
-> ExceptT PluginError (LspM Config) (Annotated ParsedSource)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"retrie" IdeState
state (ExceptT PluginError Action (Annotated ParsedSource)
 -> ExceptT PluginError (LspM Config) (Annotated ParsedSource))
-> ExceptT PluginError Action (Annotated ParsedSource)
-> ExceptT PluginError (LspM Config) (Annotated ParsedSource)
forall a b. (a -> b) -> a -> b
$
        GetAnnotatedParsedSource
-> NormalizedFilePath
-> ExceptT PluginError Action (Annotated ParsedSource)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetAnnotatedParsedSource
GetAnnotatedParsedSource NormalizedFilePath
nfpSource
    let fromRange :: RealSrcSpan
fromRange = NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan NormalizedFilePath
nfpSource (Range -> RealSrcSpan) -> Range -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ Location -> Range
getLocationRange Location
inlineFromThisLocation
        intoRange :: RealSrcSpan
intoRange = NormalizedFilePath -> Range -> RealSrcSpan
rangeToRealSrcSpan NormalizedFilePath
nfp (Range -> RealSrcSpan) -> Range -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ Location -> Range
getLocationRange Location
inlineIntoThisLocation
    [Rewrite Universe]
inlineRewrite <- IO [Rewrite Universe]
-> ExceptT PluginError (LspM Config) [Rewrite Universe]
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Rewrite Universe]
 -> ExceptT PluginError (LspM Config) [Rewrite Universe])
-> IO [Rewrite Universe]
-> ExceptT PluginError (LspM Config) [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$ Annotated ParsedSource -> RealSrcSpan -> IO [Rewrite Universe]
forall a l.
Data a =>
Annotated (GenLocated l a) -> RealSrcSpan -> IO [Rewrite Universe]
constructInlineFromIdentifer Annotated ParsedSource
astSrc RealSrcSpan
fromRange
    Bool
-> ExceptT PluginError (LspM Config) ()
-> ExceptT PluginError (LspM Config) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Rewrite Universe] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Rewrite Universe]
inlineRewrite) (ExceptT PluginError (LspM Config) ()
 -> ExceptT PluginError (LspM Config) ())
-> ExceptT PluginError (LspM Config) ()
-> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ PluginError -> ExceptT PluginError (LspM Config) ()
forall a. PluginError -> ExceptT PluginError (LspM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError (LspM Config) ())
-> PluginError -> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"Empty rewrite"
    (HscEnvEq
session, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"retrie" IdeState
state (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$
      GhcSessionDeps
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
    (FixityEnv
fixityEnv, CPP (Annotated ParsedSource)
cpp) <- IO (FixityEnv, CPP (Annotated ParsedSource))
-> ExceptT
     PluginError (LspM Config) (FixityEnv, CPP (Annotated ParsedSource))
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FixityEnv, CPP (Annotated ParsedSource))
 -> ExceptT
      PluginError
      (LspM Config)
      (FixityEnv, CPP (Annotated ParsedSource)))
-> IO (FixityEnv, CPP (Annotated ParsedSource))
-> ExceptT
     PluginError (LspM Config) (FixityEnv, CPP (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ IdeState
-> HscEnv -> String -> IO (FixityEnv, CPP (Annotated ParsedSource))
getCPPmodule IdeState
state (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) (String -> IO (FixityEnv, CPP (Annotated ParsedSource)))
-> String -> IO (FixityEnv, CPP (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
    Either SomeException ((), CPP (Annotated ParsedSource), Change)
result <- IO
  (Either SomeException ((), CPP (Annotated ParsedSource), Change))
-> ExceptT
     PluginError
     (LspM Config)
     (Either SomeException ((), CPP (Annotated ParsedSource), Change))
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either SomeException ((), CPP (Annotated ParsedSource), Change))
 -> ExceptT
      PluginError
      (LspM Config)
      (Either SomeException ((), CPP (Annotated ParsedSource), Change)))
-> IO
     (Either SomeException ((), CPP (Annotated ParsedSource), Change))
-> ExceptT
     PluginError
     (LspM Config)
     (Either SomeException ((), CPP (Annotated ParsedSource), Change))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(?callStack::CallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException (IO ((), CPP (Annotated ParsedSource), Change)
 -> IO
      (Either SomeException ((), CPP (Annotated ParsedSource), Change)))
-> IO ((), CPP (Annotated ParsedSource), Change)
-> IO
     (Either SomeException ((), CPP (Annotated ParsedSource), Change))
forall a b. (a -> b) -> a -> b
$
        FixityEnv
-> Retrie ()
-> CPP (Annotated ParsedSource)
-> IO ((), CPP (Annotated ParsedSource), Change)
forall a.
FixityEnv
-> Retrie a
-> CPP (Annotated ParsedSource)
-> IO (a, CPP (Annotated ParsedSource), Change)
runRetrie FixityEnv
fixityEnv (ContextUpdater -> [Rewrite Universe] -> Retrie ()
applyWithUpdate Context -> Int -> a -> TransformT m Context
GenericCU (TransformT m) Context
ContextUpdater
myContextUpdater [Rewrite Universe]
inlineRewrite) CPP (Annotated ParsedSource)
cpp
    case Either SomeException ((), CPP (Annotated ParsedSource), Change)
result of
        Left SomeException
err -> PluginError -> ExceptT PluginError (LspM Config) (Value |? Null)
forall a. PluginError -> ExceptT PluginError (LspM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError (LspM Config) (Value |? Null))
-> PluginError -> ExceptT PluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ Text
"Retrie - crashed with: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
        Right (()
_,CPP (Annotated ParsedSource)
_,Change
NoChange) -> PluginError -> ExceptT PluginError (LspM Config) (Value |? Null)
forall a. PluginError -> ExceptT PluginError (LspM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError (LspM Config) (Value |? Null))
-> PluginError -> ExceptT PluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"Retrie - inline produced no changes"
        Right (()
_,CPP (Annotated ParsedSource)
_,Change [Replacement]
replacements [AnnotatedImports]
imports) -> do
            let edits :: Map Uri [TextEdit]
edits = [(Uri, TextEdit)] -> Map Uri [TextEdit]
asEditMap ([(Uri, TextEdit)] -> Map Uri [TextEdit])
-> [(Uri, TextEdit)] -> Map Uri [TextEdit]
forall a b. (a -> b) -> a -> b
$ Change -> [(Uri, TextEdit)]
asTextEdits (Change -> [(Uri, TextEdit)]) -> Change -> [(Uri, TextEdit)]
forall a b. (a -> b) -> a -> b
$ [Replacement] -> [AnnotatedImports] -> Change
Change [Replacement]
ourReplacement [AnnotatedImports]
imports
                wedit :: WorkspaceEdit
wedit = Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just Map Uri [TextEdit]
edits) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
                ourReplacement :: [Replacement]
ourReplacement = [ Replacement
r
                    | r :: Replacement
r@Replacement{String
SrcSpan
replLocation :: SrcSpan
replOriginal :: String
replReplacement :: String
replLocation :: Replacement -> SrcSpan
replOriginal :: Replacement -> String
replReplacement :: Replacement -> String
..} <- [Replacement]
replacements
                    , RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
intoRange Maybe BufSpan
forall a. Maybe a
Nothing SrcSpan -> SrcSpan -> Bool
`GHC.isSubspanOf` SrcSpan
replLocation]
            LspId 'Method_WorkspaceApplyEdit
_ <- LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT
      PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit))
-> LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit
                (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Value |? Null)
 -> ExceptT PluginError (LspM Config) (Value |? Null))
-> (Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null

-- Override to skip adding binders to the context, which prevents inlining
-- nested defined functions
myContextUpdater :: ContextUpdater
myContextUpdater :: ContextUpdater
myContextUpdater Context
c Int
i =
    Context -> Int -> a -> TransformT m Context
GenericCU (TransformT m) Context
ContextUpdater
updateContext Context
c Int
i
    (a -> TransformT m Context)
-> (HsExpr GhcPs -> TransformT m Context)
-> a
-> TransformT m Context
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (Context -> TransformT m Context
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TransformT m Context)
-> (HsExpr GhcPs -> Context)
-> HsExpr GhcPs
-> TransformT m Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> Context
updExp)
    (a -> TransformT m Context)
-> (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> TransformT m Context)
-> a
-> TransformT m Context
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (forall a (m :: * -> *). Monad m => a -> TransformT m Context
skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs)))
    (a -> TransformT m Context)
-> (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> TransformT m Context)
-> a
-> TransformT m Context
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`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
_ = Context -> TransformT m Context
forall a. a -> TransformT m 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 = HasPrec $ Retrie.Fixity (SourceText "HsApp") (10 + i - firstChild) 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 = HasPrec $ lookupOp op (ctxtFixityEnv c) }
    updExp HsExpr GhcPs
_ = Context
c { ctxtParentPrec = 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 :: ModSummary -> Module
ms_mod :: Module
ms_mod} [HsBindLR GhcRn GhcRn]
topLevelBinds (Unfold String
thing)
  | Just FunBind {MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches}
  <- (HsBindLR GhcRn GhcRn -> Bool)
-> [HsBindLR GhcRn GhcRn] -> Maybe (HsBindLR GhcRn GhcRn)
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 (Name -> Text
forall a. Outputable a => a -> Text
printOutputable Name
n) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
thing ; HsBindLR GhcRn GhcRn
_ -> Bool
False) [HsBindLR GhcRn GhcRn]
topLevelBinds
  , [Name]
names <- (Name -> Bool) -> GenericQ [Name]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify Name -> Bool
p MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fun_matches
  =
    [ AddImport {Bool
String
Maybe String
Maybe (IE String)
ideclSource :: Bool
ideclQualifiedBool :: Bool
ideclAsString :: Maybe String
ideclThing :: Maybe (IE String)
ideclNameString :: String
ideclNameString :: String
ideclSource :: Bool
ideclQualifiedBool :: Bool
ideclAsString :: Maybe String
ideclThing :: Maybe (IE String)
..}
    | 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 (ModuleName -> String)
-> ((ModuleName, OccName) -> ModuleName)
-> (ModuleName, OccName)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, OccName) -> ModuleName
forall a b. (a, b) -> a
fst ((ModuleName, OccName) -> String)
-> Maybe (ModuleName, OccName) -> Maybe String
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 = IE String -> Maybe (IE String)
forall a. a -> Maybe a
Just (String -> IE String
forall name. name -> IE name
IEVar (String -> IE String) -> String -> IE String
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
r),
        Just String
ideclNameString <-
        [ModuleName -> String
moduleNameString (ModuleName -> String)
-> (Module -> ModuleName) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (Module -> String) -> Maybe Module -> Maybe String
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 Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod
-- TODO handle imports for all rewrites
extractImports ModSummary
_ [HsBindLR GhcRn GhcRn]
_ RewriteSpec
_ = []

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

provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
provider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
provider IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ (TextDocumentIdentifier Uri
uri) Range
range CodeActionContext
ca) = do
  let (LSP.CodeActionContext [Diagnostic]
_diags Maybe [CodeActionKind]
_monly Maybe CodeActionTriggerKind
_) = CodeActionContext
ca
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri

  (ModSummary{Module
ms_mod :: ModSummary -> Module
ms_mod :: Module
ms_mod}, [HsBindLR GhcRn GhcRn]
topLevelBinds, PositionMapping
posMapping, [GenLocated SrcSpanAnnA (RuleDecls GhcRn)]
hs_ruleds, [TyClGroup GhcRn]
hs_tyclds)
    <- String
-> IdeState
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
-> ExceptT
     PluginError
     (LspM Config)
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"retrie" IdeState
state (ExceptT
   PluginError
   Action
   (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
    [LRuleDecls GhcRn], [TyClGroup GhcRn])
 -> ExceptT
      PluginError
      (LspM Config)
      (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
       [LRuleDecls GhcRn], [TyClGroup GhcRn]))
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
-> ExceptT
     PluginError
     (LspM Config)
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
forall a b. (a -> b) -> a -> b
$
        NormalizedFilePath
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
getBinds NormalizedFilePath
nfp

  extras :: ShakeExtras
extras@ShakeExtras{ WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb :: WithHieDb
withHieDb, HieDbWriter
$sel:hiedbWriter:ShakeExtras :: ShakeExtras -> HieDbWriter
hiedbWriter :: HieDbWriter
hiedbWriter } <- IO ShakeExtras -> ExceptT PluginError (LspM Config) ShakeExtras
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ShakeExtras -> ExceptT PluginError (LspM Config) ShakeExtras)
-> IO ShakeExtras -> ExceptT PluginError (LspM Config) ShakeExtras
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action ShakeExtras -> IO ShakeExtras
forall a. String -> IdeState -> Action a -> IO a
runAction String
"" IdeState
state Action ShakeExtras
getShakeExtras

  Range
range <- PositionMapping -> Range -> ExceptT PluginError (LspM Config) Range
forall (m :: * -> *).
Monad m =>
PositionMapping -> Range -> ExceptT PluginError m Range
fromCurrentRangeE PositionMapping
posMapping Range
range
  let pos :: Position
pos = Range
range Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start
  let rewrites :: [(Text, CodeActionKind, RunRetrieParams)]
rewrites =
        (HsBindLR GhcRn GhcRn -> [(Text, CodeActionKind, RunRetrieParams)])
-> [HsBindLR GhcRn GhcRn]
-> [(Text, CodeActionKind, RunRetrieParams)]
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
          [(Text, CodeActionKind, RunRetrieParams)]
-> [(Text, CodeActionKind, RunRetrieParams)]
-> [(Text, CodeActionKind, RunRetrieParams)]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpanAnnA (RuleDecls GhcRn)
 -> [(Text, CodeActionKind, RunRetrieParams)])
-> [GenLocated SrcSpanAnnA (RuleDecls GhcRn)]
-> [(Text, CodeActionKind, RunRetrieParams)]
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
          [(Text, CodeActionKind, RunRetrieParams)]
-> [(Text, CodeActionKind, RunRetrieParams)]
-> [(Text, CodeActionKind, RunRetrieParams)]
forall a. [a] -> [a] -> [a]
++ [ (Text, CodeActionKind, RunRetrieParams)
r
               | TyClGroup {[LTyClDecl GhcRn]
group_tyclds :: [LTyClDecl GhcRn]
group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds} <- [TyClGroup GhcRn]
hs_tyclds,
                 L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
l) TyClDecl GhcRn
g <- [LTyClDecl GhcRn]
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
group_tyclds,
                 Position
pos Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
l,
                 (Text, CodeActionKind, RunRetrieParams)
r <- Uri
-> Module
-> TyClDecl GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites Uri
uri Module
ms_mod TyClDecl GhcRn
g
             ]

  [CodeAction]
retrieCommands <- LspM Config [CodeAction]
-> ExceptT PluginError (LspM Config) [CodeAction]
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config [CodeAction]
 -> ExceptT PluginError (LspM Config) [CodeAction])
-> LspM Config [CodeAction]
-> ExceptT PluginError (LspM Config) [CodeAction]
forall a b. (a -> b) -> a -> b
$
    [(Text, CodeActionKind, RunRetrieParams)]
-> ((Text, CodeActionKind, RunRetrieParams)
    -> LspT Config IO CodeAction)
-> LspM Config [CodeAction]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, CodeActionKind, RunRetrieParams)]
rewrites (((Text, CodeActionKind, RunRetrieParams)
  -> LspT Config IO CodeAction)
 -> LspM Config [CodeAction])
-> ((Text, CodeActionKind, RunRetrieParams)
    -> LspT Config IO CodeAction)
-> LspM Config [CodeAction]
forall a b. (a -> b) -> a -> b
$ \(Text
title, CodeActionKind
kind, RunRetrieParams
params) -> IO CodeAction -> LspT Config IO CodeAction
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CodeAction -> LspT Config IO CodeAction)
-> IO CodeAction -> LspT Config IO CodeAction
forall a b. (a -> b) -> a -> b
$ do
      let c :: Command
c = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
retrieCommandId Text
title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [RunRetrieParams -> Value
forall a. ToJSON a => a -> Value
toJSON RunRetrieParams
params])
      CodeAction -> IO CodeAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CodeAction -> IO CodeAction) -> CodeAction -> IO CodeAction
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== Text) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
CodeAction Text
title (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
kind) Maybe [Diagnostic]
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
c) Maybe Value
forall a. Maybe a
Nothing

  [Command]
inlineSuggestions <- IO [Command] -> ExceptT PluginError (LspM Config) [Command]
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Command] -> ExceptT PluginError (LspM Config) [Command])
-> IO [Command] -> ExceptT PluginError (LspM Config) [Command]
forall a b. (a -> b) -> a -> b
$ String -> ShakeExtras -> IdeAction [Command] -> IO [Command]
forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"" ShakeExtras
extras (IdeAction [Command] -> IO [Command])
-> IdeAction [Command] -> IO [Command]
forall a b. (a -> b) -> a -> b
$
    PluginId
-> Uri
-> [HsBindLR GhcRn GhcRn]
-> Range
-> WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> IdeAction [Command]
suggestBindInlines PluginId
plId Uri
uri [HsBindLR GhcRn GhcRn]
topLevelBinds Range
range (HieDb -> IO a) -> IO a
WithHieDb
withHieDb (HieDbWriter
-> String
-> ModuleName
-> GenUnit UnitId
-> Bool
-> MaybeT IdeAction Uri
lookupMod HieDbWriter
hiedbWriter)
  let inlineCommands :: [Maybe CodeAction]
inlineCommands =
        [ CodeAction -> Maybe CodeAction
forall a. a -> Maybe a
Just (CodeAction -> Maybe CodeAction) -> CodeAction -> Maybe CodeAction
forall a b. (a -> b) -> a -> b
$
            Text
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== Text) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
CodeAction Text
_title (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_RefactorInline) Maybe [Diagnostic]
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
c) Maybe Value
forall a. Maybe a
Nothing
        | c :: Command
c@Command{Maybe [Value]
Text
_title :: Text
_command :: Text
_arguments :: Maybe [Value]
$sel:_arguments:Command :: Command -> Maybe [Value]
$sel:_command:Command :: Command -> Text
$sel:_title:Command :: Command -> Text
..} <- [Command]
inlineSuggestions
        ]
  ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Command |? CodeAction] |? Null)
 -> ExceptT
      PluginError (LspM Config) ([Command |? CodeAction] |? Null))
-> ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL [CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR CodeAction
c | CodeAction
c <- [CodeAction]
retrieCommands [CodeAction] -> [CodeAction] -> [CodeAction]
forall a. [a] -> [a] -> [a]
++ [Maybe CodeAction] -> [CodeAction]
forall a. [Maybe a] -> [a]
catMaybes [Maybe CodeAction]
inlineCommands]

getLocationUri :: Location -> Uri
getLocationUri :: Location -> Uri
getLocationUri Location{Uri
_uri :: Uri
$sel:_uri:Location :: Location -> Uri
_uri} = Uri
_uri

getLocationRange :: Location -> Range
getLocationRange :: Location -> Range
getLocationRange Location{Range
_range :: Range
$sel:_range:Location :: Location -> Range
_range} = Range
_range

getBinds :: NormalizedFilePath -> ExceptT PluginError Action
  ( ModSummary
  , [HsBindLR GhcRn GhcRn]
  , PositionMapping
  , [LRuleDecls GhcRn]
  , [TyClGroup GhcRn]
  )
getBinds :: NormalizedFilePath
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [LRuleDecls GhcRn], [TyClGroup GhcRn])
getBinds NormalizedFilePath
nfp = do
  (TcModuleResult
tm, PositionMapping
posMapping) <- TypeCheck
-> NormalizedFilePath
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE 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
  case RenamedSource
rn of
    (HsGroup{HsValBinds GhcRn
hs_valds :: HsValBinds GhcRn
hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds, [LRuleDecls GhcRn]
hs_ruleds :: [LRuleDecls GhcRn]
hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds, [TyClGroup GhcRn]
hs_tyclds :: [TyClGroup GhcRn]
hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds}, [LImportDecl GhcRn]
_, Maybe [(LIE GhcRn, Avails)]
_, Maybe (LHsDoc GhcRn)
_) -> do
      [HsBindLR GhcRn GhcRn]
topLevelBinds <- case HsValBinds GhcRn
hs_valds of
        ValBinds{} -> PluginError -> ExceptT PluginError Action [HsBindLR GhcRn GhcRn]
forall a. PluginError -> ExceptT PluginError Action a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError Action [HsBindLR GhcRn GhcRn])
-> PluginError -> ExceptT PluginError Action [HsBindLR GhcRn GhcRn]
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"getBinds: ValBinds not supported"
        XValBindsLR (GHC.NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
_sigs :: GHC.NHsValBindsLR GhcRn) ->
          [HsBindLR GhcRn GhcRn]
-> ExceptT PluginError Action [HsBindLR GhcRn GhcRn]
forall a. a -> ExceptT PluginError Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ HsBindLR GhcRn GhcRn
decl
               | (RecFlag
_, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
bagBinds) <- [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
binds
               , L SrcSpanAnnA
_ HsBindLR GhcRn GhcRn
decl <- Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
bagBinds
               ]
      (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
 [GenLocated SrcSpanAnnA (RuleDecls GhcRn)], [TyClGroup GhcRn])
-> ExceptT
     PluginError
     Action
     (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping,
      [GenLocated SrcSpanAnnA (RuleDecls GhcRn)], [TyClGroup GhcRn])
forall a. a -> ExceptT PluginError Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tm, [HsBindLR GhcRn GhcRn]
topLevelBinds, PositionMapping
posMapping, [LRuleDecls GhcRn]
[GenLocated SrcSpanAnnA (RuleDecls 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 (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
l') Name
rdrName}
  | Position
pos Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
l' =
    let pprNameText :: Text
pprNameText = Name -> Text
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 (Module -> ShowS
forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
                description :: Text
description = Text
"Unfold " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pprNameText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
            in (Text
description, CodeActionKind
CodeActionKind_RefactorInline, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
rewrites :: [RewriteSpec]
description :: Text
..})
        foldRewrite :: Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
restrictToOriginatingFile =
          let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
Fold (Module -> ShowS
forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
              description :: Text
description = Text
"Fold " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pprNameText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
           in (Text
description, CodeActionKind
CodeActionKind_RefactorExtract, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
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
    -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri)
    -> IdeAction [Command]
suggestBindInlines :: PluginId
-> Uri
-> [HsBindLR GhcRn GhcRn]
-> Range
-> WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> IdeAction [Command]
suggestBindInlines PluginId
plId Uri
_uri [HsBindLR GhcRn GhcRn]
binds Range
range WithHieDb
hie String
-> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri
lookupMod = do
    HashSet (OccName, Location, Location)
identifiers <- IdeAction (HashSet (OccName, Location, Location))
definedIdentifiers
    [Command] -> IdeAction [Command]
forall a. a -> IdeAction a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Command] -> IdeAction [Command])
-> [Command] -> IdeAction [Command]
forall a b. (a -> b) -> a -> b
$ ((OccName, Location, Location) -> Command)
-> [(OccName, Location, Location)] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map (\(OccName
name, Location
siteLoc, Location
srcLoc) ->
        let
            title :: Text
title = Text
"Inline " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
printedName
            printedName :: Text
printedName = OccName -> Text
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 CommandId
retrieInlineThisCommandId Text
title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [RunRetrieInlineThisParams -> Value
forall a. ToJSON a => a -> Value
toJSON RunRetrieInlineThisParams
params])
        )
        (HashSet (OccName, Location, Location)
-> [(OccName, Location, Location)]
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
        (IdeAction (HashSet (OccName, Location, Location))
 -> IdeAction (HashSet (OccName, Location, Location))
 -> IdeAction (HashSet (OccName, Location, Location)))
-> GenericQ (IdeAction (HashSet (OccName, Location, Location)))
-> GenericQ (IdeAction (HashSet (OccName, Location, Location)))
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything IdeAction (HashSet (OccName, Location, Location))
-> IdeAction (HashSet (OccName, Location, Location))
-> IdeAction (HashSet (OccName, Location, Location))
forall a. Semigroup a => a -> a -> a
(<>) (HashSet (OccName, Location, Location)
-> IdeAction (HashSet (OccName, Location, Location))
forall a. a -> IdeAction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet (OccName, Location, Location)
forall a. Monoid a => a
mempty IdeAction (HashSet (OccName, Location, Location))
-> (GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
    -> IdeAction (HashSet (OccName, Location, Location)))
-> a
-> IdeAction (HashSet (OccName, Location, Location))
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> GRHSs GhcRn (LHsExpr GhcRn)
-> IdeAction (HashSet (OccName, Location, Location))
getGRHSIdentifierDetails (HieDb -> IO a) -> IO a
WithHieDb
hie String
-> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri
lookupMod) [HsBindLR GhcRn GhcRn]
binds

      getGRHSIdentifierDetails ::
        WithHieDb
        -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri)
        -> GRHSs GhcRn (LHsExpr GhcRn)
        -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))
      getGRHSIdentifierDetails :: WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> GRHSs GhcRn (LHsExpr GhcRn)
-> IdeAction (HashSet (OccName, Location, Location))
getGRHSIdentifierDetails WithHieDb
a String
-> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri
b it :: GRHSs GhcRn (LHsExpr GhcRn)
it@GRHSs{} =
        -- we only select candidates for which we have source code
        (IdeAction (HashSet (OccName, Location, Location))
 -> IdeAction (HashSet (OccName, Location, Location))
 -> IdeAction (HashSet (OccName, Location, Location)))
-> GenericQ (IdeAction (HashSet (OccName, Location, Location)))
-> GenericQ (IdeAction (HashSet (OccName, Location, Location)))
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything IdeAction (HashSet (OccName, Location, Location))
-> IdeAction (HashSet (OccName, Location, Location))
-> IdeAction (HashSet (OccName, Location, Location))
forall a. Semigroup a => a -> a -> a
(<>) (HashSet (OccName, Location, Location)
-> IdeAction (HashSet (OccName, Location, Location))
forall a. a -> IdeAction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet (OccName, Location, Location)
forall a. Monoid a => a
mempty IdeAction (HashSet (OccName, Location, Location))
-> (GenLocated SrcSpanAnnN Name
    -> IdeAction (HashSet (OccName, Location, Location)))
-> a
-> IdeAction (HashSet (OccName, Location, Location))
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> LIdP GhcRn
-> IdeAction (HashSet (OccName, Location, Location))
getDefinedIdentifierDetailsViaHieDb (HieDb -> IO a) -> IO a
WithHieDb
a String
-> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri
b) GRHSs GhcRn (LHsExpr GhcRn)
GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
it

      getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))
      getDefinedIdentifierDetailsViaHieDb :: WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> LIdP GhcRn
-> IdeAction (HashSet (OccName, Location, Location))
getDefinedIdentifierDetailsViaHieDb WithHieDb
withHieDb String
-> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri
lookupModule LIdP GhcRn
lname | Name
name <- GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
lname =
        case SrcSpan -> Maybe Location
srcSpanToLocation (GenLocated SrcSpanAnnN Name -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LIdP GhcRn
GenLocated SrcSpanAnnN Name
lname) of
            Just Location
siteLoc
              | Range
siteRange <- Location -> Range
getLocationRange Location
siteLoc
              , Range
range Range -> Range -> Bool
`isSubrangeOf` Range
siteRange -> do
                    Maybe [Location]
mbSrcLocation <- WithHieDb
-> (String
    -> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri)
-> Name
-> IdeAction (Maybe [Location])
forall (m :: * -> *).
MonadIO m =>
WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])
nameToLocation (HieDb -> IO a) -> IO a
WithHieDb
withHieDb String
-> ModuleName -> GenUnit UnitId -> Bool -> MaybeT IdeAction Uri
lookupModule Name
name
                    HashSet (OccName, Location, Location)
-> IdeAction (HashSet (OccName, Location, Location))
forall a. a -> IdeAction a
forall (m :: * -> *) a. Monad m => a -> m a
return (HashSet (OccName, Location, Location)
 -> IdeAction (HashSet (OccName, Location, Location)))
-> HashSet (OccName, Location, Location)
-> IdeAction (HashSet (OccName, Location, Location))
forall a b. (a -> b) -> a -> b
$ HashSet (OccName, Location, Location)
-> ([Location] -> HashSet (OccName, Location, Location))
-> Maybe [Location]
-> HashSet (OccName, Location, Location)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashSet (OccName, Location, Location)
forall a. Monoid a => a
mempty ([(OccName, Location, Location)]
-> HashSet (OccName, Location, Location)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([(OccName, Location, Location)]
 -> HashSet (OccName, Location, Location))
-> ([Location] -> [(OccName, Location, Location)])
-> [Location]
-> HashSet (OccName, Location, Location)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> (OccName, Location, Location))
-> [Location] -> [(OccName, Location, Location)]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> OccName
nameOccName Name
name, Location
siteLoc,)) Maybe [Location]
mbSrcLocation
            Maybe Location
_ -> HashSet (OccName, Location, Location)
-> IdeAction (HashSet (OccName, Location, Location))
forall a. a -> IdeAction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet (OccName, Location, Location)
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 ::
  Uri ->
  GHC.Module ->
  TyClDecl GhcRn ->
  [(T.Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites :: Uri
-> Module
-> TyClDecl GhcRn
-> [(Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites Uri
originatingFile Module
ms_mod SynDecl {LIdP GhcRn
tcdLName :: LIdP GhcRn
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName} =
    let pprNameText :: Text
pprNameText = Name -> Text
forall a. Outputable a => a -> Text
printOutputable (XRec (GhcPass Any) Name -> Name
forall (pass :: Pass) a. XRec (GhcPass pass) a -> a
unLocA XRec (GhcPass Any) Name
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 (Module -> ShowS
forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
                description :: Text
description = Text
"Unfold " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pprNameText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
           in (Text
description, CodeActionKind
CodeActionKind_RefactorInline, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
rewrites :: [RewriteSpec]
description :: Text
..})
        foldRewrite :: Bool -> (Text, CodeActionKind, RunRetrieParams)
foldRewrite Bool
restrictToOriginatingFile =
          let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
TypeBackward (Module -> ShowS
forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
pprName)]
              description :: Text
description = Text
"Fold " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pprNameText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
           in (Text
description, CodeActionKind
CodeActionKind_RefactorExtract, RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
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 :: forall pass. RuleDecls pass -> [LRuleDecl pass]
rds_rules :: [LRuleDecl GhcRn]
rds_rules}) =
    [[(Text, CodeActionKind, RunRetrieParams)]]
-> [(Text, CodeActionKind, RunRetrieParams)]
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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
l) RuleDecl GhcRn
r  <- [LRuleDecl GhcRn]
[GenLocated SrcSpanAnnA (RuleDecl GhcRn)]
rds_rules,
          Position
pos Position -> SrcSpan -> Bool
`isInsideSrcSpan` SrcSpan
l,
#if MIN_VERSION_ghc(9,5,0)
          let HsRule {rd_name :: forall pass. RuleDecl pass -> XRec pass RuleName
rd_name = L SrcAnn NoEpAnns
_ RuleName
rn} = RuleDecl GhcRn
r,
#else
          let HsRule {rd_name = L _ (_, rn)} = 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 (Module -> ShowS
forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
ruleName)]
            description :: Text
description = Text
"Apply rule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
ruleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" forward" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Bool -> Text
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile

        in ( Text
description,
            CodeActionKind
CodeActionKind_Refactor,
            RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
rewrites :: [RewriteSpec]
description :: Text
..}
            )
    backwardsRewrite :: String -> Bool -> (Text, CodeActionKind, RunRetrieParams)
backwardsRewrite String
ruleName Bool
restrictToOriginatingFile =
          let rewrites :: [RewriteSpec]
rewrites = [String -> RewriteSpec
RuleBackward (Module -> ShowS
forall mod. Outputable mod => mod -> ShowS
qualify Module
ms_mod String
ruleName)]
              description :: Text
description = Text
"Apply rule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
ruleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" backwards" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                              Bool -> Text
forall p. IsString p => Bool -> p
describeRestriction Bool
restrictToOriginatingFile
           in ( Text
description,
                CodeActionKind
CodeActionKind_Refactor,
                RunRetrieParams {Bool
[RewriteSpec]
Text
Uri
description :: Text
rewrites :: [RewriteSpec]
originatingFile :: Uri
restrictToOriginatingFile :: Bool
originatingFile :: Uri
restrictToOriginatingFile :: Bool
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 (mod -> Text
forall a. Outputable a => a -> Text
printOutputable mod
ms_mod) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
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
(CallRetrieError -> CallRetrieError -> Bool)
-> (CallRetrieError -> CallRetrieError -> Bool)
-> Eq CallRetrieError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallRetrieError -> CallRetrieError -> Bool
== :: CallRetrieError -> CallRetrieError -> Bool
$c/= :: CallRetrieError -> CallRetrieError -> Bool
/= :: CallRetrieError -> CallRetrieError -> Bool
Eq, Typeable)

instance Show CallRetrieError where
  show :: CallRetrieError -> String
show (CallRetrieInternalError String
msg NormalizedFilePath
f) = String
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f
  show (NoParse NormalizedFilePath
f) = String
"Cannot parse: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f
  show (GHCParseError NormalizedFilePath
f String
m) = String
"Cannot parse " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
m
  show (NoTypeCheck NormalizedFilePath
f) = String
"File does not typecheck: " String -> ShowS
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 (KnownTargets -> HashSet NormalizedFilePath)
-> (Hashed KnownTargets -> KnownTargets)
-> Hashed KnownTargets
-> HashSet NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hashed KnownTargets -> KnownTargets
forall a. Hashed a -> a
unhashed (Hashed KnownTargets -> HashSet NormalizedFilePath)
-> IO (Hashed KnownTargets) -> IO (HashSet NormalizedFilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Hashed KnownTargets) -> IO (Hashed KnownTargets)
forall a. TVar a -> IO a
readTVarIO (ShakeExtras -> TVar (Hashed KnownTargets)
knownTargetsVar (ShakeExtras -> TVar (Hashed KnownTargets))
-> ShakeExtras -> TVar (Hashed KnownTargets)
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 = (String
-> Options_
     [Rewrite Universe]
     (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall rewrites imports.
(Default rewrites, Default imports) =>
String -> Options_ rewrites imports
defaultOptions String
target)
        {Retrie.verbosity = Loud
        ,Retrie.targetFiles = map fromNormalizedFilePath $
            if restrictToOriginatingFile
                then [origin]
                else Set.toList knownFiles
        }

      ([ImportSpec]
theImports, [RewriteSpec]
theRewrites) = [Either ImportSpec RewriteSpec] -> ([ImportSpec], [RewriteSpec])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ImportSpec RewriteSpec]
rewrites

      annotatedImports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
annotatedImports =
        [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> Int -> Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall ast. ast -> Int -> Annotated ast
unsafeMkA ((ImportSpec -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [ImportSpec] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a an. a -> LocatedAn an a
noLocA (ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> (ImportSpec -> ImportDecl GhcPs)
-> ImportSpec
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportSpec -> ImportDecl GhcPs
toImportDecl) [ImportSpec]
theImports) Int
0

  (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 Retrie () -> Retrie () -> Retrie ()
forall a b. Retrie a -> Retrie b -> Retrie b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AnnotatedImports -> Retrie ()
addImports AnnotatedImports
Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
annotatedImports)
      ([Rewrite Universe] -> Retrie ())
-> IO [Rewrite Universe] -> IO (Retrie ())
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 <- Options_
  [Rewrite Universe]
  (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> [GroundTerms] -> IO [String]
forall a b. Options_ a b -> [GroundTerms] -> IO [String]
getTargetFiles Options
Options_
  [Rewrite Universe]
  (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
retrieOptions (Retrie () -> [GroundTerms]
forall a. Retrie a -> [GroundTerms]
getGroundTerms Retrie ()
retrie)

  [Either CallRetrieError [(Uri, TextEdit)]]
results <- [String]
-> (String -> IO (Either CallRetrieError [(Uri, TextEdit)]))
-> IO [Either CallRetrieError [(Uri, TextEdit)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
targets ((String -> IO (Either CallRetrieError [(Uri, TextEdit)]))
 -> IO [Either CallRetrieError [(Uri, TextEdit)]])
-> (String -> IO (Either CallRetrieError [(Uri, TextEdit)]))
-> IO [Either CallRetrieError [(Uri, TextEdit)]]
forall a b. (a -> b) -> a -> b
$ \String
t -> ExceptT CallRetrieError IO [(Uri, TextEdit)]
-> IO (Either CallRetrieError [(Uri, TextEdit)])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CallRetrieError IO [(Uri, TextEdit)]
 -> IO (Either CallRetrieError [(Uri, TextEdit)]))
-> ExceptT CallRetrieError IO [(Uri, TextEdit)]
-> IO (Either CallRetrieError [(Uri, TextEdit)])
forall a b. (a -> b) -> a -> b
$ do
    (FixityEnv
fixityEnv, CPP (Annotated ParsedSource)
cpp) <- IO
  (Either CallRetrieError (FixityEnv, CPP (Annotated ParsedSource)))
-> ExceptT
     CallRetrieError IO (FixityEnv, CPP (Annotated ParsedSource))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
   (Either CallRetrieError (FixityEnv, CPP (Annotated ParsedSource)))
 -> ExceptT
      CallRetrieError IO (FixityEnv, CPP (Annotated ParsedSource)))
-> IO
     (Either CallRetrieError (FixityEnv, CPP (Annotated ParsedSource)))
-> ExceptT
     CallRetrieError IO (FixityEnv, CPP (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ IO (FixityEnv, CPP (Annotated ParsedSource))
-> IO
     (Either CallRetrieError (FixityEnv, CPP (Annotated ParsedSource)))
forall (m :: * -> *) e a.
(?callStack::CallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO (FixityEnv, CPP (Annotated ParsedSource))
 -> IO
      (Either CallRetrieError (FixityEnv, CPP (Annotated ParsedSource))))
-> IO (FixityEnv, CPP (Annotated ParsedSource))
-> IO
     (Either CallRetrieError (FixityEnv, CPP (Annotated ParsedSource)))
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)) <-
      IO ((), CPP (Annotated ParsedSource), Change)
-> ExceptT
     CallRetrieError IO ((), CPP (Annotated ParsedSource), Change)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT CallRetrieError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ((), CPP (Annotated ParsedSource), Change)
 -> ExceptT
      CallRetrieError IO ((), CPP (Annotated ParsedSource), Change))
-> IO ((), CPP (Annotated ParsedSource), Change)
-> ExceptT
     CallRetrieError IO ((), CPP (Annotated ParsedSource), Change)
forall a b. (a -> b) -> a -> b
$ FixityEnv
-> Retrie ()
-> CPP (Annotated ParsedSource)
-> IO ((), CPP (Annotated ParsedSource), Change)
forall a.
FixityEnv
-> Retrie a
-> CPP (Annotated ParsedSource)
-> IO (a, CPP (Annotated ParsedSource), Change)
runRetrie FixityEnv
fixityEnv Retrie ()
retrie CPP (Annotated ParsedSource)
cpp
    [(Uri, TextEdit)] -> ExceptT CallRetrieError IO [(Uri, TextEdit)]
forall a. a -> ExceptT CallRetrieError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Uri, TextEdit)] -> ExceptT CallRetrieError IO [(Uri, TextEdit)])
-> [(Uri, TextEdit)]
-> ExceptT CallRetrieError IO [(Uri, TextEdit)]
forall a b. (a -> b) -> a -> b
$ Change -> [(Uri, TextEdit)]
asTextEdits Change
change

  let ([CallRetrieError]
errors :: [CallRetrieError], [[(Uri, TextEdit)]]
replacements) = [Either CallRetrieError [(Uri, TextEdit)]]
-> ([CallRetrieError], [[(Uri, TextEdit)]])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CallRetrieError [(Uri, TextEdit)]]
results
      editParams :: WorkspaceEdit
      editParams :: WorkspaceEdit
editParams =
        Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit]))
-> Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> a -> b
$ [(Uri, TextEdit)] -> Map Uri [TextEdit]
asEditMap ([(Uri, TextEdit)] -> Map Uri [TextEdit])
-> [(Uri, TextEdit)] -> Map Uri [TextEdit]
forall a b. (a -> b) -> a -> b
$ [[(Uri, TextEdit)]] -> [(Uri, TextEdit)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Uri, TextEdit)]]
replacements) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing

  ([CallRetrieError], WorkspaceEdit)
-> IO ([CallRetrieError], WorkspaceEdit)
forall a. a -> IO a
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 =
  String
-> IdeState -> r -> NormalizedFilePath -> IO (Maybe (RuleResult r))
forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
useRule String
lbl IdeState
state r
rule NormalizedFilePath
f IO (Maybe v) -> (Maybe v -> IO v) -> IO v
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO v -> (v -> IO v) -> Maybe v -> IO v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO v -> IO v
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO v -> IO v) -> IO v -> IO v
forall a b. (a -> b) -> a -> b
$ CallRetrieError -> IO v
forall (m :: * -> *) e a.
(?callStack::CallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (CallRetrieError -> IO v) -> CallRetrieError -> IO v
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> CallRetrieError
mkException NormalizedFilePath
f) v -> IO v
forall a. a -> IO a
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) <- ModIface -> [(OccName, 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} <-
        IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> GetModIface
-> NormalizedFilePath
-> IO (RuleResult GetModIface)
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 <- Annotated ast -> (ast -> TransformT IO ast) -> IO (Annotated ast)
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated ast
pm (FixityEnv -> ast -> TransformT IO ast
forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixities)
      (FixityEnv, Annotated ast) -> IO (FixityEnv, Annotated ast)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ast
res)

fixAnns :: ParsedModule -> Annotated GHC.ParsedSource
fixAnns :: ParsedModule -> Annotated ParsedSource
fixAnns GHC.ParsedModule{ParsedSource
pm_parsed_source :: ParsedModule -> ParsedSource
pm_parsed_source :: ParsedSource
pm_parsed_source} = ParsedSource -> Int -> Annotated ParsedSource
forall ast. ast -> Int -> Annotated ast
unsafeMkA (ParsedSource -> ParsedSource
forall ast. ExactPrint ast => ast -> ast
makeDeltaAst ParsedSource
pm_parsed_source) Int
0

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
  -- retrie needs the libdir for `parseRewriteSpecs`
  String
libdir <- DynFlags -> String
topDir (DynFlags -> String)
-> (ModSummaryResult -> DynFlags) -> ModSummaryResult -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags)
-> (ModSummaryResult -> ModSummary) -> ModSummaryResult -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummaryResult -> ModSummary
msrModSummary (ModSummaryResult -> String) -> IO ModSummaryResult -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> GetModSummary
-> NormalizedFilePath
-> IO (RuleResult GetModSummary)
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
  String
-> (String -> IO (CPP (Annotated ParsedSource)))
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite Universe]
parseRewriteSpecs
    String
libdir
    (\String
_f -> CPP (Annotated ParsedSource) -> IO (CPP (Annotated ParsedSource))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CPP (Annotated ParsedSource) -> IO (CPP (Annotated ParsedSource)))
-> CPP (Annotated ParsedSource)
-> IO (CPP (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ Annotated ParsedSource -> CPP (Annotated ParsedSource)
forall a. a -> CPP a
NoCPP Annotated ParsedSource
originParsedModule)
    FixityEnv
originFixities
    [RewriteSpec]
specs

constructfromFunMatches ::
  Annotated [GHCGHC.LocatedA (ImportDecl GhcPs)]
  -> GHCGHC.LocatedN GHCGHC.RdrName
  -> GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs))
  -> TransformT IO [Rewrite Universe]
constructfromFunMatches :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> LocatedN RdrName
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT IO [Rewrite Universe]
constructfromFunMatches Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps LocatedN RdrName
fun_id MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches = do
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
fe <- LocatedN RdrName -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar LocatedN RdrName
fun_id
    [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
rewrites <- [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
 -> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> TransformT
     IO [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> (GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> TransformT
     IO [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
unLoc (GenLocated
   SrcSpanAnnL
   [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fe AnnotatedImports
Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps Direction
LeftToRight)
    let urewrites :: [Rewrite Universe]
urewrites = Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Rewrite Universe)
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite Universe]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
rewrites
    -- traceShowM $ map showQuery urewrites
    Bool
-> TransformT IO [Rewrite Universe]
-> TransformT IO [Rewrite Universe]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Rewrite Universe] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Rewrite Universe]
urewrites) (TransformT IO [Rewrite Universe]
 -> TransformT IO [Rewrite Universe])
-> TransformT IO [Rewrite Universe]
-> TransformT IO [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$
        [Rewrite Universe] -> TransformT IO [Rewrite Universe]
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Rewrite Universe]
urewrites

-- showQuery :: Rewrite Universe -> String
-- showQuery = 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 = T.unpack . printOutputable . showAstData NoBlankSrcSpan
--         NoBlankEpAnnotations

constructInlineFromIdentifer :: Data a => Annotated (GenLocated l a) -> GHCGHC.RealSrcSpan -> IO [Rewrite Universe]
constructInlineFromIdentifer :: forall a l.
Data a =>
Annotated (GenLocated l a) -> RealSrcSpan -> IO [Rewrite Universe]
constructInlineFromIdentifer Annotated (GenLocated l a)
originParsedModule RealSrcSpan
originSpan = do
    -- traceM $ s $ astA originParsedModule
    (Annotated [Rewrite Universe] -> [Rewrite Universe])
-> IO (Annotated [Rewrite Universe]) -> IO [Rewrite Universe]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated [Rewrite Universe] -> [Rewrite Universe]
forall ast. Annotated ast -> ast
astA (IO (Annotated [Rewrite Universe]) -> IO [Rewrite Universe])
-> IO (Annotated [Rewrite Universe]) -> IO [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$ Annotated (GenLocated l a)
-> (GenLocated l a -> TransformT IO [Rewrite Universe])
-> IO (Annotated [Rewrite Universe])
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated (GenLocated l a)
originParsedModule ((GenLocated l a -> TransformT IO [Rewrite Universe])
 -> IO (Annotated [Rewrite Universe]))
-> (GenLocated l a -> TransformT IO [Rewrite Universe])
-> IO (Annotated [Rewrite Universe])
forall a b. (a -> b) -> a -> b
$ \(L l
_ a
m) -> do
        let ast :: First
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
ast = (First
   (LocatedN RdrName,
    MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> First
      (LocatedN RdrName,
       MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> First
      (LocatedN RdrName,
       MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GenericQ
     (First
        (LocatedN RdrName,
         MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GenericQ
     (First
        (LocatedN RdrName,
         MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything First
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Semigroup a => a -> a -> a
(<>) (Maybe
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a -> First a
First Maybe
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing First
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (HsBindLR GhcPs GhcPs
    -> First
         (LocatedN RdrName,
          MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> a
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` HsBindLR GhcPs GhcPs
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
matcher) a
m
            matcher :: HsBindLR GhcPs GhcPs
                -> First ( GHCGHC.LocatedN GHCGHC.RdrName
                         , GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs))
                         )
            matcher :: HsBindLR GhcPs GhcPs
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
matcher FunBind{LIdP GhcPs
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id :: LIdP GhcPs
fun_id, MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches}
                -- trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined
                | RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_ <- LocatedN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA LIdP GhcPs
LocatedN RdrName
fun_id
                , RealSrcSpan
sp RealSrcSpan -> RealSrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan
originSpan =
                Maybe
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a -> First a
First (Maybe
   (LocatedN RdrName,
    MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> First
      (LocatedN RdrName,
       MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ (LocatedN RdrName,
 MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just (LIdP GhcPs
LocatedN RdrName
fun_id, MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches)
            matcher HsBindLR GhcPs GhcPs
_ = Maybe
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> First
     (LocatedN RdrName,
      MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a -> First a
First Maybe
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing
        case First
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
ast of
            First (Just (LocatedN RdrName
fun_id, MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches))
                ->
                let imports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imports = Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. Monoid a => a
mempty in
                Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> LocatedN RdrName
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT IO [Rewrite Universe]
constructfromFunMatches Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imports LocatedN RdrName
fun_id MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fun_matches
            First
  (LocatedN RdrName,
   MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
_ -> [Rewrite Universe] -> TransformT IO [Rewrite Universe]
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rewrite Universe] -> TransformT IO [Rewrite Universe])
-> [Rewrite Universe] -> TransformT IO [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$ String -> [Rewrite Universe]
forall a. (?callStack::CallStack) => String -> a
error String
"could not find source code to inline"

asEditMap :: [(Uri, TextEdit)] -> Map.Map Uri [TextEdit]
asEditMap :: [(Uri, TextEdit)] -> Map Uri [TextEdit]
asEditMap = ([TextEdit] -> [TextEdit] -> [TextEdit])
-> [(Uri, [TextEdit])] -> Map Uri [TextEdit]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [TextEdit] -> [TextEdit] -> [TextEdit]
forall a. [a] -> [a] -> [a]
(++) ([(Uri, [TextEdit])] -> Map Uri [TextEdit])
-> ([(Uri, TextEdit)] -> [(Uri, [TextEdit])])
-> [(Uri, TextEdit)]
-> Map Uri [TextEdit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Uri, TextEdit) -> (Uri, [TextEdit]))
-> [(Uri, TextEdit)] -> [(Uri, [TextEdit])]
forall a b. (a -> b) -> [a] -> [b]
map ((TextEdit -> [TextEdit]) -> (Uri, TextEdit) -> (Uri, [TextEdit])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second TextEdit -> [TextEdit]
forall a. a -> [a]
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
replLocation :: Replacement -> SrcSpan
replOriginal :: Replacement -> String
replReplacement :: Replacement -> String
replLocation :: SrcSpan
replOriginal :: String
replReplacement :: String
..} <- (Replacement -> Maybe RealSrcSpan)
-> [Replacement] -> [Replacement]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (SrcSpan -> Maybe RealSrcSpan
realSpan (SrcSpan -> Maybe RealSrcSpan)
-> (Replacement -> SrcSpan) -> Replacement -> Maybe RealSrcSpan
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 (RuleName -> String) -> RuleName -> String
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 = String -> IdeState -> Action (Maybe v) -> IO (Maybe v)
forall a. String -> IdeState -> Action a -> IO a
runAction String
label IdeState
state (k -> NormalizedFilePath -> Action (Maybe v)
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 =
  ((v, PositionMapping) -> v)
-> Maybe (v, PositionMapping) -> Maybe v
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, PositionMapping) -> v
forall a b. (a, b) -> a
fst
    (Maybe (v, PositionMapping) -> Maybe v)
-> IO (Maybe (v, PositionMapping)) -> IO (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ShakeExtras
-> IdeAction (Maybe (v, PositionMapping))
-> IO (Maybe (v, PositionMapping))
forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
label (IdeState -> ShakeExtras
shakeExtras IdeState
state) (k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
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 = String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
forall k v.
IdeRule k v =>
String
-> IdeState -> k -> NormalizedFilePath -> IO (Maybe (RuleResult k))
_useRuleStale (String
"Retrie." String -> ShowS
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 stock (IE name -> IE name -> Bool
(IE name -> IE name -> Bool)
-> (IE name -> IE name -> Bool) -> Eq (IE name)
forall name. Eq name => IE name -> IE name -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: IE name -> IE name -> Bool
Eq, Int -> IE name -> ShowS
[IE name] -> ShowS
IE name -> String
(Int -> IE name -> ShowS)
-> (IE name -> String) -> ([IE name] -> ShowS) -> Show (IE name)
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
$cshowsPrec :: forall name. Show name => Int -> IE name -> ShowS
showsPrec :: Int -> IE name -> ShowS
$cshow :: forall name. Show name => IE name -> String
show :: IE name -> String
$cshowList :: forall name. Show name => [IE name] -> ShowS
showList :: [IE name] -> ShowS
Show, (forall x. IE name -> Rep (IE name) x)
-> (forall x. Rep (IE name) x -> IE name) -> Generic (IE name)
forall x. Rep (IE name) x -> IE name
forall x. IE name -> Rep (IE name) x
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
$cfrom :: forall name x. IE name -> Rep (IE name) x
from :: forall x. IE name -> Rep (IE name) x
$cto :: forall name x. Rep (IE name) x -> IE name
to :: forall x. Rep (IE name) x -> IE name
Generic)
  deriving anyclass (Maybe (IE name)
Value -> Parser [IE name]
Value -> Parser (IE name)
(Value -> Parser (IE name))
-> (Value -> Parser [IE name])
-> Maybe (IE name)
-> FromJSON (IE name)
forall name. FromJSON name => Maybe (IE name)
forall name. FromJSON name => Value -> Parser [IE name]
forall name. FromJSON name => Value -> Parser (IE name)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall name. FromJSON name => Value -> Parser (IE name)
parseJSON :: Value -> Parser (IE name)
$cparseJSONList :: forall name. FromJSON name => Value -> Parser [IE name]
parseJSONList :: Value -> Parser [IE name]
$comittedField :: forall name. FromJSON name => Maybe (IE name)
omittedField :: Maybe (IE name)
FromJSON, [IE name] -> Value
[IE name] -> Encoding
IE name -> Bool
IE name -> Value
IE name -> Encoding
(IE name -> Value)
-> (IE name -> Encoding)
-> ([IE name] -> Value)
-> ([IE name] -> Encoding)
-> (IE name -> Bool)
-> ToJSON (IE name)
forall name. ToJSON name => [IE name] -> Value
forall name. ToJSON name => [IE name] -> Encoding
forall name. ToJSON name => IE name -> Bool
forall name. ToJSON name => IE name -> Value
forall name. ToJSON name => IE name -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall name. ToJSON name => IE name -> Value
toJSON :: IE name -> Value
$ctoEncoding :: forall name. ToJSON name => IE name -> Encoding
toEncoding :: IE name -> Encoding
$ctoJSONList :: forall name. ToJSON name => [IE name] -> Value
toJSONList :: [IE name] -> Value
$ctoEncodingList :: forall name. ToJSON name => [IE name] -> Encoding
toEncodingList :: [IE name] -> Encoding
$comitField :: forall name. ToJSON name => IE name -> Bool
omitField :: IE name -> Bool
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
(ImportSpec -> ImportSpec -> Bool)
-> (ImportSpec -> ImportSpec -> Bool) -> Eq ImportSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ImportSpec -> ImportSpec -> Bool
== :: ImportSpec -> ImportSpec -> Bool
$c/= :: ImportSpec -> ImportSpec -> Bool
/= :: ImportSpec -> ImportSpec -> Bool
Eq, Int -> ImportSpec -> ShowS
[ImportSpec] -> ShowS
ImportSpec -> String
(Int -> ImportSpec -> ShowS)
-> (ImportSpec -> String)
-> ([ImportSpec] -> ShowS)
-> Show ImportSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ImportSpec -> ShowS
showsPrec :: Int -> ImportSpec -> ShowS
$cshow :: ImportSpec -> String
show :: ImportSpec -> String
$cshowList :: [ImportSpec] -> ShowS
showList :: [ImportSpec] -> ShowS
Show, (forall x. ImportSpec -> Rep ImportSpec x)
-> (forall x. Rep ImportSpec x -> ImportSpec) -> Generic ImportSpec
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
$cfrom :: forall x. ImportSpec -> Rep ImportSpec x
from :: forall x. ImportSpec -> Rep ImportSpec x
$cto :: forall x. Rep ImportSpec x -> ImportSpec
to :: forall x. Rep ImportSpec x -> ImportSpec
Generic, Maybe ImportSpec
Value -> Parser [ImportSpec]
Value -> Parser ImportSpec
(Value -> Parser ImportSpec)
-> (Value -> Parser [ImportSpec])
-> Maybe ImportSpec
-> FromJSON ImportSpec
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ImportSpec
parseJSON :: Value -> Parser ImportSpec
$cparseJSONList :: Value -> Parser [ImportSpec]
parseJSONList :: Value -> Parser [ImportSpec]
$comittedField :: Maybe ImportSpec
omittedField :: Maybe ImportSpec
FromJSON, [ImportSpec] -> Value
[ImportSpec] -> Encoding
ImportSpec -> Bool
ImportSpec -> Value
ImportSpec -> Encoding
(ImportSpec -> Value)
-> (ImportSpec -> Encoding)
-> ([ImportSpec] -> Value)
-> ([ImportSpec] -> Encoding)
-> (ImportSpec -> Bool)
-> ToJSON ImportSpec
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ImportSpec -> Value
toJSON :: ImportSpec -> Value
$ctoEncoding :: ImportSpec -> Encoding
toEncoding :: ImportSpec -> Encoding
$ctoJSONList :: [ImportSpec] -> Value
toJSONList :: [ImportSpec] -> Value
$ctoEncodingList :: [ImportSpec] -> Encoding
toEncodingList :: [ImportSpec] -> Encoding
$comitField :: ImportSpec -> Bool
omitField :: ImportSpec -> Bool
ToJSON)

toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs
toImportDecl :: ImportSpec -> ImportDecl GhcPs
toImportDecl AddImport {Bool
String
Maybe String
Maybe (IE String)
ideclNameString :: ImportSpec -> String
ideclSource :: ImportSpec -> Bool
ideclQualifiedBool :: ImportSpec -> Bool
ideclAsString :: ImportSpec -> Maybe String
ideclThing :: ImportSpec -> Maybe (IE String)
ideclNameString :: String
ideclSource :: Bool
ideclQualifiedBool :: Bool
ideclAsString :: Maybe String
ideclThing :: Maybe (IE String)
..} = GHC.ImportDecl {ideclSource :: IsBootInterface
ideclSource = IsBootInterface
ideclSource', Bool
Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
Maybe
  (ImportListInterpretation,
   GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
Maybe (XRec GhcPs ModuleName)
Maybe (LocatedAn AnnListItem ModuleName)
ImportDeclPkgQual GhcPs
XCImportDecl GhcPs
XRec GhcPs ModuleName
LocatedAn AnnListItem ModuleName
RawPkgQual
ImportDeclQualifiedStyle
XImportDeclPass
forall a. Maybe a
ideclName :: LocatedAn AnnListItem ModuleName
ideclSafe :: Bool
ideclAs :: Maybe (LocatedAn AnnListItem ModuleName)
ideclQualified :: ImportDeclQualifiedStyle
ideclPkgQual :: RawPkgQual
ideclImportList :: forall a. Maybe a
ideclExt :: XImportDeclPass
ideclExt :: XCImportDecl GhcPs
ideclName :: XRec GhcPs ModuleName
ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclSafe :: Bool
ideclQualified :: ImportDeclQualifiedStyle
ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclImportList :: Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
..}
  where
    ideclSource' :: IsBootInterface
ideclSource' = if Bool
ideclSource then IsBootInterface
IsBoot else IsBootInterface
NotBoot
    toMod :: String -> LocatedAn an ModuleName
toMod = ModuleName -> LocatedAn an ModuleName
forall a an. a -> LocatedAn an a
noLocA (ModuleName -> LocatedAn an ModuleName)
-> (String -> ModuleName) -> String -> LocatedAn an ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
GHC.mkModuleName
    ideclName :: LocatedAn AnnListItem ModuleName
ideclName = String -> LocatedAn AnnListItem ModuleName
forall {an}. String -> LocatedAn an ModuleName
toMod String
ideclNameString
    ideclSafe :: Bool
ideclSafe = Bool
False
    ideclImplicit :: Bool
ideclImplicit = Bool
False
    ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText
    ideclAs :: Maybe (LocatedAn AnnListItem ModuleName)
ideclAs = String -> LocatedAn AnnListItem ModuleName
forall {an}. String -> LocatedAn an ModuleName
toMod (String -> LocatedAn AnnListItem ModuleName)
-> Maybe String -> Maybe (LocatedAn AnnListItem ModuleName)
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

#if MIN_VERSION_ghc(9,3,0)
    ideclPkgQual :: RawPkgQual
ideclPkgQual = RawPkgQual
NoRawPkgQual
#else
    ideclPkgQual = Nothing
#endif

#if MIN_VERSION_ghc(9,5,0)
    ideclImportList :: Maybe a
ideclImportList = Maybe a
forall a. Maybe a
Nothing
    ideclExt :: XImportDeclPass
ideclExt = GHCGHC.XImportDeclPass
      { ideclAnn :: EpAnn EpAnnImportDecl
ideclAnn = EpAnn EpAnnImportDecl
forall ann. EpAnn ann
GHCGHC.EpAnnNotUsed
      , ideclSourceText :: SourceText
ideclSourceText = SourceText
ideclSourceSrc
      , ideclImplicit :: Bool
ideclImplicit = Bool
ideclImplicit
      }
#else
    ideclExt = GHCGHC.EpAnnNotUsed
    ideclHiding = Nothing
#endif


reuseParsedModule :: IdeState -> NormalizedFilePath -> IO (FixityEnv, Annotated GHCGHC.ParsedSource)
reuseParsedModule :: IdeState
-> NormalizedFilePath -> IO (FixityEnv, Annotated ParsedSource)
reuseParsedModule IdeState
state NormalizedFilePath
f = do
        ParsedModule
pm <- IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> GetParsedModule
-> NormalizedFilePath
-> IO (RuleResult GetParsedModule)
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') <- IdeState
-> NormalizedFilePath
-> Annotated ParsedSource
-> IO (FixityEnv, Annotated ParsedSource)
forall ast.
Data ast =>
IdeState
-> NormalizedFilePath
-> Annotated ast
-> IO (FixityEnv, Annotated ast)
fixFixities IdeState
state NormalizedFilePath
f (ParsedModule -> Annotated ParsedSource
fixAnns ParsedModule
pm)
        (FixityEnv, Annotated ParsedSource)
-> IO (FixityEnv, Annotated ParsedSource)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ParsedSource
pm')

getCPPmodule :: IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule)
getCPPmodule :: IdeState
-> HscEnv -> String -> IO (FixityEnv, CPP (Annotated ParsedSource))
getCPPmodule IdeState
state HscEnv
session String
t = do
    NormalizedFilePath
nt <- String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath)
-> IO String -> IO NormalizedFilePath
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 (ModSummaryResult -> ModSummary)
-> IO ModSummaryResult -> IO ModSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            IdeState
-> String
-> (NormalizedFilePath -> CallRetrieError)
-> GetModSummary
-> NormalizedFilePath
-> IO (RuleResult GetModSummary)
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 =
                      Just (stringToStringBuffer contents)
                  }
          Logger -> Priority -> Text -> IO ()
logPriority (IdeState -> Logger
ideLogger IdeState
state) Priority
Info (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Parsing module: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
t
          ParsedModule
parsed <- HscEnv -> Ghc ParsedModule -> IO ParsedModule
forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
session (ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
GHCGHC.parseModule ModSummary
ms')
              IO ParsedModule
-> (SomeException -> IO ParsedModule) -> IO ParsedModule
forall (m :: * -> *) e a.
(?callStack::CallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> CallRetrieError -> IO ParsedModule
forall (m :: * -> *) e a.
(?callStack::CallStack, 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) <- IdeState
-> NormalizedFilePath
-> Annotated ParsedSource
-> IO (FixityEnv, Annotated ParsedSource)
forall ast.
Data ast =>
IdeState
-> NormalizedFilePath
-> Annotated ast
-> IO (FixityEnv, Annotated ast)
fixFixities IdeState
state NormalizedFilePath
f (ParsedModule -> Annotated ParsedSource
fixAnns ParsedModule
parsed)
          (FixityEnv, Annotated ParsedSource)
-> IO (FixityEnv, Annotated ParsedSource)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ParsedSource
parsed)

    Text
contents <- do
      (UTCTime
_, Maybe Text
mbContentsVFS) <-
        String
-> IdeState
-> Action (UTCTime, Maybe Text)
-> IO (UTCTime, Maybe Text)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Retrie.GetFileContents" IdeState
state (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nt
      case Maybe Text
mbContentsVFS of
        Just Text
contents -> Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
contents
        Maybe Text
Nothing       -> ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nt)
    if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
T.isPrefixOf Text
"#if" (Text -> Bool) -> (Text -> Text) -> Text -> Bool
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 <- FixityEnv -> IO (IORef FixityEnv)
forall a. a -> IO (IORef a)
newIORef FixityEnv
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
              IORef FixityEnv -> (FixityEnv -> FixityEnv) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef FixityEnv
fixitiesRef (FixityEnv
fix <>)
              Annotated ParsedSource -> IO (Annotated ParsedSource)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Annotated ParsedSource
res
        CPP (Annotated ParsedSource)
res <- (String -> IO (Annotated ParsedSource))
-> Text -> IO (CPP (Annotated ParsedSource))
forall (m :: * -> *).
Monad m =>
(String -> m (Annotated ParsedSource))
-> Text -> m (CPP (Annotated ParsedSource))
parseCPP String -> IO (Annotated ParsedSource)
parseModule Text
contents
        FixityEnv
fixities <- IORef FixityEnv -> IO FixityEnv
forall a. IORef a -> IO a
readIORef IORef FixityEnv
fixitiesRef
        (FixityEnv, CPP (Annotated ParsedSource))
-> IO (FixityEnv, CPP (Annotated ParsedSource))
forall a. a -> IO a
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
        (FixityEnv, CPP (Annotated ParsedSource))
-> IO (FixityEnv, CPP (Annotated ParsedSource))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fixities, Annotated ParsedSource -> CPP (Annotated ParsedSource)
forall a. a -> CPP a
NoCPP Annotated ParsedSource
pm)