{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE ViewPatterns       #-}

module Ide.Plugin.ExplicitImports
  ( descriptor
  , descriptorForModules
  , extractMinimalImports
  , within
  , abbreviateImportTitle
  , Log(..)
  ) where

import           Control.DeepSeq
import           Control.Monad.IO.Class
import           Data.Aeson                           (ToJSON (toJSON),
                                                       Value (Null))
import           Data.Aeson.Types                     (FromJSON)
import qualified Data.HashMap.Strict                  as HashMap
import           Data.IORef                           (readIORef)
import qualified Data.Map.Strict                      as Map
import           Data.Maybe                           (catMaybes, fromMaybe,
                                                       isJust)
import           Data.String                          (fromString)
import qualified Data.Text                            as T
import           Development.IDE                      hiding (pluginHandlers,
                                                       pluginRules)
import           Development.IDE.Core.PositionMapping
import qualified Development.IDE.Core.Shake           as Shake
import           Development.IDE.GHC.Compat
import           Development.IDE.Graph.Classes
import           Development.IDE.Types.Logger         as Logger (Pretty (pretty))
import           GHC.Generics                         (Generic)
import           Ide.PluginUtils                      (mkLspCommand)
import           Ide.Types
import           Language.LSP.Server
import           Language.LSP.Types

importCommandId :: CommandId
importCommandId :: CommandId
importCommandId = CommandId
"ImportLensCommand"

newtype Log
  = LogShake Shake.Log
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> [Char]
$cshow :: Log -> [Char]
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log

-- | The "main" function of a plugin
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder =
    -- (almost) no one wants to see an explicit import list for Prelude
    Recorder (WithPriority Log)
-> (ModuleName -> Bool) -> PluginId -> PluginDescriptor IdeState
descriptorForModules Recorder (WithPriority Log)
recorder (forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
pRELUDE)

descriptorForModules
    :: Recorder (WithPriority Log)
    -> (ModuleName -> Bool)
      -- ^ Predicate to select modules that will be annotated
    -> PluginId
    -> PluginDescriptor IdeState
descriptorForModules :: Recorder (WithPriority Log)
-> (ModuleName -> Bool) -> PluginId -> PluginDescriptor IdeState
descriptorForModules Recorder (WithPriority Log)
recorder ModuleName -> Bool
pred PluginId
plId =
  (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
    {
      -- This plugin provides a command handler
      pluginCommands :: [PluginCommand IdeState]
pluginCommands = [PluginCommand IdeState
importLensCommand],
      -- This plugin defines a new rule
      pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
minimalImportsRule Recorder (WithPriority Log)
recorder,
      pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall a. Monoid a => [a] -> a
mconcat
        [ -- This plugin provides code lenses
          forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeLens
STextDocumentCodeLens forall a b. (a -> b) -> a -> b
$ (ModuleName -> Bool)
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
lensProvider ModuleName -> Bool
pred
          -- This plugin provides code actions
        , forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction forall a b. (a -> b) -> a -> b
$ (ModuleName -> Bool)
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider ModuleName -> Bool
pred
        ]
    }

-- | The command descriptor
importLensCommand :: PluginCommand IdeState
importLensCommand :: PluginCommand IdeState
importLensCommand =
  forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
importCommandId Text
"Explicit import command" CommandFunction IdeState ImportCommandParams
runImportCommand

-- | The type of the parameters accepted by our command
newtype ImportCommandParams = ImportCommandParams WorkspaceEdit
  deriving (forall x. Rep ImportCommandParams x -> ImportCommandParams
forall x. ImportCommandParams -> Rep ImportCommandParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ImportCommandParams x -> ImportCommandParams
$cfrom :: forall x. ImportCommandParams -> Rep ImportCommandParams x
Generic)
  deriving anyclass (Value -> Parser [ImportCommandParams]
Value -> Parser ImportCommandParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ImportCommandParams]
$cparseJSONList :: Value -> Parser [ImportCommandParams]
parseJSON :: Value -> Parser ImportCommandParams
$cparseJSON :: Value -> Parser ImportCommandParams
FromJSON, [ImportCommandParams] -> Encoding
[ImportCommandParams] -> Value
ImportCommandParams -> Encoding
ImportCommandParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ImportCommandParams] -> Encoding
$ctoEncodingList :: [ImportCommandParams] -> Encoding
toJSONList :: [ImportCommandParams] -> Value
$ctoJSONList :: [ImportCommandParams] -> Value
toEncoding :: ImportCommandParams -> Encoding
$ctoEncoding :: ImportCommandParams -> Encoding
toJSON :: ImportCommandParams -> Value
$ctoJSON :: ImportCommandParams -> Value
ToJSON)

