{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Ide.Plugin.Rename (descriptor) where

#if MIN_VERSION_ghc(9,2,1)
import           GHC.Parser.Annotation                 (AnnContext, AnnList, AnnParen, AnnPragma)
#endif

import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Data.Generics
import           Data.HashSet                          (HashSet)
import qualified Data.HashSet                          as HS
import           Data.Hashable
import           Data.List.Extra
import qualified Data.Map                              as M
import           Data.Maybe
import           Data.Mod.Word
import qualified Data.Text                             as T
import           Development.IDE.Core.PositionMapping
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Service
import           Development.IDE.Core.Shake
import           Development.IDE.GHC.Compat.Core
import           Development.IDE.GHC.Compat.ExactPrint
import           Development.IDE.GHC.Compat.Parser
import           Development.IDE.GHC.Compat.Units
import           Development.IDE.GHC.Error
import           Development.IDE.GHC.ExactPrint
import           Development.IDE.Spans.AtPoint
import           Development.IDE.Types.Location
import           HieDb.Query
import           Ide.Plugin.Config
import           Ide.Plugin.Properties
import           Ide.PluginUtils
import           Ide.Types
import           Language.LSP.Server
import           Language.LSP.Types

instance Hashable Location
instance Hashable Range
instance Hashable Position
instance Hashable UInt
instance Hashable (Mod a) where hash :: Mod a -> Int
hash Mod a
n = Word -> Int
forall a. Hashable a => a -> Int
hash (Mod a -> Word
forall (m :: Nat). Mod m -> Word
unMod Mod a
n)

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
pluginId = (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
pluginId)
    { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentRename
-> PluginMethodHandler IdeState 'TextDocumentRename
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentRename
STextDocumentRename PluginMethodHandler IdeState 'TextDocumentRename
renameProvider
    , pluginConfigDescriptor :: ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor
        { configCustomConfig :: CustomConfig
configCustomConfig = Properties '[ 'PropertyKey "crossModule" 'TBoolean] -> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[ 'PropertyKey "crossModule" 'TBoolean]
properties }
    }

renameProvider :: PluginMethodHandler IdeState TextDocumentRename
renameProvider :: PluginMethodHandler IdeState 'TextDocumentRename
renameProvider IdeState
state PluginId
pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) =
    ExceptT String (LspT Config IO) WorkspaceEdit
-> LspT Config IO (Either ResponseError WorkspaceEdit)
forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
response (ExceptT String (LspT Config IO) WorkspaceEdit
 -> LspT Config IO (Either ResponseError WorkspaceEdit))
-> ExceptT String (LspT Config IO) WorkspaceEdit
-> LspT Config IO (Either ResponseError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ do
        NormalizedFilePath
nfp <- Uri -> ExceptT String (LspT Config IO) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
safeUriToNfp Uri
uri
        Name
oldName <- IdeState
-> NormalizedFilePath
-> Position
-> ExceptT String (LspT Config IO) Name
getNameAtPos IdeState
state NormalizedFilePath
nfp Position
pos
        HashSet Location
refLocs <- IdeState
-> NormalizedFilePath
-> Name
-> ExceptT String (LspT Config IO) (HashSet Location)
forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> Name
-> ExceptT String m (HashSet Location)
refsAtName IdeState
state NormalizedFilePath
nfp Name
oldName
        Bool
crossModuleEnabled <- LspT Config IO Bool -> ExceptT String (LspT Config IO) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspT Config IO Bool -> ExceptT String (LspT Config IO) Bool)
-> LspT Config IO Bool -> ExceptT String (LspT Config IO) Bool
forall a b. (a -> b) -> a -> b
$ KeyNameProxy "crossModule"
-> PluginId
-> Properties '[ 'PropertyKey "crossModule" 'TBoolean]
-> LspT Config IO (ToHsType 'TBoolean)
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]) (m :: * -> *).
(HasProperty s k t r, MonadLsp Config m) =>
KeyNameProxy s -> PluginId -> Properties r -> m (ToHsType t)
usePropertyLsp IsLabel "crossModule" (KeyNameProxy "crossModule")
KeyNameProxy "crossModule"
#crossModule PluginId
pluginId Properties '[ 'PropertyKey "crossModule" 'TBoolean]
properties
        Bool
