{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Ide.Plugin.ModuleName (
descriptor,
Log,
) where
import Control.Monad (forM_, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Aeson (toJSON)
import Data.Char (isLower, isUpper)
import Data.List (intercalate, minimumBy,
stripPrefix, uncons)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import Data.String (IsString)
import qualified Data.Text as T
import Development.IDE (GetParsedModule (GetParsedModule),
GhcSession (GhcSession),
IdeState, Pretty,
Priority (Debug),
Recorder, WithPriority,
colon, evalGhcEnv,
hscEnvWithImportPaths,
logWith,
realSrcSpanToRange,
runAction, useWithStale,
(<+>))
import Development.IDE.Core.PluginUtils
import Development.IDE.Core.PositionMapping (toCurrentRange)
import Development.IDE.GHC.Compat (GenLocated (L),
getSessionDynFlags,
hsmodName, importPaths,
locA, moduleNameString,
pattern RealSrcSpan,
pm_parsed_source, unLoc)
import Ide.Logger (Pretty (..))
import Ide.Plugin.Error
import Ide.Types
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.VFS (virtualFileText)
import System.Directory (makeAbsolute)
import System.FilePath (dropExtension, normalise,
pathSeparator,
splitDirectories,
takeFileName)
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
(forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ $sel:pluginHandlers:PluginDescriptor :: PluginHandlers IdeState
pluginHandlers = forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCodeLens
SMethod_TextDocumentCodeLens (Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens
codeLens Recorder (WithPriority Log)
recorder)
, $sel:pluginCommands:PluginDescriptor :: [PluginCommand IdeState]
pluginCommands = [forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand forall p. IsString p => p
updateModuleNameCommand Text
"set name of module to match with file path" (Recorder (WithPriority Log) -> CommandFunction IdeState Uri
command Recorder (WithPriority Log)
recorder)]
}
updateModuleNameCommand :: IsString p => p
updateModuleNameCommand :: forall p. IsString p => p
updateModuleNameCommand = p
"updateModuleName"
codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens
codeLens :: Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens
codeLens Recorder (WithPriority Log)
recorder IdeState
state PluginId
pluginId CodeLensParams{$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument=TextDocumentIdentifier Uri
uri} = do
[Action]
res <- forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL (Action -> CodeLens
asCodeLens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Action]
res)
where
asCodeLens :: Action -> CodeLens
asCodeLens :: Action -> CodeLens
asCodeLens Replace{Text
Uri
Range
aCode :: Action -> Text
aTitle :: Action -> Text
aRange :: Action -> Range
aUri :: Action -> Uri
aCode :: Text
aTitle :: Text
aRange :: Range
aUri :: Uri
..} = Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
aRange (forall a. a -> Maybe a
Just Command
cmd) forall a. Maybe a
Nothing
where
cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
pluginId forall p. IsString p => p
updateModuleNameCommand Text
aTitle (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON Uri
aUri])
command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
command Recorder (WithPriority Log)
recorder IdeState
state Uri
uri = do
[Action]
actMaybe <- forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Action]
actMaybe forall a b. (a -> b) -> a -> b
$ \Replace{Text
Uri
Range
aCode :: Text
aTitle :: Text
aRange :: Range
aUri :: Uri
aCode :: Action -> Text
aTitle :: Action -> Text
aRange :: Action -> Range
aUri :: Action -> Uri
..} ->
let
edit :: WorkspaceEdit
edit = Maybe (Map Uri [TextEdit])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Uri
aUri [Range -> Text -> TextEdit
TextEdit Range
aRange Text
aCode]) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
in
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edit) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null
data Action = Replace
{ Action -> Uri
aUri :: Uri
, Action -> Range
aRange :: Range
, Action -> Text
aTitle :: T.Text
, Action -> Text
aCode :: T.Text
}
deriving (Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show)
action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]
action :: forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri = do
NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
String
fp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m String
uriToFilePathE Uri
uri
Maybe VirtualFile
contents <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
let emptyModule :: Bool
emptyModule = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. VirtualFile -> Text
virtualFileText) Maybe VirtualFile
contents
[Text]
correctNames <- forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> String
-> ExceptT PluginError IO [Text]
pathModuleNames Recorder (WithPriority Log)
recorder IdeState
state NormalizedFilePath
nfp String
fp
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([Text] -> Log
CorrectNames [Text]
correctNames)
let bestName :: Maybe Text
bestName = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Text -> Int
T.length) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
correctNames
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Maybe Text -> Log
BestName Maybe Text
bestName)
Maybe (Range, Text)
statedNameMaybe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text))
codeModuleName IdeState
state NormalizedFilePath
nfp
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Maybe Text -> Log
ModuleName forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Range, Text)
statedNameMaybe)
case (Maybe Text
bestName, Maybe (Range, Text)
statedNameMaybe) of
(Just Text
bestName, Just (Range
nameRange, Text
statedName))
| Text
statedName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
correctNames ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Uri -> Range -> Text -> Text -> Action
Replace Uri
uri Range
nameRange (Text
"Set module name to " forall a. Semigroup a => a -> a -> a
<> Text
bestName) Text
bestName]
(Just Text
bestName, Maybe (Range, Text)
Nothing)
| Bool
emptyModule ->
let code :: Text
code = Text
"module " forall a. Semigroup a => a -> a -> a
<> Text
bestName forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
in forall (f :: * -> *) a. Applicative f => a -> f a
pure [Uri -> Range -> Text -> Text -> Action
Replace Uri
uri (Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
0)) Text
code Text
code]
(Maybe Text, Maybe (Range, Text))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ []
pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text]
pathModuleNames :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> String
-> ExceptT PluginError IO [Text]
pathModuleNames Recorder (WithPriority Log)
recorder IdeState
state NormalizedFilePath
normFilePath String
filePath
| Char -> Bool
isLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
filePath = forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"Main"]
| Bool
otherwise = do
(HscEnvEq
session, PositionMapping
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"ModuleName.ghcSession" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
normFilePath
[String]
srcPaths <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv (HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq
session) forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
importPaths forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([String] -> Log
SrcPaths [String]
srcPaths)
let paths :: [String]
paths = forall a b. (a -> b) -> [a] -> [b]
map (ShowS
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
pathSeparator)) [String]
srcPaths
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([String] -> Log
NormalisedPaths [String]
paths)
String
mdlPath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute String
filePath
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (String -> Log
AbsoluteFilePath String
mdlPath)
let suffixes :: [String]
suffixes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Eq a => [a] -> [a] -> Maybe [a]
`stripPrefix` String
mdlPath) [String]
paths
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
moduleNameFrom [String]
suffixes)
where
moduleNameFrom :: String -> Text
moduleNameFrom =
String -> Text
T.pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate String
"."
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (a, [a])
uncons)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropExtension
codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text))
codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text))
codeModuleName IdeState
state NormalizedFilePath
nfp = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
(ParsedModule
pm, PositionMapping
mp) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> IdeState -> Action a -> IO a
runAction String
"ModuleName.GetParsedModule" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GetParsedModule
GetParsedModule NormalizedFilePath
nfp
L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> (RealSrcSpan RealSrcSpan
l Maybe BufSpan
_)) ModuleName
m <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> Maybe (GenLocated SrcSpanAnnA ModuleName)
hsmodName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm
Range
range <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mp (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Range
range, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
m)
data Log =
CorrectNames [T.Text]
| BestName (Maybe T.Text)
| ModuleName (Maybe T.Text)
| SrcPaths [FilePath]
| NormalisedPaths [FilePath]
| AbsoluteFilePath FilePath
deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty Log
log = Doc ann
"ModuleName." forall a. Semigroup a => a -> a -> a
<> case Log
log of
CorrectNames [Text]
log -> Doc ann
"CorrectNames" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [Text]
log
BestName Maybe Text
log -> Doc ann
"BestName" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
log
ModuleName Maybe Text
log -> Doc ann
"StatedNameMaybe" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
log
SrcPaths [String]
log -> Doc ann
"SrcPaths" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [String]
log
NormalisedPaths [String]
log -> Doc ann
"NormalisedPaths" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [String]
log
AbsoluteFilePath String
log -> Doc ann
"AbsoluteFilePath" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
log