{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults #-}

{- | 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,
    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)

-- |Plugin descriptor
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
    (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides a code action to alter the module name if it is wrong")
        { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (codeLens recorder)
        , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)]
        }

updateModuleNameCommand :: IsString p => p
updateModuleNameCommand :: forall p. IsString p => p
updateModuleNameCommand = p
"updateModuleName"

-- | Generate code lenses
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 <- Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM Config) [Action]
forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri
  ([CodeLens] |? Null)
-> ExceptT PluginError (LspM Config) ([CodeLens] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CodeLens] |? Null)
 -> ExceptT PluginError (LspM Config) ([CodeLens] |? Null))
-> ([CodeLens] |? Null)
-> ExceptT PluginError (LspM Config) ([CodeLens] |? Null)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> [CodeLens] |? Null
forall a b. a -> a |? b
InL (Action -> CodeLens
asCodeLens  (Action -> CodeLens) -> [Action] -> [CodeLens]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Action]
res)
  where
    asCodeLens :: Action -> CodeLens
    asCodeLens :: Action -> CodeLens
asCodeLens Replace{Text
Range
Uri
aUri :: Uri
aRange :: Range
aTitle :: Text
aCode :: Text
aUri :: Action -> Uri
aRange :: Action -> Range
aTitle :: Action -> Text
aCode :: Action -> Text
..} = Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
aRange (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd) Maybe Value
forall a. Maybe a
Nothing
      where
        cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
pluginId CommandId
forall p. IsString p => p
updateModuleNameCommand Text
aTitle ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Uri -> Value
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 Maybe ProgressToken
_ Uri
uri = do
  [Action]
actMaybe <- Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM Config) [Action]
forall c.
Recorder (WithPriority Log)
-> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]
action Recorder (WithPriority Log)
recorder IdeState
state Uri
uri
  [Action]
-> (Action -> ExceptT PluginError (LspM Config) ())
-> ExceptT PluginError (LspM Config) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Action]
actMaybe ((Action -> ExceptT PluginError (LspM Config) ())
 -> ExceptT PluginError (LspM Config) ())
-> (Action -> ExceptT PluginError (LspM Config) ())
-> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ \Replace{Text
Range
Uri
aUri :: Action -> Uri
aRange :: Action -> Range
aTitle :: Action -> Text
aCode :: Action -> Text
aUri :: Uri
aRange :: Range
aTitle :: Text
aCode :: Text
..} ->
    let
      -- | Convert an Action to the corresponding edit operation
      edit :: WorkspaceEdit
edit = 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]
forall k a. k -> a -> Map k a
Map.singleton Uri
aUri [Range -> Text -> TextEdit
TextEdit Range
aRange Text
aCode]) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
    in
      ExceptT
  PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT PluginError (LspM Config) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT PluginError (LspM Config) ())