-> ExceptT String (LspT Config IO) ()
-> ExceptT String (LspT Config IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
crossModuleEnabled (ExceptT String (LspT Config IO) ()
 -> ExceptT String (LspT Config IO) ())
-> ExceptT String (LspT Config IO) ()
-> ExceptT String (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> HashSet Location
-> Name
-> ExceptT String (LspT Config IO) ()
forall config (m :: * -> *).
MonadLsp config m =>
IdeState
-> NormalizedFilePath
-> HashSet Location
-> Name
-> ExceptT String m ()
failWhenImportOrExport IdeState
state NormalizedFilePath
nfp HashSet Location
refLocs Name
oldName
        Bool
-> ExceptT String (LspT Config IO) ()
-> ExceptT String (LspT Config IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isBuiltInSyntax Name
oldName) (ExceptT String (LspT Config IO) ()
 -> ExceptT String (LspT Config IO) ())
-> ExceptT String (LspT Config IO) ()
-> ExceptT String (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$
            String -> ExceptT String (LspT Config IO) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String
"Invalid rename of built-in syntax: \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
showName Name
oldName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")
        let newName :: OccName
newName = String -> OccName
mkTcOcc (String -> OccName) -> String -> OccName
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
newNameText
            filesRefs :: [(Uri, HashSet Location)]
filesRefs = (Location -> Uri) -> HashSet Location -> [(Uri, HashSet Location)]
forall a b.
(Hashable a, Eq a, Eq b) =>
(a -> b) -> HashSet a -> [(b, HashSet a)]
collectWith Location -> Uri
locToUri HashSet Location
refLocs
            getFileEdit :: Uri
-> HashSet Location
-> ExceptT String (LspT Config IO) WorkspaceEdit
getFileEdit = (HashSet Location
 -> Uri -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> Uri
-> HashSet Location
-> ExceptT String (LspT Config IO) WorkspaceEdit
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((HashSet Location
  -> Uri -> ExceptT String (LspT Config IO) WorkspaceEdit)
 -> Uri
 -> HashSet Location
 -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> (HashSet Location
    -> Uri -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> Uri
-> HashSet Location
-> ExceptT String (LspT Config IO) WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ IdeState
-> (ParsedSource -> ParsedSource)
-> Uri
-> ExceptT String (LspT Config IO) WorkspaceEdit
forall config (m :: * -> *).
MonadLsp config m =>
IdeState
-> (ParsedSource -> ParsedSource)
-> Uri
-> ExceptT String m WorkspaceEdit
getSrcEdit IdeState
state ((ParsedSource -> ParsedSource)
 -> Uri -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> (HashSet Location -> ParsedSource -> ParsedSource)
-> HashSet Location
-> Uri
-> ExceptT String (LspT Config IO) WorkspaceEdit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> HashSet Location -> ParsedSource -> ParsedSource
renameRefs OccName
newName
        [WorkspaceEdit]
fileEdits <- ((Uri, HashSet Location)
 -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> [(Uri, HashSet Location)]
-> ExceptT String (LspT Config IO) [WorkspaceEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Uri
 -> HashSet Location
 -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> (Uri, HashSet Location)
-> ExceptT String (LspT Config IO) WorkspaceEdit
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Uri
-> HashSet Location
-> ExceptT String (LspT Config IO) WorkspaceEdit
getFileEdit) [(Uri, HashSet Location)]
filesRefs
        WorkspaceEdit -> ExceptT String (LspT Config IO) WorkspaceEdit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkspaceEdit -> ExceptT String (LspT Config IO) WorkspaceEdit)
-> WorkspaceEdit -> ExceptT String (LspT Config IO) WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ (WorkspaceEdit -> WorkspaceEdit -> WorkspaceEdit)
-> WorkspaceEdit -> [WorkspaceEdit] -> WorkspaceEdit
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' WorkspaceEdit -> WorkspaceEdit -> WorkspaceEdit
forall a. Semigroup a => a -> a -> a
(<>) WorkspaceEdit
forall a. Monoid a => a
mempty [WorkspaceEdit]
fileEdits

-- | Limit renaming across modules.
failWhenImportOrExport ::
    (MonadLsp config m) =>
    IdeState ->
    NormalizedFilePath ->
    HashSet Location ->
    Name ->
    ExceptT String m ()
failWhenImportOrExport :: IdeState
-> NormalizedFilePath
-> HashSet Location
-> Name
-> ExceptT String m ()
failWhenImportOrExport IdeState
state NormalizedFilePath
nfp HashSet Location
refLocs Name
name = do
    ParsedModule
pm <- String -> m (Maybe ParsedModule) -> ExceptT String m ParsedModule
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM (String
"No parsed module for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp) (m (Maybe ParsedModule) -> ExceptT String m ParsedModule)
-> m (Maybe ParsedModule) -> ExceptT String m ParsedModule
forall a b. (a -> b) -> a -> b
$ IO (Maybe ParsedModule) -> m (Maybe ParsedModule)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ParsedModule) -> m (Maybe ParsedModule))
-> IO (Maybe ParsedModule) -> m (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe ParsedModule)
-> IO (Maybe ParsedModule)
forall a. String -> IdeState -> Action a -> IO a
runAction
        String
"Rename.GetParsedModule"
        IdeState
state
        (GetParsedModule
-> NormalizedFilePath -> Action (Maybe ParsedModule)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
nfp)
    let hsMod :: SrcSpanLess ParsedSource
hsMod = ParsedSource -> SrcSpanLess ParsedSource
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ParsedSource -> SrcSpanLess ParsedSource)
-> ParsedSource -> SrcSpanLess ParsedSource
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm
    case (Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName HsModule GhcPs
SrcSpanLess ParsedSource
hsMod, HsModule GhcPs -> Maybe (Located [LIE GhcPs])
forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodExports HsModule GhcPs
SrcSpanLess ParsedSource
hsMod) of
        (Maybe ModuleName
mbModName, Maybe (Located [LIE GhcPs])
_) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Module -> Name -> Bool
nameIsLocalOrFrom (Name -> Maybe ModuleName -> Module
replaceModName Name
name Maybe ModuleName
mbModName) Name
name
            -> String -> ExceptT String m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Renaming of an imported name is unsupported"
        (Maybe ModuleName
_, Just (L SrcSpan
_ [LIE GhcPs]
exports)) | (LIE GhcPs -> Bool) -> [LIE GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Location -> HashSet Location -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet Location
refLocs) (Location -> Bool) -> (LIE GhcPs -> Location) -> LIE GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Location
unsafeSrcSpanToLoc (SrcSpan -> Location)
-> (LIE GhcPs -> SrcSpan) -> LIE GhcPs -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LIE GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) [LIE GhcPs]
exports
            -> String -> ExceptT String m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Renaming of an exported name is unsupported"
        (Just ModuleName
_, Maybe (Located [LIE GhcPs])
Nothing) -> String -> ExceptT String m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Explicit export list required for renaming"
        (Maybe ModuleName, Maybe (Located [LIE GhcPs]))
_ -> () -> ExceptT String m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

---------------------------------------------------------------------------------------------------
-- Source renaming

-- | Apply a function to a `ParsedSource` for a given `Uri` to compute a `WorkspaceEdit`.
getSrcEdit ::
    (MonadLsp config m) =>
    IdeState ->
    (ParsedSource -> ParsedSource) ->
    Uri ->
    ExceptT String m WorkspaceEdit
getSrcEdit :: IdeState
-> (ParsedSource -> ParsedSource)
-> Uri
-> ExceptT String m WorkspaceEdit
getSrcEdit IdeState
state ParsedSource -> ParsedSource
updatePs Uri
uri = do
    ClientCapabilities
ccs <- m ClientCapabilities -> ExceptT String m ClientCapabilities
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
    NormalizedFilePath
nfp <- Uri -> ExceptT String m NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
safeUriToNfp Uri
uri
    Annotated ParsedSource
annAst <- String
-> m (Maybe (Annotated ParsedSource))
-> ExceptT String m (Annotated ParsedSource)
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM (String
"No parsed source for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp) (m (Maybe (Annotated ParsedSource))
 -> ExceptT String m (Annotated ParsedSource))
-> m (Maybe (Annotated ParsedSource))
-> ExceptT String m (Annotated ParsedSource)
forall a b. (a -> b) -> a -> b
$ IO (Maybe (Annotated ParsedSource))
-> m (Maybe (Annotated ParsedSource))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Annotated ParsedSource))
 -> m (Maybe (Annotated ParsedSource)))
-> IO (Maybe (Annotated ParsedSource))
-> m (Maybe (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe (Annotated ParsedSource))
-> IO (Maybe (Annotated ParsedSource))
forall a. String -> IdeState -> Action a -> IO a
runAction
        String
"Rename.GetAnnotatedParsedSource"
        IdeState
state
        (GetAnnotatedParsedSource
-> NormalizedFilePath -> Action (Maybe (Annotated ParsedSource))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetAnnotatedParsedSource
GetAnnotatedParsedSource NormalizedFilePath
nfp)
    let (ParsedSource
ps, Anns
anns) = (Annotated ParsedSource -> ParsedSource
forall ast. Annotated ast -> ast
astA Annotated ParsedSource
annAst, Annotated ParsedSource -> Anns
forall ast. Annotated ast -> Anns
annsA Annotated ParsedSource
annAst)
#if !MIN_VERSION_ghc(9,2,1)
    let src :: Text
src = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParsedSource -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint ParsedSource
ps Anns
anns
        res :: Text
res = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParsedSource -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint (ParsedSource -> ParsedSource
updatePs ParsedSource
ps) Anns
anns
#else
    let src = T.pack $ exactPrint ps
        res = T.pack $ exactPrint (updatePs ps)
#endif
    WorkspaceEdit -> ExceptT String m WorkspaceEdit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkspaceEdit -> ExceptT String m WorkspaceEdit)
-> WorkspaceEdit -> ExceptT String m WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ ClientCapabilities
-> (Uri, Text) -> Text -> WithDeletions -> WorkspaceEdit
diffText ClientCapabilities
ccs (Uri
uri, Text
src) Text
res WithDeletions
IncludeDeletions

-- | Replace names at every given `Location` (in a given `ParsedSource`) with a given new name.
renameRefs ::
    OccName ->
    HashSet Location ->
    ParsedSource ->
    ParsedSource
#if MIN_VERSION_ghc(9,2,1)
renameRefs newName refs = everywhere $
    -- there has to be a better way...
    mkT (replaceLoc @AnnListItem) `extT`
    -- replaceLoc @AnnList `extT` -- not needed
    -- replaceLoc @AnnParen `extT`   -- not needed
    -- replaceLoc @AnnPragma `extT` -- not needed
    -- replaceLoc @AnnContext `extT` -- not needed
    -- replaceLoc @NoEpAnns `extT` -- not needed
    replaceLoc @NameAnn
    where
        replaceLoc :: forall an. Typeable an => LocatedAn an RdrName -> LocatedAn an RdrName
        replaceLoc (L srcSpan oldRdrName)
            | isRef (locA srcSpan) = L srcSpan $ replace oldRdrName
        replaceLoc lOldRdrName = lOldRdrName
#else
renameRefs :: OccName -> HashSet Location -> ParsedSource -> ParsedSource
renameRefs OccName
newName HashSet Location
refs = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (Located RdrName -> Located RdrName) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Located RdrName -> Located RdrName
replaceLoc
    where
        replaceLoc :: Located RdrName -> Located RdrName
        replaceLoc :: Located RdrName -> Located RdrName
replaceLoc (L SrcSpan
srcSpan RdrName
oldRdrName)
            | SrcSpan -> Bool
isRef SrcSpan
srcSpan = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
srcSpan (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ RdrName -> RdrName
replace RdrName
oldRdrName
        replaceLoc Located RdrName
lOldRdrName = Located RdrName
lOldRdrName
#endif

        replace :: RdrName -> RdrName
        replace :: RdrName -> RdrName
replace (Qual ModuleName
modName OccName
_) = ModuleName -> OccName -> RdrName
Qual ModuleName
modName OccName
newName
        replace RdrName
_                = OccName -> RdrName
Unqual OccName
newName

        isRef :: SrcSpan -> Bool
        isRef :: SrcSpan -> Bool
isRef = (Location -> HashSet Location -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HashSet Location
refs) (Location -> Bool) -> (SrcSpan -> Location) -> SrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Location
unsafeSrcSpanToLoc

---------------------------------------------------------------------------------------------------
-- Reference finding

-- | Note: We only find exact name occurences (i.e. type reference "depth" is 0).
refsAtName ::
    MonadIO m =>
    IdeState ->
    NormalizedFilePath ->
    Name ->
    ExceptT String m (HashSet Location)
refsAtName :: IdeState
-> NormalizedFilePath
-> Name
-> ExceptT String m (HashSet Location)
refsAtName IdeState
state NormalizedFilePath
nfp Name
name = do
    ShakeExtras{WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb :: WithHieDb
withHieDb} <- IO ShakeExtras -> ExceptT String m ShakeExtras
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ShakeExtras -> ExceptT String m ShakeExtras)
-> IO ShakeExtras -> ExceptT String m ShakeExtras
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action ShakeExtras -> IO ShakeExtras
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Rename.HieDb" IdeState
state Action ShakeExtras
getShakeExtras
    (HieAstResult, PositionMapping)
ast <- IdeState
-> NormalizedFilePath
-> ExceptT String m (HieAstResult, PositionMapping)
forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> ExceptT String m (HieAstResult, PositionMapping)
safeGetHieAst IdeState
state NormalizedFilePath
nfp
    [Location]
dbRefs <- case Name -> Maybe Module
nameModule_maybe Name
name of
        Maybe Module
Nothing -> [Location] -> ExceptT String m [Location]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Just Module
mod -> IO [Location] -> ExceptT String m [Location]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Location] -> ExceptT String m [Location])
-> IO [Location] -> ExceptT String m [Location]
forall a b. (a -> b) -> a -> b
$ (Res RefRow -> Maybe Location) -> [Res RefRow] -> [Location]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Res RefRow -> Maybe Location
rowToLoc ([Res RefRow] -> [Location]) -> IO [Res RefRow] -> IO [Location]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HieDb -> IO [Res RefRow]) -> IO [Res RefRow]
WithHieDb
withHieDb (\HieDb
hieDb ->
            HieDb
-> Bool
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> [String]
-> IO [Res RefRow]
findReferences
                HieDb
hieDb
                Bool
True
                (Name -> OccName
nameOccName Name
name)
                (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleName -> Maybe ModuleName) -> ModuleName -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName Module
mod)
                (Unit -> Maybe Unit
forall a. a -> Maybe a
Just (Unit -> Maybe Unit) -> Unit -> Maybe Unit
forall a b. (a -> b) -> a -> b
$ Module -> Unit
moduleUnit Module
mod)
                [NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp]
            )
    HashSet Location -> ExceptT String m (HashSet Location)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet Location -> ExceptT String m (HashSet Location))