-- | The actual command handler
runImportCommand :: CommandFunction IdeState ImportCommandParams
runImportCommand :: CommandFunction IdeState ImportCommandParams
runImportCommand IdeState
_state (ImportCommandParams WorkspaceEdit
edit) = do
  -- This command simply triggers a workspace edit!
  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 SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Value
Null)

-- | For every implicit import statement, return a code lens of the corresponding explicit import
-- Example - for the module below:
--
-- > import Data.List
-- >
-- > f = intercalate " " . sortBy length
--
-- the provider should produce one code lens associated to the import statement:
--
-- > import Data.List (intercalate, sortBy)
lensProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState TextDocumentCodeLens
lensProvider :: (ModuleName -> Bool)
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
lensProvider
  ModuleName -> Bool
pred
  IdeState
state -- ghcide state, used to retrieve typechecking artifacts
  PluginId
pId -- plugin Id
  CodeLensParams {$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument = TextDocumentIdentifier {Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri}}
    -- VSCode uses URIs instead of file paths
    -- haskell-lsp provides conversion functions
    | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
_uri = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      do
        Maybe (MinimalImportsResult, PositionMapping)
mbMinImports <- forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale MinimalImports
MinimalImports NormalizedFilePath
nfp
        case Maybe (MinimalImportsResult, PositionMapping)
mbMinImports of
          -- Implement the provider logic:
          -- for every import, if it's lacking a explicit list, generate a code lens
          Just (MinimalImportsResult [(LImportDecl GhcRn, Maybe Text)]
minImports, PositionMapping
posMapping) -> do
            [Maybe CodeLens]
commands <-
              forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                [ PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens)
generateLens PluginId
pId Uri
_uri TextEdit
edit
                  | (GenLocated SrcSpanAnnA (ImportDecl GhcRn)
imp, Just Text
minImport) <- [(LImportDecl GhcRn, Maybe Text)]
minImports,
                    Just TextEdit
edit <- [(ModuleName -> Bool)
-> PositionMapping -> LImportDecl GhcRn -> Text -> Maybe TextEdit
mkExplicitEdit ModuleName -> Bool
pred PositionMapping
posMapping GenLocated SrcSpanAnnA (ImportDecl GhcRn)
imp Text
minImport]
                ]
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall a. [a] -> List a
List forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe CodeLens]
commands)
          Maybe (MinimalImportsResult, PositionMapping)
_ ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall a. [a] -> List a
List [])
    | Bool
otherwise =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall a. [a] -> List a
List [])

-- | If there are any implicit imports, provide one code action to turn them all
--   into explicit imports.
codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: (ModuleName -> Bool)
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider ModuleName -> Bool
pred IdeState
ideState PluginId
_pId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
range CodeActionContext
_context)
  | TextDocumentIdentifier {Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} <- TextDocumentIdentifier
docId,
    Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
_uri = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do
      Maybe ParsedModule
pm <- forall a. IdeState -> Action a -> IO a
runIde IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
nfp
      let insideImport :: Bool
insideImport = case Maybe ParsedModule
pm of
            Just ParsedModule {ParsedSource
pm_parsed_source :: ParsedModule -> ParsedSource
pm_parsed_source :: ParsedSource
pm_parsed_source}
              | [LImportDecl GhcPs]
locImports <- HsModule -> [LImportDecl GhcPs]
hsmodImports (forall l e. GenLocated l e -> e
unLoc ParsedSource
pm_parsed_source),
                [SrcSpan]
rangesImports <- forall a b. (a -> b) -> [a] -> [b]
map forall a. HasSrcSpan a => a -> SrcSpan
getLoc [LImportDecl GhcPs]
locImports ->
                forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Range -> SrcSpan -> Bool