-> ExceptT
     PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ LspM Config (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 (LspM Config (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT
      PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit))
-> LspM Config (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 ())
-> LspM Config (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
edit) (LspT Config IO ()
-> Either ResponseError ApplyWorkspaceEditResult
-> LspT Config IO ()
forall a b. a -> b -> a
const (() -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure ((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

-- | 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
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Action -> ShowS
showsPrec :: Int -> Action -> ShowS
$cshow :: Action -> String
show :: Action -> String
$cshowList :: [Action] -> ShowS
showList :: [Action] -> ShowS
Show)

-- | Required action (that can be converted to either CodeLenses or CodeActions)
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 <- Uri -> ExceptT PluginError (LspM c) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE  Uri
uri
    String
fp <- Uri -> ExceptT PluginError (LspM c) String
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m String
uriToFilePathE Uri
uri

    Maybe VirtualFile
contents <- LspM c (Maybe VirtualFile)
-> ExceptT PluginError (LspM c) (Maybe VirtualFile)
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 c (Maybe VirtualFile)
 -> ExceptT PluginError (LspM c) (Maybe VirtualFile))
-> (NormalizedUri -> LspM c (Maybe VirtualFile))
-> NormalizedUri
-> ExceptT PluginError (LspM c) (Maybe VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> LspM c (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (NormalizedUri -> ExceptT PluginError (LspM c) (Maybe VirtualFile))
-> NormalizedUri
-> ExceptT PluginError (LspM c) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
    let emptyModule :: Bool
emptyModule = Bool -> (VirtualFile -> Bool) -> Maybe VirtualFile -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> Bool
T.null (Text -> Bool) -> (VirtualFile -> Text) -> VirtualFile -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (VirtualFile -> Text) -> VirtualFile -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VirtualFile -> Text
virtualFileText) Maybe VirtualFile
contents

    [Text]
correctNames <- (IO (Either PluginError [Text])
 -> LspM c (Either PluginError [Text]))
-> ExceptT PluginError IO [Text]
-> ExceptT PluginError (LspM c) [Text]
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT IO (Either PluginError [Text])
-> LspM c (Either PluginError [Text])
forall a. IO a -> LspT c IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT PluginError IO [Text]
 -> ExceptT PluginError (LspM c) [Text])
-> ExceptT PluginError IO [Text]
-> ExceptT PluginError (LspM c) [Text]
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
    Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (LspM c) ()
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 = (Text -> Text -> Ordering) -> NonEmpty Text -> Text
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Text -> Int) -> Text -> Text -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Text -> Int
T.length) (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
correctNames
    Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (LspM c) ()
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 <- IO (Maybe (Range, Text))
-> ExceptT PluginError (LspM c) (Maybe (Range, Text))
forall a. IO a -> ExceptT PluginError (LspM c) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Range, Text))
 -> ExceptT PluginError (LspM c) (Maybe (Range, Text)))
-> IO (Maybe (Range, Text))
-> ExceptT PluginError (LspM c) (Maybe (Range, Text))
forall a b. (a -> b) -> a -> b
$ IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text))
codeModuleName IdeState
state NormalizedFilePath
nfp
    Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (LspM c) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Maybe Text -> Log
ModuleName (Maybe Text -> Log) -> Maybe Text -> Log
forall a b. (a -> b) -> a -> b
$ (Range, Text) -> Text
forall a b. (a, b) -> b
snd ((Range, Text) -> Text) -> Maybe (Range, Text) -> Maybe Text
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 Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
correctNames ->
            [Action] -> ExceptT PluginError (LspM c) [Action]
forall a. a -> ExceptT PluginError (LspM c) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Uri -> Range -> Text -> Text -> Action
Replace Uri
uri Range
nameRange (Text
"Set module name to " Text -> Text -> Text
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bestName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
            in [Action] -> ExceptT PluginError (LspM c) [Action]
forall a. a -> ExceptT PluginError (LspM c) a
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))
_ -> [Action] -> ExceptT PluginError (LspM c) [Action]
forall a. a -> ExceptT PluginError (LspM c) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | 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 -> 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 (Char -> Bool) -> (String -> Char) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. HasCallStack => [a] -> a
head (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
filePath = [Text] -> ExceptT PluginError IO [Text]
forall a. a -> ExceptT PluginError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"Main"]
  | Bool
otherwise = do
      (HscEnvEq
session, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError IO (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"ModuleName.ghcSession" IdeState
state (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT PluginError IO (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError IO (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
normFilePath
      [String]
srcPaths <- IO [String] -> ExceptT PluginError IO [String]
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ExceptT PluginError IO [String])
-> IO [String] -> ExceptT PluginError IO [String]
forall a b. (a -> b) -> a -> b
$ HscEnv -> Ghc [String] -> IO [String]
forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv (HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq
session) (Ghc [String] -> IO [String]) -> Ghc [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
importPaths (DynFlags -> [String]) -> Ghc DynFlags -> Ghc [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError IO ()
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 = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
normalise ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
pathSeparator)) [String]
srcPaths
      Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError IO ()
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 <- IO String -> ExceptT PluginError IO String
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT PluginError IO String)
-> IO String -> ExceptT PluginError IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute String
filePath
      Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError IO ()
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 = (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
`stripPrefix` String
mdlPath) [String]
paths
      [Text] -> ExceptT PluginError IO [Text]
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
moduleNameFrom [String]
suffixes)
  where
    moduleNameFrom :: String -> Text
moduleNameFrom =
      String -> Text
T.pack
        (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"."
        -- Do not suggest names whose components start from a lower-case char,
        -- they are guaranteed to be malformed.
        ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> ((Char, String) -> Bool) -> Maybe (Char, String) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
isUpper (Char -> Bool)
-> ((Char, String) -> Char) -> (Char, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, String) -> Char
forall a b. (a, b) -> a
fst) (Maybe (Char, String) -> Bool)
-> (String -> Maybe (Char, String)) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (Char, String)
forall a. [a] -> Maybe (a, [a])
uncons)
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
        (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropExtension

-- | 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 = MaybeT IO (Range, Text) -> IO (Maybe (Range, Text))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (Range, Text) -> IO (Maybe (Range, Text)))
-> MaybeT IO (Range, Text) -> IO (Maybe (Range, Text))
forall a b. (a -> b) -> a -> b
$ do
  (ParsedModule
pm, PositionMapping
mp) <- IO (Maybe (ParsedModule, PositionMapping))
-> MaybeT IO (ParsedModule, PositionMapping)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (ParsedModule, PositionMapping))
 -> MaybeT IO (ParsedModule, PositionMapping))