-> HashSet Location -> ExceptT String m (HashSet Location)
forall a b. (a -> b) -> a -> b
$ [Location] -> HashSet Location
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([Location] -> HashSet Location) -> [Location] -> HashSet Location
forall a b. (a -> b) -> a -> b
$ Name -> (HieAstResult, PositionMapping) -> [Location]
getNameLocs Name
name (HieAstResult, PositionMapping)
ast [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Location]
dbRefs

getNameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location]
getNameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location]
getNameLocs Name
name (HAR Module
_ HieASTs a
_ RefMap a
rm Map Name [RealSrcSpan]
_ HieKind a
_, PositionMapping
pm) =
    ((RealSrcSpan, IdentifierDetails a) -> Maybe Location)
-> [(RealSrcSpan, IdentifierDetails a)] -> [Location]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PositionMapping -> Location -> Maybe Location
toCurrentLocation PositionMapping
pm (Location -> Maybe Location)
-> ((RealSrcSpan, IdentifierDetails a) -> Location)
-> (RealSrcSpan, IdentifierDetails a)
-> Maybe Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> Location
realSrcSpanToLocation (RealSrcSpan -> Location)
-> ((RealSrcSpan, IdentifierDetails a) -> RealSrcSpan)
-> (RealSrcSpan, IdentifierDetails a)
-> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealSrcSpan, IdentifierDetails a) -> RealSrcSpan
forall a b. (a, b) -> a
fst)
             (Maybe [(RealSrcSpan, IdentifierDetails a)]
-> [(RealSrcSpan, IdentifierDetails a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Maybe [(RealSrcSpan, IdentifierDetails a)]
 -> [(RealSrcSpan, IdentifierDetails a)])
-> Maybe [(RealSrcSpan, IdentifierDetails a)]
-> [(RealSrcSpan, IdentifierDetails a)]
forall a b. (a -> b) -> a -> b
$ Either ModuleName Name
-> RefMap a -> Maybe [(RealSrcSpan, IdentifierDetails a)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Name -> Either ModuleName Name
forall a b. b -> Either a b
Right Name
name) RefMap a
rm)

---------------------------------------------------------------------------------------------------
-- Util

getNameAtPos :: IdeState -> NormalizedFilePath -> Position -> ExceptT String (LspT Config IO) Name
getNameAtPos :: IdeState
-> NormalizedFilePath
-> Position
-> ExceptT String (LspT Config IO) Name
getNameAtPos IdeState
state NormalizedFilePath
nfp Position
pos = do
    (HAR{HieASTs a
hieAst :: ()
hieAst :: HieASTs a
hieAst}, PositionMapping
pm) <- IdeState
-> NormalizedFilePath
-> ExceptT String (LspT Config IO) (HieAstResult, PositionMapping)
forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> ExceptT String m (HieAstResult, PositionMapping)
safeGetHieAst IdeState
state NormalizedFilePath
nfp
    String -> Maybe Name -> ExceptT String (LspT Config IO) Name
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (String
"No name at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
showPos Position
pos) (Maybe Name -> ExceptT String (LspT Config IO) Name)
-> Maybe Name -> ExceptT String (LspT Config IO) Name
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe Name
forall a. [a] -> Maybe a
listToMaybe ([Name] -> Maybe Name) -> [Name] -> Maybe Name
forall a b. (a -> b) -> a -> b
$ HieASTs a -> Position -> PositionMapping -> [Name]
forall a. HieASTs a -> Position -> PositionMapping -> [Name]
getNamesAtPoint HieASTs a
hieAst Position
pos PositionMapping
pm

safeGetHieAst ::
    MonadIO m =>
    IdeState ->
    NormalizedFilePath ->
    ExceptT String m (HieAstResult, PositionMapping)
safeGetHieAst :: IdeState
-> NormalizedFilePath
-> ExceptT String m (HieAstResult, PositionMapping)
safeGetHieAst IdeState
state NormalizedFilePath
nfp = String
-> m (Maybe (HieAstResult, PositionMapping))
-> ExceptT String m (HieAstResult, PositionMapping)
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM
    (String
"No AST for file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp)
    (IO (Maybe (HieAstResult, PositionMapping))
-> m (Maybe (HieAstResult, PositionMapping))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (HieAstResult, PositionMapping))
 -> m (Maybe (HieAstResult, PositionMapping)))
-> IO (Maybe (HieAstResult, PositionMapping))
-> m (Maybe (HieAstResult, PositionMapping))
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Maybe (HieAstResult, PositionMapping))
-> IO (Maybe (HieAstResult, PositionMapping))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Rename.GetHieAst" IdeState
state (Action (Maybe (HieAstResult, PositionMapping))
 -> IO (Maybe (HieAstResult, PositionMapping)))