within Range
range) [SrcSpan]
rangesImports
            Maybe ParsedModule
_ -> Bool
False
      if Bool -> Bool
not Bool
insideImport
        then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (forall a. [a] -> List a
List []))
        else do
          Maybe MinimalImportsResult
minImports <- forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"MinimalImports" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use MinimalImports
MinimalImports NormalizedFilePath
nfp
          let edits :: [TextEdit]
edits =
                [ TextEdit
e
                  | (GenLocated SrcSpanAnnA (ImportDecl GhcRn)
imp, Just Text
explicit) <-
                      forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] MinimalImportsResult -> [(LImportDecl GhcRn, Maybe Text)]
getMinimalImportsResult Maybe MinimalImportsResult
minImports,
                    Just TextEdit
e <- [(ModuleName -> Bool)
-> PositionMapping -> LImportDecl GhcRn -> Text -> Maybe TextEdit
mkExplicitEdit ModuleName -> Bool
pred PositionMapping
zeroMapping GenLocated SrcSpanAnnA (ImportDecl GhcRn)
imp Text
explicit]
                ]
              caExplicitImports :: Command |? CodeAction
caExplicitImports = forall a b. b -> a |? b
InR CodeAction {Maybe WorkspaceEdit
Maybe CodeActionKind
Text
forall a. Maybe a
$sel:_title:CodeAction :: Text
$sel:_kind:CodeAction :: Maybe CodeActionKind
$sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
$sel:_isPreferred:CodeAction :: Maybe Bool
$sel:_disabled:CodeAction :: Maybe Reason
$sel:_edit:CodeAction :: Maybe WorkspaceEdit
$sel:_command:CodeAction :: Maybe Command
$sel:_xdata:CodeAction :: Maybe Value
_xdata :: forall a. Maybe a
_disabled :: forall a. Maybe a
_isPreferred :: forall a. Maybe a
_diagnostics :: forall a. Maybe a
_edit :: Maybe WorkspaceEdit
_command :: forall a. Maybe a
_kind :: Maybe CodeActionKind
_title :: Text
..}
              _title :: Text
_title = Text
"Make all imports explicit"
              _kind :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
CodeActionQuickFix
              _command :: Maybe a
_command = forall a. Maybe a
Nothing
              _edit :: Maybe WorkspaceEdit
_edit = forall a. a -> Maybe a
Just WorkspaceEdit {Maybe (HashMap Uri (List TextEdit))
$sel:_changes:WorkspaceEdit :: Maybe (HashMap Uri (List TextEdit))
_changes :: Maybe (HashMap Uri (List TextEdit))
_changes, forall a. Maybe a
$sel:_documentChanges:WorkspaceEdit :: Maybe (List DocumentChange)
_documentChanges :: forall a. Maybe a
_documentChanges, forall a. Maybe a
$sel:_changeAnnotations:WorkspaceEdit :: Maybe ChangeAnnotationMap
_changeAnnotations :: forall a. Maybe a
_changeAnnotations}
              _changes :: Maybe (HashMap Uri (List TextEdit))
_changes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Uri
_uri forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [TextEdit]
edits
              _documentChanges :: Maybe a
_documentChanges = forall a. Maybe a
Nothing
              _diagnostics :: Maybe a
_diagnostics = forall a. Maybe a
Nothing
              _isPreferred :: Maybe a
_isPreferred = forall a. Maybe a
Nothing
              _disabled :: Maybe a
_disabled = forall a. Maybe a
Nothing
              _xdata :: Maybe a
_xdata = forall a. Maybe a
Nothing
              _changeAnnotations :: Maybe a
_changeAnnotations = forall a. Maybe a
Nothing
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [Command |? CodeAction
caExplicitImports | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TextEdit]
edits)]
  | Bool
otherwise =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List []

--------------------------------------------------------------------------------