-> (Action (Maybe (ParsedModule, PositionMapping))
    -> IO (Maybe (ParsedModule, PositionMapping)))
-> Action (Maybe (ParsedModule, PositionMapping))
-> MaybeT IO (ParsedModule, PositionMapping)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> IdeState
-> Action (Maybe (ParsedModule, PositionMapping))
-> IO (Maybe (ParsedModule, PositionMapping))
forall a. String -> IdeState -> Action a -> IO a
runAction String
"ModuleName.GetParsedModule" IdeState
state (Action (Maybe (ParsedModule, PositionMapping))
 -> MaybeT IO (ParsedModule, PositionMapping))
-> Action (Maybe (ParsedModule, PositionMapping))
-> MaybeT IO (ParsedModule, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetParsedModule
-> NormalizedFilePath
-> Action (Maybe (ParsedModule, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale GetParsedModule
GetParsedModule NormalizedFilePath
nfp
  L (SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA -> (RealSrcSpan RealSrcSpan
l Maybe BufSpan
_)) ModuleName
m <- IO
  (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
-> MaybeT
     IO (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO
   (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
 -> MaybeT
      IO (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
-> (ParsedSource
    -> IO
         (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)))
-> ParsedSource
-> MaybeT
     IO (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
-> IO
     (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
 -> IO
      (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)))
-> (ParsedSource
    -> Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
-> ParsedSource
-> IO
     (Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
HsModule GhcPs
-> Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName (HsModule GhcPs
 -> Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
-> (ParsedSource -> HsModule GhcPs)
-> ParsedSource
-> Maybe (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedSource -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc (ParsedSource
 -> MaybeT
      IO (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName))
-> ParsedSource
-> MaybeT
     IO (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) ModuleName)
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm
  Range
range <- IO (Maybe Range) -> MaybeT IO Range
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Range) -> MaybeT IO Range)
-> (Maybe Range -> IO (Maybe Range))
-> Maybe Range
-> MaybeT IO Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Range -> IO (Maybe Range)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Range -> MaybeT IO Range) -> Maybe Range -> MaybeT IO Range
forall a b. (a -> b) -> a -> b
$ PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mp (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
l)
  (Range, Text) -> MaybeT IO (Range, Text)
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Range
range, String -> Text
T.pack (String -> Text) -> String -> Text
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
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty Log
log = Doc ann
"ModuleName." Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> case Log
log of
    CorrectNames [Text]
log     -> Doc ann
"CorrectNames" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Text] -> Doc ann
forall ann. [Text] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
log
    BestName Maybe Text
log         -> Doc ann
"BestName" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Text -> Doc ann
forall ann. Maybe Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
log
    ModuleName Maybe Text
log       -> Doc ann
"StatedNameMaybe" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Text -> Doc ann
forall ann. Maybe Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
log
    SrcPaths [String]
log         -> Doc ann
"SrcPaths" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [String] -> Doc ann
forall ann. [String] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [String]
log
    NormalisedPaths [String]
log  -> Doc ann
"NormalisedPaths" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [String] -> Doc ann
forall ann. [String] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [String]
log
    AbsoluteFilePath String
log -> Doc ann
"AbsoluteFilePath" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
log