-> Action (Maybe (HieAstResult, PositionMapping))
-> IO (Maybe (HieAstResult, PositionMapping))
forall a b. (a -> b) -> a -> b
$ GetHieAst
-> NormalizedFilePath
-> Action (Maybe (HieAstResult, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GetHieAst
GetHieAst NormalizedFilePath
nfp)

safeUriToNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath
safeUriToNfp :: Uri -> ExceptT String m NormalizedFilePath
safeUriToNfp Uri
uri = String
-> Maybe NormalizedFilePath -> ExceptT String m NormalizedFilePath
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe
    (String
"No filepath for uri: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri)
    (String -> NormalizedFilePath
toNormalizedFilePath (String -> NormalizedFilePath)
-> Maybe String -> Maybe NormalizedFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> Maybe String
uriToFilePath Uri
uri)

-- head is safe since groups are non-empty
collectWith :: (Hashable a, Eq a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)]
collectWith :: (a -> b) -> HashSet a -> [(b, HashSet a)]
collectWith a -> b
f = ([a] -> (b, HashSet a)) -> [[a]] -> [(b, HashSet a)]
forall a b. (a -> b) -> [a] -> [b]
map (\[a]
a -> (a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
head [a]
a, [a] -> HashSet a
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [a]
a)) ([[a]] -> [(b, HashSet a)])
-> (HashSet a -> [[a]]) -> HashSet a -> [(b, HashSet a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [[a]]
forall b a. Eq b => (a -> b) -> [a] -> [[a]]
groupOn a -> b
f ([a] -> [[a]]) -> (HashSet a -> [a]) -> HashSet a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> [a]
forall a. HashSet a -> [a]
HS.toList

locToUri :: Location -> Uri
locToUri :: Location -> Uri
locToUri (Location Uri
uri Range
_) = Uri
uri

nfpToUri :: NormalizedFilePath -> Uri
nfpToUri :: NormalizedFilePath -> Uri
nfpToUri = String -> Uri
filePathToUri (String -> Uri)
-> (NormalizedFilePath -> String) -> NormalizedFilePath -> Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath

showName :: Name -> String
showName :: Name -> String
showName = OccName -> String
occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName

showPos :: Position -> String
showPos :: Position -> String
showPos Position{UInt
_line :: Position -> UInt
_line :: UInt
_line, UInt
_character :: Position -> UInt
_character :: UInt
_character} = String
"line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UInt -> String
forall a. Show a => a -> String
show UInt
_line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - character: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UInt -> String
forall a. Show a => a -> String
show UInt
_character

unsafeSrcSpanToLoc :: SrcSpan -> Location
unsafeSrcSpanToLoc :: SrcSpan -> Location
unsafeSrcSpanToLoc SrcSpan
srcSpan =
    case SrcSpan -> Maybe Location
srcSpanToLocation SrcSpan
srcSpan of
        Maybe Location
Nothing       -> String -> Location
forall a. HasCallStack => String -> a
error String
"Invalid conversion from UnhelpfulSpan to Location"
        Just Location
location -> Location
location

replaceModName :: Name -> Maybe ModuleName -> Module
replaceModName :: Name -> Maybe ModuleName -> Module
replaceModName Name
name Maybe ModuleName
mbModName =
    Unit -> ModuleName -> Module
mkModule (Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name) (ModuleName -> Maybe ModuleName -> ModuleName
forall a. a -> Maybe a -> a
fromMaybe (String -> ModuleName
mkModuleName String
"Main") Maybe ModuleName
mbModName)

---------------------------------------------------------------------------------------------------
-- Config

properties :: Properties '[ 'PropertyKey "crossModule" 'TBoolean]
properties :: Properties '[ 'PropertyKey "crossModule" 'TBoolean]
properties = Properties '[]
emptyProperties
  Properties '[]
-> (Properties '[]
    -> Properties '[ 'PropertyKey "crossModule" 'TBoolean])
-> Properties '[ 'PropertyKey "crossModule" 'TBoolean]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "crossModule"
-> Text
-> Bool
-> Properties '[]
-> Properties '[ 'PropertyKey "crossModule" 'TBoolean]
forall (s :: Symbol) (r :: [PropertyKey]).
(KnownSymbol s, NotElem s r) =>
KeyNameProxy s
-> Text
-> Bool
-> Properties r
-> Properties ('PropertyKey s 'TBoolean : r)
defineBooleanProperty IsLabel "crossModule" (KeyNameProxy "crossModule")
KeyNameProxy "crossModule"
#crossModule
    Text
"Enable experimental cross-module renaming" Bool
False