{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}
{-# OPTIONS_GHC -Wall -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,
) 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,
                                             evalGhcEnv, hscEnvWithImportPaths,
                                             realSrcSpanToRange, runAction,
                                             uriToFilePath', use, use_)
import           Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags,
                                             hsmodName, importPaths, locA,
                                             pattern RealSrcSpan,
                                             pm_parsed_source, unLoc, moduleNameString)
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, splitDirectories,
                                             takeFileName)

-- |Plugin descriptor
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId =
    (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
        { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentCodeLens
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeLens
STextDocumentCodeLens PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens
        , pluginCommands :: [PluginCommand IdeState]
pluginCommands = [CommandId
-> Text -> CommandFunction IdeState Uri -> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
forall p. IsString p => p
updateModuleNameCommand Text
"set name of module to match with file path" CommandFunction IdeState Uri
command]
        }

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

-- | Generate code lenses
codeLens :: PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens :: PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens IdeState
state PluginId
pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} =
  List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> (Maybe Action -> List CodeLens)
-> Maybe Action
-> Either ResponseError (List CodeLens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CodeLens] -> List CodeLens
forall a. [a] -> List a
List ([CodeLens] -> List CodeLens)
-> (Maybe Action -> [CodeLens]) -> Maybe Action -> List CodeLens
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CodeLens -> [CodeLens]
forall a. Maybe a -> [a]
maybeToList (Maybe CodeLens -> [CodeLens])
-> (Maybe Action -> Maybe CodeLens) -> Maybe Action -> [CodeLens]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Action -> CodeLens
asCodeLens (Action -> CodeLens) -> Maybe Action -> Maybe CodeLens
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Action -> Either ResponseError (List CodeLens))
-> LspT Config IO (Maybe Action)
-> LspT Config IO (Either ResponseError (List CodeLens))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdeState -> Uri -> LspT Config IO (Maybe Action)
forall c. IdeState -> Uri -> LspM c (Maybe Action)
action 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 (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 :: CommandFunction IdeState Uri
command :: CommandFunction IdeState Uri
command IdeState
state Uri
uri = do
  Maybe Action
actMaybe <- IdeState -> Uri -> LspT Config IO (Maybe Action)
forall c. IdeState -> Uri -> LspM c (Maybe Action)
action IdeState
state Uri
uri
  Maybe Action -> (Action -> LspT Config IO ()) -> LspT Config IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Action
actMaybe ((Action -> LspT Config IO ()) -> LspT Config IO ())
-> (Action -> LspT Config IO ()) -> LspT Config IO ()
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 (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (WorkspaceEditMap -> Maybe WorkspaceEditMap)
-> (List TextEdit -> WorkspaceEditMap)
-> List TextEdit
-> Maybe WorkspaceEditMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
aUri (List TextEdit -> Maybe WorkspaceEditMap)
-> List TextEdit -> Maybe WorkspaceEditMap
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> List TextEdit
forall a. [a] -> List a
List [Range -> Text -> TextEdit
TextEdit Range
aRange Text
aCode]) Maybe (List DocumentChange)
forall a. Maybe a
Nothing Maybe ChangeAnnotationMap
forall a. Maybe a
Nothing
    in
      LspT Config IO (LspId 'WorkspaceApplyEdit) -> LspT Config IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LspT Config IO (LspId 'WorkspaceApplyEdit) -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit) -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
edit) (LspT Config IO ()
-> Either ResponseError ApplyWorkspaceEditResponseBody
-> LspT Config IO ()
forall a b. a -> b -> a
const (() -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
  Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
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
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
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 :: IdeState -> Uri -> LspM c (Maybe Action)
action :: IdeState -> Uri -> LspM c (Maybe Action)
action IdeState
state Uri
uri =
  String -> LspM c (Maybe Action) -> LspM c (Maybe Action)
forall b a. b -> a -> a
traceAs String
"action" (LspM c (Maybe Action) -> LspM c (Maybe Action))
-> (MaybeT (LspT c IO) Action -> LspM c (Maybe Action))
-> MaybeT (LspT c IO) Action
-> LspM c (Maybe Action)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT (LspT c IO) Action -> LspM c (Maybe Action)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (LspT c IO) Action -> LspM c (Maybe Action))
-> MaybeT (LspT c IO) Action -> LspM c (Maybe Action)
forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- LspT c IO (Maybe NormalizedFilePath)
-> MaybeT (LspT c IO) NormalizedFilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LspT c IO (Maybe NormalizedFilePath)
 -> MaybeT (LspT c IO) NormalizedFilePath)