data MinimalImports = MinimalImports
  deriving (Int -> MinimalImports -> ShowS
[MinimalImports] -> ShowS
MinimalImports -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MinimalImports] -> ShowS
$cshowList :: [MinimalImports] -> ShowS
show :: MinimalImports -> [Char]
$cshow :: MinimalImports -> [Char]
showsPrec :: Int -> MinimalImports -> ShowS
$cshowsPrec :: Int -> MinimalImports -> ShowS
Show, forall x. Rep MinimalImports x -> MinimalImports
forall x. MinimalImports -> Rep MinimalImports x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MinimalImports x -> MinimalImports
$cfrom :: forall x. MinimalImports -> Rep MinimalImports x
Generic, MinimalImports -> MinimalImports -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MinimalImports -> MinimalImports -> Bool
$c/= :: MinimalImports -> MinimalImports -> Bool
== :: MinimalImports -> MinimalImports -> Bool
$c== :: MinimalImports -> MinimalImports -> Bool
Eq, Eq MinimalImports
MinimalImports -> MinimalImports -> Bool
MinimalImports -> MinimalImports -> Ordering
MinimalImports -> MinimalImports -> MinimalImports
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MinimalImports -> MinimalImports -> MinimalImports
$cmin :: MinimalImports -> MinimalImports -> MinimalImports
max :: MinimalImports -> MinimalImports -> MinimalImports
$cmax :: MinimalImports -> MinimalImports -> MinimalImports
>= :: MinimalImports -> MinimalImports -> Bool
$c>= :: MinimalImports -> MinimalImports -> Bool
> :: MinimalImports -> MinimalImports -> Bool
$c> :: MinimalImports -> MinimalImports -> Bool
<= :: MinimalImports -> MinimalImports -> Bool
$c<= :: MinimalImports -> MinimalImports -> Bool
< :: MinimalImports -> MinimalImports -> Bool
$c< :: MinimalImports -> MinimalImports -> Bool
compare :: MinimalImports -> MinimalImports -> Ordering
$ccompare :: MinimalImports -> MinimalImports -> Ordering
Ord)

instance Hashable MinimalImports

instance NFData MinimalImports

type instance RuleResult MinimalImports = MinimalImportsResult

newtype MinimalImportsResult = MinimalImportsResult
  {MinimalImportsResult -> [(LImportDecl GhcRn, Maybe Text)]
getMinimalImportsResult :: [(LImportDecl GhcRn, Maybe T.Text)]}

instance Show MinimalImportsResult where show :: MinimalImportsResult -> [Char]
show MinimalImportsResult
_ = [Char]
"<minimalImportsResult>"

instance NFData MinimalImportsResult where rnf :: MinimalImportsResult -> ()
rnf = forall a. a -> ()
rwhnf

exportedModuleStrings :: ParsedModule -> [String]
exportedModuleStrings :: ParsedModule -> [[Char]]
exportedModuleStrings ParsedModule{pm_parsed_source :: ParsedModule -> ParsedSource
pm_parsed_source = L SrcSpan
_ HsModule{[LHsDecl GhcPs]
[LImportDecl GhcPs]
Maybe (LocatedP WarningTxt)
Maybe (LocatedA ModuleName)
Maybe (LocatedL [LIE GhcPs])
Maybe LHsDocString
EpAnn AnnsModule
LayoutInfo
hsmodAnn :: HsModule -> EpAnn AnnsModule
hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDeprecMessage :: HsModule -> Maybe (LocatedP WarningTxt)
hsmodExports :: HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodHaddockModHeader :: HsModule -> Maybe LHsDocString
hsmodLayout :: HsModule -> LayoutInfo
hsmodName :: HsModule -> Maybe (LocatedA ModuleName)
hsmodHaddockModHeader :: Maybe LHsDocString
hsmodDeprecMessage :: Maybe (LocatedP WarningTxt)
hsmodDecls :: [LHsDecl GhcPs]
hsmodImports :: [LImportDecl GhcPs]
hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodName :: Maybe (LocatedA ModuleName)
hsmodLayout :: LayoutInfo
hsmodAnn :: EpAnn AnnsModule
hsmodImports :: HsModule -> [LImportDecl GhcPs]
..}}
  | Just LocatedL [LIE GhcPs]
export <- Maybe (LocatedL [LIE GhcPs])
hsmodExports,
    [GenLocated SrcSpanAnnA (IE GhcPs)]
exports <- forall l e. GenLocated l e -> e
unLoc LocatedL [LIE GhcPs]
export
    = forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable) [GenLocated SrcSpanAnnA (IE GhcPs)]
exports
exportedModuleStrings ParsedModule
_ = []

