{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}
{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

{- | Keep the module name in sync with its file path.

Provide CodeLenses to:
* Add a module header ("module /moduleName/ where") to empty Haskell files
* Fix the module name if incorrect
-}
module Ide.Plugin.ModuleName (
    descriptor,
) where

import           Control.Monad                (forM_, void)
import           Control.Monad.IO.Class       (liftIO)
import           Control.Monad.Trans.Class    (lift)
import           Control.Monad.Trans.Maybe
import           Data.Aeson                   (Value (Null), toJSON)
import           Data.Char                    (isLower)
import qualified Data.HashMap.Strict          as HashMap
import           Data.List                    (intercalate, isPrefixOf,
                                               minimumBy)
import qualified Data.List.NonEmpty           as NE
import           Data.Maybe                   (maybeToList)
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, Info), Recorder,
                                               WithPriority, colon, evalGhcEnv,
                                               hscEnvWithImportPaths, logWith,
                                               realSrcSpanToRange, runAction,
                                               uriToFilePath', use, use_, (<+>))
import           Development.IDE.GHC.Compat   (GenLocated (L),
                                               getSessionDynFlags, hsmodName,
                                               importPaths, locA,
                                               moduleNameString,
                                               pattern RealSrcSpan,
                                               pm_parsed_source, unLoc)
import           Development.IDE.Types.Logger (Pretty (..))
import           Ide.Types
import           Language.LSP.Server
import           Language.LSP.Types           hiding
                                              (SemanticTokenAbsolute (length, line),
                                               SemanticTokenRelative (length),
                                               SemanticTokensEdit (_start))
import           Language.LSP.VFS             (virtualFileText)
import           System.Directory             (makeAbsolute)
import           System.FilePath              (dropExtension, normalise,
                                               pathSeparator, splitDirectories,
                                               takeFileName)

-- |Plugin descriptor
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)
        { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeLens
STextDocumentCodeLens (Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens Recorder (WithPriority Log)
recorder)
        , pluginCommands :: [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"

-- | Generate code lenses
codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens :: Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens Recorder (WithPriority Log)
recorder IdeState
state PluginId
pluginId CodeLensParams{$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument=TextDocumentIdentifier Uri
uri} =
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> List a
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Action -> CodeLens
asCodeLens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> LspM c (Maybe Action)
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri
  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])

-- | (Quasi) Idempotent command execution: recalculate action to execute on command request
command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
command Recorder (WithPriority Log)
recorder IdeState
state Uri
uri = do
  Maybe Action
actMaybe <- forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> LspM c (Maybe 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_ Maybe 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
      -- | Convert an Action to the corresponding edit operation
      edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
aUri forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [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 (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
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 -> Either a b
Right Value
Null

-- | A source code change
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)

-- | Required action (that can be converted to either CodeLenses or CodeActions)
action :: Recorder (WithPriority Log) -> IdeState -> Uri -> LspM c (Maybe Action)
action :: forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> LspM c (Maybe Action)
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri =
  forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall 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
. NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
    String
fp <- 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
$ Uri -> Maybe String
uriToFilePath' 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> String -> 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)
    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 (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
$ 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
Info (Text -> Log
BestName 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 (Range, Text)
statedNameMaybe of
      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 forall a b. (a -> b) -> a -> b
$ 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
      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 forall a b. (a -> b) -> a -> b
$ 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 (Range, Text)
_ -> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Possible module names, as derived by the position of the module in the
-- source directories.  There may be more than one possible name, if the source
-- directories are nested inside each other.
pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> IO [T.Text]
pathModuleNames :: Recorder (WithPriority Log)
-> IdeState -> NormalizedFilePath -> String -> 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 <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"ModuleName.ghcSession" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
normFilePath
      [String]
srcPaths <- 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)

      -- Append a `pathSeparator` to make the path looks like a directory,
      --   and then we can drop it uniformly.
      -- See https://github.com/haskell/haskell-language-server/pull/3092 for details.
      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 <- 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 prefixes :: [String]
prefixes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
mdlPath) [String]
paths
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {a}. Foldable t => String -> t a -> Text
moduleNameFrom String
mdlPath) [String]
prefixes)
  where
    moduleNameFrom :: String -> t a -> Text
moduleNameFrom String
mdlPath t a
prefix =
      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
. String -> [String]
splitDirectories
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
prefix)
        forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension String
mdlPath

-- | The module name, as stated in the module
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 <- 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)
use 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
l, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
m)

data Log =
    CorrectNames [T.Text]
  | BestName 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 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 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