-> (NormalizedUri -> LspT c IO (Maybe NormalizedFilePath))
-> NormalizedUri
-> MaybeT (LspT c IO) NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe NormalizedFilePath -> LspT c IO (Maybe NormalizedFilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NormalizedFilePath -> LspT c IO (Maybe NormalizedFilePath))
-> (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri
-> LspT c IO (Maybe NormalizedFilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> MaybeT (LspT c IO) NormalizedFilePath)
-> NormalizedUri -> MaybeT (LspT c IO) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
    String
fp <- LspT c IO (Maybe String) -> MaybeT (LspT c IO) String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LspT c IO (Maybe String) -> MaybeT (LspT c IO) String)
-> (Maybe String -> LspT c IO (Maybe String))
-> Maybe String
-> MaybeT (LspT c IO) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> LspT c IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> MaybeT (LspT c IO) String)
-> Maybe String -> MaybeT (LspT c IO) String
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath' Uri
uri

    Maybe VirtualFile
contents <- LspT c IO (Maybe VirtualFile)
-> MaybeT (LspT c IO) (Maybe VirtualFile)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspT c IO (Maybe VirtualFile)
 -> MaybeT (LspT c IO) (Maybe VirtualFile))
-> (NormalizedUri -> LspT c IO (Maybe VirtualFile))
-> NormalizedUri
-> MaybeT (LspT c IO) (Maybe VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> LspT c IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (NormalizedUri -> MaybeT (LspT c IO) (Maybe VirtualFile))
-> NormalizedUri -> MaybeT (LspT c IO) (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 [Text] -> MaybeT (LspT c IO) [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> MaybeT (LspT c IO) [Text])
-> IO [Text] -> MaybeT (LspT c IO) [Text]
forall a b. (a -> b) -> a -> b
$ String -> [Text] -> [Text]
forall b a. b -> a -> a
traceAs String
"correctNames" ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdeState -> NormalizedFilePath -> String -> IO [Text]
pathModuleNames IdeState
state NormalizedFilePath
nfp String
fp
    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)
-> MaybeT (LspT c IO) (NonEmpty Text) -> MaybeT (LspT c IO) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LspT c IO (Maybe (NonEmpty Text))
-> MaybeT (LspT c IO) (NonEmpty Text)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LspT c IO (Maybe (NonEmpty Text))
 -> MaybeT (LspT c IO) (NonEmpty Text))
-> (Maybe (NonEmpty Text) -> LspT c IO (Maybe (NonEmpty Text)))
-> Maybe (NonEmpty Text)
-> MaybeT (LspT c IO) (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty Text) -> LspT c IO (Maybe (NonEmpty Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmpty Text) -> MaybeT (LspT c IO) (NonEmpty Text))
-> Maybe (NonEmpty Text) -> MaybeT (LspT c IO) (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
correctNames)

    Maybe (Range, Text)
statedNameMaybe <- IO (Maybe (Range, Text))
-> MaybeT (LspT c IO) (Maybe (Range, Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Range, Text))
 -> MaybeT (LspT c IO) (Maybe (Range, Text)))
-> IO (Maybe (Range, Text))
-> MaybeT (LspT c IO) (Maybe (Range, Text))
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Range, Text) -> Maybe (Range, Text)
forall b a. b -> a -> a
traceAs String
"statedName" (Maybe (Range, Text) -> Maybe (Range, Text))
-> IO (Maybe (Range, Text)) -> IO (Maybe (Range, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text))
codeModuleName IdeState
state NormalizedFilePath
nfp
    case Maybe (Range, Text)
statedNameMaybe of
      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 -> MaybeT (LspT c IO) Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action -> MaybeT (LspT c IO) Action)
-> Action -> MaybeT (LspT c IO) Action
forall a b. (a -> b) -> a -> b
$ 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
      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 -> MaybeT (LspT c IO) Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Action -> MaybeT (LspT c IO) Action)