minimalImportsRule :: Recorder (WithPriority Log) -> Rules ()
minimalImportsRule :: Recorder (WithPriority Log) -> Rules ()
minimalImportsRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \MinimalImports
MinimalImports NormalizedFilePath
nfp -> do
  -- Get the typechecking artifacts from the module
  Maybe TcModuleResult
tmr <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp
  -- We also need a GHC session with all the dependencies
  Maybe HscEnvEq
hsc <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
  -- Use the GHC api to extract the "minimal" imports
  ([GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
imports, Maybe [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
mbMinImports) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe HscEnvEq
-> Maybe TcModuleResult
-> IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn])
extractMinimalImports Maybe HscEnvEq
hsc Maybe TcModuleResult
tmr
  let importsMap :: Map RealSrcLoc Text
importsMap =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
l, forall a. Outputable a => a -> Text
printOutputable ImportDecl GhcRn
i)
            | L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> RealSrcSpan RealSrcSpan
l Maybe BufSpan
_) ImportDecl GhcRn
i <- forall a. a -> Maybe a -> a
fromMaybe [] Maybe [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
mbMinImports
          ]
      res :: [(GenLocated SrcSpanAnnA (ImportDecl GhcRn), Maybe Text)]
res =
        [ (GenLocated SrcSpanAnnA (ImportDecl GhcRn)
i, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
l) Map RealSrcLoc Text
importsMap)
          | GenLocated SrcSpanAnnA (ImportDecl GhcRn)
i <- [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
imports
          , RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ <- [forall a. HasSrcSpan a => a -> SrcSpan
getLoc GenLocated SrcSpanAnnA (ImportDecl GhcRn)
i]
        ]
  forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(LImportDecl GhcRn, Maybe Text)] -> MinimalImportsResult
MinimalImportsResult [(GenLocated SrcSpanAnnA (ImportDecl GhcRn), Maybe Text)]
res forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
mbMinImports)

--------------------------------------------------------------------------------

-- | Use the ghc api to extract a minimal, explicit set of imports for this module
extractMinimalImports ::
  Maybe HscEnvEq ->
  Maybe TcModuleResult ->
  IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn])
extractMinimalImports :: Maybe HscEnvEq
-> Maybe TcModuleResult
-> IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn])
extractMinimalImports (Just HscEnvEq
hsc) (Just TcModuleResult {Bool
RenamedSource
ParsedModule
TcGblEnv
ModuleEnv ByteString
Splices
tmrParsed :: TcModuleResult -> ParsedModule
tmrRenamed :: TcModuleResult -> RenamedSource
tmrTypechecked :: TcModuleResult -> TcGblEnv
tmrTopLevelSplices :: TcModuleResult -> Splices
tmrDeferedError :: TcModuleResult -> Bool
tmrRuntimeModules :: TcModuleResult -> ModuleEnv ByteString
tmrRuntimeModules :: ModuleEnv ByteString
tmrDeferedError :: Bool
tmrTopLevelSplices :: Splices
tmrTypechecked :: TcGblEnv
tmrRenamed :: RenamedSource
tmrParsed :: ParsedModule
..}) = do
  -- extract the original imports and the typechecking environment
  let tcEnv :: TcGblEnv
tcEnv = TcGblEnv
tmrTypechecked
      (HsGroup GhcRn
_, [LImportDecl GhcRn]
imports, Maybe [(LIE GhcRn, Avails)]
_, Maybe LHsDocString
_) = RenamedSource
tmrRenamed
      ParsedModule {pm_parsed_source :: ParsedModule -> ParsedSource
pm_parsed_source = L SrcSpan
loc HsModule
_} = ParsedModule
tmrParsed
      emss :: [[Char]]
emss = ParsedModule -> [[Char]]
exportedModuleStrings ParsedModule
tmrParsed
      span :: RealSrcSpan
span = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"expected real") forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe RealSrcSpan
realSpan SrcSpan
loc
  -- Don't make suggestions for modules which are also exported, the user probably doesn't want this!
  -- See https://github.com/haskell/haskell-language-server/issues/2079
  let notExportedImports :: [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
notExportedImports = forall a. (a -> Bool) -> [a] -> [a]
filter ([[Char]] -> LImportDecl GhcRn -> Bool
notExported [[Char]]
emss) [LImportDecl GhcRn]
imports

  -- GHC is secretly full of mutable state
  [GlobalRdrElt]
gblElts <- forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef [GlobalRdrElt]
tcg_used_gres TcGblEnv
tcEnv)

  -- call findImportUsage does exactly what we need
  -- GHC is full of treats like this
  let usage :: [ImportDeclUsage]
usage = [LImportDecl GhcRn] -> [GlobalRdrElt] -> [ImportDeclUsage]
findImportUsage [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
notExportedImports [GlobalRdrElt]
gblElts
  (Messages DecoratedSDoc
_, Maybe [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
minimalImports) <-
    forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl (HscEnvEq -> HscEnv
hscEnv HscEnvEq
hsc) TcGblEnv
tcEnv RealSrcSpan
span forall a b. (a -> b) -> a -> b
$ [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
getMinimalImports [ImportDeclUsage]
usage

  -- return both the original imports and the computed minimal ones
  forall (m :: * -> *) a. Monad m => a -> m a
return ([LImportDecl GhcRn]
imports, Maybe [GenLocated SrcSpanAnnA (ImportDecl GhcRn)]
minimalImports)
  where
      notExported :: [String] -> LImportDecl GhcRn -> Bool
      notExported :: [[Char]] -> LImportDecl GhcRn -> Bool
notExported []  LImportDecl GhcRn
_ = Bool
True
      notExported [[Char]]
exports (L SrcSpanAnnA
_ ImportDecl{ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName = L SrcSpanAnnA
_ ModuleName
name}) =
          Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[Char]
e -> ([Char]
"module " forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString ModuleName
name) forall a. Eq a => a -> a -> Bool
== [Char]
e) [[Char]]
exports
extractMinimalImports Maybe HscEnvEq
_ Maybe TcModuleResult
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)

mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit
mkExplicitEdit :: (ModuleName -> Bool)
-> PositionMapping -> LImportDecl GhcRn -> Text -> Maybe TextEdit
mkExplicitEdit ModuleName -> Bool
pred PositionMapping
posMapping (L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
src) ImportDecl GhcRn
imp) Text
explicit
  -- Explicit import list case
  | ImportDecl {ideclHiding :: forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding = Just (Bool
False, XRec GhcRn [LIE GhcRn]
_)} <- ImportDecl GhcRn
imp =
    forall a. Maybe a
Nothing
  | Bool -> Bool
not (forall a. ImportDecl a -> Bool
isQualifiedImport ImportDecl GhcRn
imp),
    RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ <- SrcSpan
src,
    L SrcSpanAnnA
_ ModuleName
mn <- forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcRn
imp,
    ModuleName -> Bool
pred ModuleName
mn,
    Just Range
rng <- PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
posMapping forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
l =
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Range -> Text -> TextEdit
TextEdit Range
rng Text
explicit
  | Bool
otherwise =
    forall a. Maybe a
Nothing

-- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things,
-- but at the moment I don't believe we know it.
-- 80 columns is traditional, but Haskellers tend to use longer lines (citation needed) and it's
-- probably not too bad if the lens is a *bit* longer than normal lines.
maxColumns :: Int
maxColumns :: Int
maxColumns = Int
120

-- | Given an import declaration, generate a code lens unless it has an
-- explicit import list or it's qualified
generateLens :: PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens)
generateLens :: PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens)
generateLens PluginId
pId Uri
uri importEdit :: TextEdit
importEdit@TextEdit {Range
$sel:_range:TextEdit :: TextEdit -> Range
_range :: Range
_range, Text
$sel:_newText:TextEdit :: TextEdit -> Text
_newText :: Text
_newText} = do
  let
      title :: Text
title = Text -> Text
abbreviateImportTitle Text
_newText
      -- the code lens has no extra data
      _xdata :: Maybe a
_xdata = forall a. Maybe a
Nothing
      -- an edit that replaces the whole declaration with the explicit one
      edit :: WorkspaceEdit
edit = Maybe (HashMap Uri (List TextEdit))
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just HashMap Uri (List TextEdit)
editsMap) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
      editsMap :: HashMap Uri (List TextEdit)
editsMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Uri
uri, forall a. [a] -> List a
List [TextEdit
importEdit])]
      -- the command argument is simply the edit
      _arguments :: Maybe [Value]
_arguments = forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ WorkspaceEdit -> ImportCommandParams
ImportCommandParams WorkspaceEdit
edit]
  -- create the command
      _command :: Maybe Command
_command = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
pId CommandId
importCommandId Text
title Maybe [Value]
_arguments
  -- create and return the code lens
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CodeLens {Maybe Command
Range
forall a. Maybe a
$sel:_range:CodeLens :: Range
$sel:_command:CodeLens :: Maybe Command
$sel:_xdata:CodeLens :: Maybe Value
_command :: Maybe Command
_xdata :: forall a. Maybe a
_range :: Range
..}

-- | The title of the command is ideally the minimal explicit import decl, but
-- we don't want to create a really massive code lens (and the decl can be extremely large!).
-- So we abbreviate it to fit a max column size, and indicate how many more items are in the list
-- after the abbreviation
abbreviateImportTitle :: T.Text -> T.Text
abbreviateImportTitle :: Text -> Text
abbreviateImportTitle Text
input =
  let
      -- For starters, we only want one line in the title
      oneLineText :: Text
oneLineText = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
input
      -- Now, split at the max columns, leaving space for the summary text we're going to add
      -- (conservatively assuming we won't need to print a number larger than 100)
      (Text
prefix, Text
suffix) = Int -> Text -> (Text, Text)
T.splitAt (Int
maxColumns forall a. Num a => a -> a -> a
- (Text -> Int
T.length (forall {a} {a}. (Semigroup a, IsString a, Show a) => a -> a
summaryText Integer
100))) Text
oneLineText
      -- We also want to truncate the last item so we get a "clean" break, rather than half way through
      -- something. The conditional here is just because 'breakOnEnd' doesn't give us quite the right thing
      -- if there are actually no commas.
      (Text
actualPrefix, Text
extraSuffix) = if Text -> Text -> Int
T.count Text
"," Text
prefix forall a. Ord a => a -> a -> Bool
> Int
0 then Text -> Text -> (Text, Text)
T.breakOnEnd Text
"," Text
prefix else (Text
prefix, Text
"")
      actualSuffix :: Text
actualSuffix = Text
extraSuffix forall a. Semigroup a => a -> a -> a
<> Text
suffix

      -- The number of additional items is the number of commas+1
      numAdditionalItems :: Int
numAdditionalItems = Text -> Text -> Int
T.count Text
"," Text
actualSuffix forall a. Num a => a -> a -> a
+ Int
1
      -- We want to make text like this: import Foo (AImport, BImport, ... (30 items))
      -- We also want it to look sensible if we end up splitting in the module name itself,
      summaryText :: a -> a
summaryText a
n = a
" ... (" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show a
n) forall a. Semigroup a => a -> a -> a
<> a
" items)"
      -- so we only add a trailing paren if we've split in the export list
      suffixText :: Text
suffixText = forall {a} {a}. (Semigroup a, IsString a, Show a) => a -> a
summaryText Int
numAdditionalItems forall a. Semigroup a => a -> a -> a
<> if Text -> Text -> Int
T.count Text
"(" Text
prefix forall a. Ord a => a -> a -> Bool
> Int
0 then Text
")" else Text
""
      title :: Text
title =
          -- If the original text fits, just use it
          if Text -> Int
T.length Text
oneLineText forall a. Ord a => a -> a -> Bool
<= Int
maxColumns
          then Text
oneLineText
          else Text
actualPrefix forall a. Semigroup a => a -> a -> a
<> Text
suffixText
  in Text
title

--------------------------------------------------------------------------------

-- | A helper to run ide actions
runIde :: IdeState -> Action a -> IO a
runIde :: forall a. IdeState -> Action a -> IO a
runIde = forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"importLens"

within :: Range -> SrcSpan -> Bool
within :: Range -> SrcSpan -> Bool
within (Range Position
start Position
end) SrcSpan
span =
  Position -> SrcSpan -> Bool
isInsideSrcSpan Position
start SrcSpan
span Bool -> Bool -> Bool
|| Position -> SrcSpan -> Bool
isInsideSrcSpan Position
end SrcSpan
span