-> Action -> MaybeT (LspT c IO) Action
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)
_ -> LspM c (Maybe Action) -> MaybeT (LspT c IO) Action
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LspM c (Maybe Action) -> MaybeT (LspT c IO) Action)
-> LspM c (Maybe Action) -> MaybeT (LspT c IO) Action
forall a b. (a -> b) -> a -> b
$ Maybe Action -> LspM c (Maybe Action)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Action
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 :: IdeState -> NormalizedFilePath -> String -> IO [T.Text]
pathModuleNames :: IdeState -> NormalizedFilePath -> String -> IO [Text]
pathModuleNames 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. [a] -> a
head (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
filePath = [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"Main"]
  | Bool
otherwise = do
      HscEnvEq
session <- String -> IdeState -> Action HscEnvEq -> IO HscEnvEq
forall a. String -> IdeState -> Action a -> IO a
runAction String
"ModuleName.ghcSession" IdeState
state (Action HscEnvEq -> IO HscEnvEq) -> Action HscEnvEq -> IO HscEnvEq
forall a b. (a -> b) -> a -> b
$ GhcSession -> NormalizedFilePath -> Action HscEnvEq
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
normFilePath
      [String]
srcPaths <- 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
      [String]
paths <- (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
makeAbsolute [String]
srcPaths
      String
mdlPath <- String -> IO String
makeAbsolute String
filePath
      let prefixes :: [String]
prefixes = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
mdlPath) [String]
paths
      [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Text
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
        (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
"."
        ([String] -> String) -> (String -> [String]) -> ShowS
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
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
prefix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        (String -> Text) -> String -> Text
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 = 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 <- IO (Maybe ParsedModule) -> MaybeT IO ParsedModule
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe ParsedModule) -> MaybeT IO ParsedModule)
-> (Action (Maybe ParsedModule) -> IO (Maybe ParsedModule))
-> Action (Maybe ParsedModule)
-> MaybeT IO ParsedModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> IdeState
-> Action (Maybe ParsedModule)
-> IO (Maybe ParsedModule)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"ModuleName.GetParsedModule" IdeState
state (Action (Maybe ParsedModule) -> MaybeT IO ParsedModule)
-> Action (Maybe ParsedModule) -> MaybeT IO ParsedModule
forall a b. (a -> b) -> a -> b
$ GetParsedModule
-> NormalizedFilePath -> Action (Maybe ParsedModule)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
nfp
  L (SrcSpan -> SrcSpan
forall a. a -> a
locA -> (RealSrcSpan RealSrcSpan
l Maybe ()
_)) ModuleName
m <- IO (Maybe (GenLocated SrcSpan ModuleName))
-> MaybeT IO (GenLocated SrcSpan ModuleName)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (GenLocated SrcSpan ModuleName))
 -> MaybeT IO (GenLocated SrcSpan ModuleName))
-> (ParsedSource -> IO (Maybe (GenLocated SrcSpan ModuleName)))
-> ParsedSource
-> MaybeT IO (GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (GenLocated SrcSpan ModuleName)
-> IO (Maybe (GenLocated SrcSpan ModuleName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GenLocated SrcSpan ModuleName)
 -> IO (Maybe (GenLocated SrcSpan ModuleName)))
-> (ParsedSource -> Maybe (GenLocated SrcSpan ModuleName))
-> ParsedSource
-> IO (Maybe (GenLocated SrcSpan ModuleName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule GhcPs -> Maybe (GenLocated SrcSpan ModuleName)
forall pass. HsModule pass -> Maybe (GenLocated SrcSpan ModuleName)
hsmodName (HsModule GhcPs -> Maybe (GenLocated SrcSpan ModuleName))
-> (ParsedSource -> HsModule GhcPs)
-> ParsedSource
-> Maybe (GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedSource -> HsModule GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ParsedSource -> MaybeT IO (GenLocated SrcSpan ModuleName))
-> ParsedSource -> MaybeT IO (GenLocated SrcSpan ModuleName)
forall a b. (a -> b) -> a -> b
$ ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm
  (Range, Text) -> MaybeT IO (Range, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
l, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
m)

-- traceAs :: Show a => String -> a -> a
-- traceAs lbl a = trace (lbl ++ " = " ++ show a) a

traceAs :: b -> a -> a
traceAs :: b -> a -> a
traceAs b
_ a
a = a
a