{-# LANGUAGE GADTs           #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns    #-}

module Ide.Plugin.Class.CodeAction where

import           Control.Lens                         hiding (List, use)
import           Control.Monad.Error.Class            (MonadError (throwError))
import           Control.Monad.Extra
import           Control.Monad.IO.Class               (liftIO)
import           Control.Monad.Trans.Class            (lift)
import           Control.Monad.Trans.Except           (ExceptT)
import           Control.Monad.Trans.Maybe
import           Data.Aeson                           hiding (Null)
import           Data.Bifunctor                       (second)
import           Data.Either.Extra                    (rights)
import           Data.List
import           Data.List.Extra                      (nubOrdOn)
import qualified Data.Map.Strict                      as Map
import           Data.Maybe                           (isNothing, listToMaybe,
                                                       mapMaybe)
import qualified Data.Set                             as Set
import qualified Data.Text                            as T
import           Development.IDE
import           Development.IDE.Core.Compile         (sourceTypecheck)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.Core.PositionMapping (fromCurrentRange)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util
import           Development.IDE.Spans.AtPoint        (pointCommand)
import           Ide.Plugin.Class.ExactPrint
import           Ide.Plugin.Class.Types
import           Ide.Plugin.Class.Utils
import qualified Ide.Plugin.Config
import           Ide.Plugin.Error
import           Ide.PluginUtils
import           Ide.Types
import qualified Language.LSP.Protocol.Lens           as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server

addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams
addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams
addMethodPlaceholders PluginId
_ IdeState
state Maybe ProgressToken
_ param :: AddMinimalMethodsParams
param@AddMinimalMethodsParams{Bool
[MethodDefinition]
Range
VersionedTextDocumentIdentifier
verTxtDocId :: VersionedTextDocumentIdentifier
range :: Range
methodGroup :: [MethodDefinition]
withSig :: Bool
verTxtDocId :: AddMinimalMethodsParams -> VersionedTextDocumentIdentifier
range :: AddMinimalMethodsParams -> Range
methodGroup :: AddMinimalMethodsParams -> [MethodDefinition]
withSig :: AddMinimalMethodsParams -> Bool
..} = do
    ClientCapabilities
caps <- LspM Config ClientCapabilities
-> ExceptT PluginError (LspT Config IO) ClientCapabilities
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 ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspT Config IO) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (VersionedTextDocumentIdentifier
verTxtDocId VersionedTextDocumentIdentifier
-> Getting Uri VersionedTextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri VersionedTextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Uri
L.uri)
    ParsedModule
pm <- String
-> IdeState
-> ExceptT PluginError Action ParsedModule
-> ExceptT PluginError (LspT Config IO) ParsedModule
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.addMethodPlaceholders.GetParsedModule" IdeState
state
        (ExceptT PluginError Action ParsedModule
 -> ExceptT PluginError (LspT Config IO) ParsedModule)
-> ExceptT PluginError Action ParsedModule
-> ExceptT PluginError (LspT Config IO) ParsedModule
forall a b. (a -> b) -> a -> b
$ GetParsedModule
-> NormalizedFilePath -> ExceptT PluginError Action ParsedModule
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetParsedModule
GetParsedModule NormalizedFilePath
nfp
    (HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (HscEnvEq -> HscEnv) -> HscEnvEq -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv -> DynFlags
df) <- String
-> IdeState
-> ExceptT PluginError Action HscEnvEq
-> ExceptT PluginError (LspT Config IO) HscEnvEq
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.addMethodPlaceholders.GhcSessionDeps" IdeState
state
        (ExceptT PluginError Action HscEnvEq
 -> ExceptT PluginError (LspT Config IO) HscEnvEq)
-> ExceptT PluginError Action HscEnvEq
-> ExceptT PluginError (LspT Config IO) HscEnvEq
forall a b. (a -> b) -> a -> b
$ GhcSessionDeps
-> NormalizedFilePath -> ExceptT PluginError Action HscEnvEq
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
    (Text
old, Text
new) <- PluginError
-> LspM Config (Maybe MethodDefinition)
-> ExceptT PluginError (LspT Config IO) MethodDefinition
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM (Text -> PluginError
PluginInternalError Text
"Unable to makeEditText")
        (LspM Config (Maybe MethodDefinition)
 -> ExceptT PluginError (LspT Config IO) MethodDefinition)
-> LspM Config (Maybe MethodDefinition)
-> ExceptT PluginError (LspT Config IO) MethodDefinition
forall a b. (a -> b) -> a -> b
$ IO (Maybe MethodDefinition) -> LspM Config (Maybe MethodDefinition)
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe MethodDefinition)
 -> LspM Config (Maybe MethodDefinition))
-> IO (Maybe MethodDefinition)
-> LspM Config (Maybe MethodDefinition)
forall a b. (a -> b) -> a -> b
$ MaybeT IO MethodDefinition -> IO (Maybe MethodDefinition)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
        (MaybeT IO MethodDefinition -> IO (Maybe MethodDefinition))
-> MaybeT IO MethodDefinition -> IO (Maybe MethodDefinition)
forall a b. (a -> b) -> a -> b
$ ParsedModule
-> DynFlags
-> AddMinimalMethodsParams
-> MaybeT IO MethodDefinition
forall (m :: * -> *).
Monad m =>
ParsedModule
-> DynFlags -> AddMinimalMethodsParams -> MaybeT m MethodDefinition
makeEditText ParsedModule
pm DynFlags
df AddMinimalMethodsParams
param
    [TextEdit]
pragmaInsertion <- IdeState
-> NormalizedFilePath
-> Extension
-> ExceptT PluginError (LspT Config IO) [TextEdit]
forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> Extension
-> ExceptT PluginError m [TextEdit]
insertPragmaIfNotPresent IdeState
state NormalizedFilePath
nfp Extension
InstanceSigs
    let edit :: WorkspaceEdit
edit =
            if Bool
withSig
            then WorkspaceEdit -> [TextEdit] -> WorkspaceEdit
mergeEdit (ClientCapabilities -> Text -> Text -> WorkspaceEdit
workspaceEdit ClientCapabilities
caps Text
old Text
new) [TextEdit]
pragmaInsertion
            else ClientCapabilities -> Text -> Text -> WorkspaceEdit
workspaceEdit ClientCapabilities
caps Text
old Text
new

    ExceptT
  PluginError (LspT Config IO) (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT PluginError (LspT Config IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   PluginError (LspT Config IO) (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT PluginError (LspT Config IO) ())
-> ExceptT
     PluginError (LspT Config IO) (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT PluginError (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$ LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (LspT Config IO) (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 (LspT Config IO) (LspId 'Method_WorkspaceApplyEdit))
-> LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (LspT Config IO) (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) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    (Value |? Null)
-> ExceptT PluginError (LspT Config IO) (Value |? Null)
forall a. a -> ExceptT PluginError (LspT Config IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null)
 -> ExceptT PluginError (LspT Config IO) (Value |? Null))
-> (Value |? Null)
-> ExceptT PluginError (LspT Config IO) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null
    where
        toTextDocumentEdit :: TextEdit -> TextDocumentEdit
toTextDocumentEdit TextEdit
edit =
            OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
TextDocumentEdit (VersionedTextDocumentIdentifier
verTxtDocId VersionedTextDocumentIdentifier
-> Getting
     OptionalVersionedTextDocumentIdentifier
     VersionedTextDocumentIdentifier
     OptionalVersionedTextDocumentIdentifier
-> OptionalVersionedTextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^.AReview
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
-> Getter
     VersionedTextDocumentIdentifier
     OptionalVersionedTextDocumentIdentifier
forall t b. AReview t b -> Getter b t
re AReview
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier) [TextEdit -> TextEdit |? AnnotatedTextEdit
forall a b. a -> a |? b
InL TextEdit
edit]

        mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit
        mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit
mergeEdit WorkspaceEdit{Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
Maybe (Map Uri [TextEdit])
Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changes :: Maybe (Map Uri [TextEdit])
_documentChanges :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_changeAnnotations :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
$sel:_changeAnnotations:WorkspaceEdit :: WorkspaceEdit
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
$sel:_changes:WorkspaceEdit :: WorkspaceEdit -> Maybe (Map Uri [TextEdit])
$sel:_documentChanges:WorkspaceEdit :: WorkspaceEdit
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
..} [TextEdit]
edits = WorkspaceEdit
            { $sel:_documentChanges:WorkspaceEdit :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_documentChanges =
                (\[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
x -> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
x [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. [a] -> [a] -> [a]
++ (TextEdit
 -> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> [TextEdit]
-> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a b. (a -> b) -> [a] -> [b]
map (TextDocumentEdit
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
forall a b. a -> a |? b
InL (TextDocumentEdit
 -> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> (TextEdit -> TextDocumentEdit)
-> TextEdit
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEdit -> TextDocumentEdit
toTextDocumentEdit) [TextEdit]
edits)
                    ([TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
 -> [TextDocumentEdit
     |? (CreateFile |? (RenameFile |? DeleteFile))])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_documentChanges
            , Maybe (Map Uri [TextEdit])
Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changes :: Maybe (Map Uri [TextEdit])
_changeAnnotations :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
$sel:_changeAnnotations:WorkspaceEdit :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
$sel:_changes:WorkspaceEdit :: Maybe (Map Uri [TextEdit])
..
            }

        workspaceEdit :: ClientCapabilities -> Text -> Text -> WorkspaceEdit
workspaceEdit ClientCapabilities
caps Text
old Text
new
            = ClientCapabilities
-> (VersionedTextDocumentIdentifier, Text)
-> Text
-> WithDeletions
-> WorkspaceEdit
diffText ClientCapabilities
caps (VersionedTextDocumentIdentifier
verTxtDocId, Text
old) Text
new WithDeletions
IncludeDeletions

-- |
-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
-- sensitive to the format of diagnostic messages from GHC.
codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction
codeAction :: Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeAction Recorder (WithPriority Log)
recorder IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
_ CodeActionContext
context) = do
    VersionedTextDocumentIdentifier
verTxtDocId <- LspM Config VersionedTextDocumentIdentifier
-> ExceptT
     PluginError (LspT Config IO) VersionedTextDocumentIdentifier
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 VersionedTextDocumentIdentifier
 -> ExceptT
      PluginError (LspT Config IO) VersionedTextDocumentIdentifier)
-> LspM Config VersionedTextDocumentIdentifier
-> ExceptT
     PluginError (LspT Config IO) VersionedTextDocumentIdentifier
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
-> LspM Config VersionedTextDocumentIdentifier
forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc TextDocumentIdentifier
docId
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspT Config IO) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (VersionedTextDocumentIdentifier
verTxtDocId VersionedTextDocumentIdentifier
-> Getting Uri VersionedTextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri VersionedTextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Uri
L.uri)
    [Command |? CodeAction]
actions <- [[Command |? CodeAction]] -> [Command |? CodeAction]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Command |? CodeAction]] -> [Command |? CodeAction])
-> ExceptT PluginError (LspT Config IO) [[Command |? CodeAction]]
-> ExceptT PluginError (LspT Config IO) [Command |? CodeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Diagnostic
 -> ExceptT PluginError (LspT Config IO) [Command |? CodeAction])
-> [Diagnostic]
-> ExceptT PluginError (LspT Config IO) [[Command |? CodeAction]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> Diagnostic
-> ExceptT PluginError (LspT Config IO) [Command |? CodeAction]
mkActions NormalizedFilePath
nfp VersionedTextDocumentIdentifier
verTxtDocId) [Diagnostic]
methodDiags
    ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspT Config IO) ([Command |? CodeAction] |? Null)
forall a. a -> ExceptT PluginError (LspT Config IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Command |? CodeAction] |? Null)
 -> ExceptT
      PluginError (LspT Config IO) ([Command |? CodeAction] |? Null))
-> ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspT Config IO) ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL [Command |? CodeAction]
actions
    where
        diags :: [Diagnostic]
diags = CodeActionContext
context CodeActionContext
-> Getting [Diagnostic] CodeActionContext [Diagnostic]
-> [Diagnostic]
forall s a. s -> Getting a s a -> a
^. Getting [Diagnostic] CodeActionContext [Diagnostic]
forall s a. HasDiagnostics s a => Lens' s a
Lens' CodeActionContext [Diagnostic]
L.diagnostics

        ghcDiags :: [Diagnostic]
ghcDiags = (Diagnostic -> Bool) -> [Diagnostic] -> [Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Diagnostic
d -> Diagnostic
d Diagnostic
-> Getting (Maybe Text) Diagnostic (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Diagnostic (Maybe Text)
forall s a. HasSource s a => Lens' s a
Lens' Diagnostic (Maybe Text)
L.source Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sourceTypecheck) [Diagnostic]
diags
        methodDiags :: [Diagnostic]
methodDiags = (Diagnostic -> Bool) -> [Diagnostic] -> [Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Diagnostic
d -> Text -> Bool
isClassMethodWarning (Diagnostic
d Diagnostic -> Getting Text Diagnostic Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Diagnostic Text
forall s a. HasMessage s a => Lens' s a
Lens' Diagnostic Text
L.message)) [Diagnostic]
ghcDiags

        mkActions
            :: NormalizedFilePath
            -> VersionedTextDocumentIdentifier
            -> Diagnostic
            -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction]
        mkActions :: NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> Diagnostic
-> ExceptT PluginError (LspT Config IO) [Command |? CodeAction]
mkActions NormalizedFilePath
docPath VersionedTextDocumentIdentifier
verTxtDocId Diagnostic
diag = do
            (HAR {hieAst :: ()
hieAst = HieASTs a
ast}, PositionMapping
pmap) <- String
-> IdeState
-> ExceptT PluginError Action (HieAstResult, PositionMapping)
-> ExceptT
     PluginError (LspT Config IO) (HieAstResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.findClassIdentifier.GetHieAst" IdeState
state
                (ExceptT PluginError Action (HieAstResult, PositionMapping)
 -> ExceptT
      PluginError (LspT Config IO) (HieAstResult, PositionMapping))
-> ExceptT PluginError Action (HieAstResult, PositionMapping)
-> ExceptT
     PluginError (LspT Config IO) (HieAstResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetHieAst
-> NormalizedFilePath
-> ExceptT PluginError Action (HieAstResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetHieAst
GetHieAst NormalizedFilePath
docPath
            Position
instancePosition <- PluginError
-> Maybe Position -> ExceptT PluginError (LspT Config IO) Position
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInvalidUserState Text
"fromCurrentRange") (Maybe Position -> ExceptT PluginError (LspT Config IO) Position)
-> Maybe Position -> ExceptT PluginError (LspT Config IO) Position
forall a b. (a -> b) -> a -> b
$
                              PositionMapping -> Range -> Maybe Range
fromCurrentRange PositionMapping
pmap Range
range Maybe Range
-> Getting (First Position) (Maybe Range) Position
-> Maybe Position
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Range -> Const (First Position) Range)
-> Maybe Range -> Const (First Position) (Maybe Range)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((Range -> Const (First Position) Range)
 -> Maybe Range -> Const (First Position) (Maybe Range))
-> ((Position -> Const (First Position) Position)
    -> Range -> Const (First Position) Range)
-> Getting (First Position) (Maybe Range) Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const (First Position) Position)
-> Range -> Const (First Position) Range
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start
                              Maybe Position
-> (Maybe Position -> Maybe Position) -> Maybe Position
forall a b. a -> (a -> b) -> b
& (Position -> Position) -> Maybe Position -> Maybe Position
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UInt -> Identity UInt) -> Position -> Identity Position
forall s a. HasCharacter s a => Lens' s a
Lens' Position UInt
L.character ((UInt -> Identity UInt) -> Position -> Identity Position)
-> UInt -> Position -> Position
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ UInt
1)
            Identifier
ident <- HieASTs a
-> Position -> ExceptT PluginError (LspT Config IO) Identifier
forall {m :: * -> *} {a}.
Monad m =>
HieASTs a -> Position -> ExceptT PluginError m Identifier
findClassIdentifier HieASTs a
ast Position
instancePosition
            Class
cls <- NormalizedFilePath
-> Identifier -> ExceptT PluginError (LspT Config IO) Class
findClassFromIdentifier NormalizedFilePath
docPath Identifier
ident
            InstanceBindTypeSigsResult [InstanceBindTypeSig]
sigs <- String
-> IdeState
-> ExceptT PluginError Action InstanceBindTypeSigsResult
-> ExceptT PluginError (LspT Config IO) InstanceBindTypeSigsResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.GetInstanceBindTypeSigs" IdeState
state
                (ExceptT PluginError Action InstanceBindTypeSigsResult
 -> ExceptT PluginError (LspT Config IO) InstanceBindTypeSigsResult)
-> ExceptT PluginError Action InstanceBindTypeSigsResult
-> ExceptT PluginError (LspT Config IO) InstanceBindTypeSigsResult
forall a b. (a -> b) -> a -> b
$ GetInstanceBindTypeSigs
-> NormalizedFilePath
-> ExceptT PluginError Action InstanceBindTypeSigsResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
docPath
            (TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
gblEnv ) <- String
-> IdeState
-> ExceptT PluginError Action TcModuleResult
-> ExceptT PluginError (LspT Config IO) TcModuleResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.TypeCheck" IdeState
state (ExceptT PluginError Action TcModuleResult
 -> ExceptT PluginError (LspT Config IO) TcModuleResult)
-> ExceptT PluginError Action TcModuleResult
-> ExceptT PluginError (LspT Config IO) TcModuleResult
forall a b. (a -> b) -> a -> b
$ TypeCheck
-> NormalizedFilePath -> ExceptT PluginError Action TcModuleResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE TypeCheck
TypeCheck NormalizedFilePath
docPath
            (HscEnvEq -> HscEnv
hscEnv -> HscEnv
hsc) <- String
-> IdeState
-> ExceptT PluginError Action HscEnvEq
-> ExceptT PluginError (LspT Config IO) HscEnvEq
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.GhcSession" IdeState
state (ExceptT PluginError Action HscEnvEq
 -> ExceptT PluginError (LspT Config IO) HscEnvEq)
-> ExceptT PluginError Action HscEnvEq
-> ExceptT PluginError (LspT Config IO) HscEnvEq
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath -> ExceptT PluginError Action HscEnvEq
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GhcSession
GhcSession NormalizedFilePath
docPath
            [Text]
implemented <- HieASTs a
-> Position -> ExceptT PluginError (LspT Config IO) [Text]
forall a.
HieASTs a
-> Position -> ExceptT PluginError (LspT Config IO) [Text]
findImplementedMethods HieASTs a
ast Position
instancePosition
            Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError (LspT Config IO) ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Class -> [Text] -> Log
LogImplementedMethods Class
cls [Text]
implemented)
            [Command |? CodeAction]
-> ExceptT PluginError (LspT Config IO) [Command |? CodeAction]
forall a. a -> ExceptT PluginError (LspT Config IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ([Command |? CodeAction]
 -> ExceptT PluginError (LspT Config IO) [Command |? CodeAction])
-> [Command |? CodeAction]
-> ExceptT PluginError (LspT Config IO) [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$ (MethodGroup -> [Command |? CodeAction])
-> [MethodGroup] -> [Command |? CodeAction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap MethodGroup -> [Command |? CodeAction]
mkAction
                ([MethodGroup] -> [Command |? CodeAction])
-> [MethodGroup] -> [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$ (MethodGroup -> [MethodDefinition])
-> [MethodGroup] -> [MethodGroup]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn MethodGroup -> [MethodDefinition]
forall a b. (a, b) -> b
snd
                ([MethodGroup] -> [MethodGroup]) -> [MethodGroup] -> [MethodGroup]
forall a b. (a -> b) -> a -> b
$ (MethodGroup -> Bool) -> [MethodGroup] -> [MethodGroup]
forall a. (a -> Bool) -> [a] -> [a]
filter ([MethodDefinition] -> [MethodDefinition] -> Bool
forall a. Eq a => a -> a -> Bool
(/=) [MethodDefinition]
forall a. Monoid a => a
mempty ([MethodDefinition] -> Bool)
-> (MethodGroup -> [MethodDefinition]) -> MethodGroup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodGroup -> [MethodDefinition]
forall a b. (a, b) -> b
snd)
                ([MethodGroup] -> [MethodGroup]) -> [MethodGroup] -> [MethodGroup]
forall a b. (a -> b) -> a -> b
$ (MethodGroup -> MethodGroup) -> [MethodGroup] -> [MethodGroup]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([MethodDefinition] -> [MethodDefinition])
-> MethodGroup -> MethodGroup
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((MethodDefinition -> Bool)
-> [MethodDefinition] -> [MethodDefinition]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
bind, Text
_) -> Text
bind Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
implemented)))
                ([MethodGroup] -> [MethodGroup]) -> [MethodGroup] -> [MethodGroup]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv
-> Range
-> [InstanceBindTypeSig]
-> Class
-> [MethodGroup]
mkMethodGroups HscEnv
hsc TcGblEnv
gblEnv Range
range [InstanceBindTypeSig]
sigs Class
cls
            where
                range :: Range
range = Diagnostic
diag Diagnostic -> Getting Range Diagnostic Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range Diagnostic Range
forall s a. HasRange s a => Lens' s a
Lens' Diagnostic Range
L.range

                mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
                mkMethodGroups :: HscEnv
-> TcGblEnv
-> Range
-> [InstanceBindTypeSig]
-> Class
-> [MethodGroup]
mkMethodGroups HscEnv
hsc TcGblEnv
gblEnv Range
range [InstanceBindTypeSig]
sigs Class
cls = [MethodGroup]
minimalDef [MethodGroup] -> [MethodGroup] -> [MethodGroup]
forall a. Semigroup a => a -> a -> a
<> [MethodGroup
Item [MethodGroup]
allClassMethods]
                    where
                        minimalDef :: [MethodGroup]
minimalDef = HscEnv
-> TcGblEnv
-> Range
-> [InstanceBindTypeSig]
-> BooleanFormula Name
-> [MethodGroup]
minDefToMethodGroups HscEnv
hsc TcGblEnv
gblEnv Range
range [InstanceBindTypeSig]
sigs (BooleanFormula Name -> [MethodGroup])
-> BooleanFormula Name -> [MethodGroup]
forall a b. (a -> b) -> a -> b
$ Class -> BooleanFormula Name
classMinimalDef Class
cls
                        allClassMethods :: MethodGroup
allClassMethods = (Text
"all missing methods", HscEnv
-> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions HscEnv
hsc TcGblEnv
gblEnv Range
range [InstanceBindTypeSig]
sigs)

                mkAction :: MethodGroup -> [Command |? CodeAction]
                mkAction :: MethodGroup -> [Command |? CodeAction]
mkAction (Text
name, [MethodDefinition]
methods)
                    = [ Text -> Command -> Command |? CodeAction
forall {a}. Text -> Command -> a |? CodeAction
mkCodeAction Text
title
                            (Command -> Command |? CodeAction)
-> Command -> Command |? CodeAction
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
codeActionCommandId Text
title
                                ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ [MethodDefinition] -> Bool -> [Value]
mkCmdParams [MethodDefinition]
methods Bool
False)
                      , Text -> Command -> Command |? CodeAction
forall {a}. Text -> Command -> a |? CodeAction
mkCodeAction Text
titleWithSig
                            (Command -> Command |? CodeAction)
-> Command -> Command |? CodeAction
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
codeActionCommandId Text
titleWithSig
                                ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ [MethodDefinition] -> Bool -> [Value]
mkCmdParams [MethodDefinition]
methods Bool
True)
                      ]
                    where
                        title :: Text
title = Text
"Add placeholders for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                        titleWithSig :: Text
titleWithSig = Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with signature(s)"

                mkCmdParams :: [(T.Text, T.Text)] -> Bool -> [Value]
                mkCmdParams :: [MethodDefinition] -> Bool -> [Value]
mkCmdParams [MethodDefinition]
methodGroup Bool
withSig =
                    [AddMinimalMethodsParams -> Value
forall a. ToJSON a => a -> Value
toJSON (VersionedTextDocumentIdentifier
-> Range -> [MethodDefinition] -> Bool -> AddMinimalMethodsParams
AddMinimalMethodsParams VersionedTextDocumentIdentifier
verTxtDocId Range
range [MethodDefinition]
methodGroup Bool
withSig)]

                mkCodeAction :: Text -> Command -> a |? CodeAction
mkCodeAction Text
title Command
cmd
                    = CodeAction -> a |? CodeAction
forall a b. b -> a |? b
InR
                    (CodeAction -> a |? CodeAction) -> CodeAction -> a |? CodeAction
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== Text) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
CodeAction
                        Text
title
                        (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_QuickFix)
                        ([Diagnostic] -> Maybe [Diagnostic]
forall a. a -> Maybe a
Just [])
                        Maybe Bool
forall a. Maybe a
Nothing
                        Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing
                        Maybe WorkspaceEdit
forall a. Maybe a
Nothing
                        (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd)
                        Maybe Value
forall a. Maybe a
Nothing

        findClassIdentifier :: HieASTs a -> Position -> ExceptT PluginError m Identifier
findClassIdentifier HieASTs a
hf Position
instancePosition =
            PluginError -> Maybe Identifier -> ExceptT PluginError m Identifier
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInternalError Text
"No Identifier found")
                (Maybe Identifier -> ExceptT PluginError m Identifier)
-> Maybe Identifier -> ExceptT PluginError m Identifier
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Maybe Identifier
forall a. [a] -> Maybe a
listToMaybe
                ([Identifier] -> Maybe Identifier)
-> [Identifier] -> Maybe Identifier
forall a b. (a -> b) -> a -> b
$ ([Identifier] -> Maybe Identifier)
-> [[Identifier]] -> [Identifier]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Identifier] -> Maybe Identifier
forall a. [a] -> Maybe a
listToMaybe
                ([[Identifier]] -> [Identifier]) -> [[Identifier]] -> [Identifier]
forall a b. (a -> b) -> a -> b
$ HieASTs a
-> Position -> (HieAST a -> [Identifier]) -> [[Identifier]]
forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
instancePosition
                    ( (Map Identifier (IdentifierDetails a) -> [Identifier]
forall k a. Map k a -> [k]
Map.keys (Map Identifier (IdentifierDetails a) -> [Identifier])
-> (HieAST a -> Map Identifier (IdentifierDetails a))
-> HieAST a
-> [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> IdentifierDetails a -> Bool)
-> Map Identifier (IdentifierDetails a)
-> Map Identifier (IdentifierDetails a)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Identifier -> IdentifierDetails a -> Bool
forall a. Identifier -> IdentifierDetails a -> Bool
isClassNodeIdentifier (Map Identifier (IdentifierDetails a)
 -> Map Identifier (IdentifierDetails a))
-> (HieAST a -> Map Identifier (IdentifierDetails a))
-> HieAST a
-> Map Identifier (IdentifierDetails a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST a -> Map Identifier (IdentifierDetails a)
forall a. HieAST a -> Map Identifier (IdentifierDetails a)
getNodeIds)
                        (HieAST a -> [Identifier])
-> (HieAST a -> [HieAST a]) -> HieAST a -> [Identifier]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren
                    )

        findImplementedMethods
            :: HieASTs a
            -> Position
            -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text]
        findImplementedMethods :: forall a.
HieASTs a
-> Position -> ExceptT PluginError (LspT Config IO) [Text]
findImplementedMethods HieASTs a
asts Position
instancePosition = do
            [Text] -> ExceptT PluginError (LspT Config IO) [Text]
forall a. a -> ExceptT PluginError (LspT Config IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ([Text] -> ExceptT PluginError (LspT Config IO) [Text])
-> [Text] -> ExceptT PluginError (LspT Config IO) [Text]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ HieASTs a -> Position -> (HieAST a -> [Text]) -> [[Text]]
forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
asts Position
instancePosition
                ((HieAST a -> [Text]) -> [[Text]])
-> (HieAST a -> [Text]) -> [[Text]]
forall a b. (a -> b) -> a -> b
$ (Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. NamedThing a => a -> String
getOccString) ([Name] -> [Text]) -> (HieAST a -> [Name]) -> HieAST a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identifier] -> [Name]
forall a b. [Either a b] -> [b]
rights ([Identifier] -> [Name])
-> (HieAST a -> [Identifier]) -> HieAST a -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST a -> [Identifier]
forall a. HieAST a -> [Identifier]
findInstanceValBindIdentifiers

        -- | Recurses through the given AST to find identifiers which are
        -- 'InstanceValBind's.
        findInstanceValBindIdentifiers :: HieAST a -> [Identifier]
        findInstanceValBindIdentifiers :: forall a. HieAST a -> [Identifier]
findInstanceValBindIdentifiers HieAST a
ast =
            let valBindIds :: [Identifier]
valBindIds = Map Identifier (IdentifierDetails a) -> [Identifier]
forall k a. Map k a -> [k]
Map.keys
                            (Map Identifier (IdentifierDetails a) -> [Identifier])
-> (Map Identifier (IdentifierDetails a)
    -> Map Identifier (IdentifierDetails a))
-> Map Identifier (IdentifierDetails a)
-> [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdentifierDetails a -> Bool)
-> Map Identifier (IdentifierDetails a)
-> Map Identifier (IdentifierDetails a)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isInstanceValBind (Set ContextInfo -> Bool)
-> (IdentifierDetails a -> Set ContextInfo)
-> IdentifierDetails a
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo)
                            (Map Identifier (IdentifierDetails a) -> [Identifier])
-> Map Identifier (IdentifierDetails a) -> [Identifier]
forall a b. (a -> b) -> a -> b
$ HieAST a -> Map Identifier (IdentifierDetails a)
forall a. HieAST a -> Map Identifier (IdentifierDetails a)
getNodeIds HieAST a
ast
            in [Identifier]
valBindIds [Identifier] -> [Identifier] -> [Identifier]
forall a. Semigroup a => a -> a -> a
<> (HieAST a -> [Identifier]) -> [HieAST a] -> [Identifier]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HieAST a -> [Identifier]
forall a. HieAST a -> [Identifier]
findInstanceValBindIdentifiers (HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
ast)

        findClassFromIdentifier :: NormalizedFilePath
-> Identifier -> ExceptT PluginError (LspT Config IO) Class
findClassFromIdentifier NormalizedFilePath
docPath (Right Name
name) = do
            (HscEnvEq -> HscEnv
hscEnv -> HscEnv
hscenv, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspT Config IO) (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.findClassFromIdentifier.GhcSessionDeps" IdeState
state
                (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT
      PluginError (LspT Config IO) (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspT Config IO) (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GhcSessionDeps
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
docPath
            (TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
thisMod, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
-> ExceptT
     PluginError (LspT Config IO) (TcModuleResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.findClassFromIdentifier.TypeCheck" IdeState
state
                (ExceptT PluginError Action (TcModuleResult, PositionMapping)
 -> ExceptT
      PluginError (LspT Config IO) (TcModuleResult, PositionMapping))
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
-> ExceptT
     PluginError (LspT Config IO) (TcModuleResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ TypeCheck
-> NormalizedFilePath
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE TypeCheck
TypeCheck NormalizedFilePath
docPath
            PluginError
-> LspT Config IO (Maybe Class)
-> ExceptT PluginError (LspT Config IO) Class
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM (Text -> PluginError
PluginInternalError Text
"initTcWithGbl failed")
                (LspT Config IO (Maybe Class)
 -> ExceptT PluginError (LspT Config IO) Class)
-> (TcM Class -> LspT Config IO (Maybe Class))
-> TcM Class
-> ExceptT PluginError (LspT Config IO) Class
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe Class) -> LspT Config IO (Maybe Class)
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                (IO (Maybe Class) -> LspT Config IO (Maybe Class))
-> (TcM Class -> IO (Maybe Class))
-> TcM Class
-> LspT Config IO (Maybe Class)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Messages TcRnMessage, Maybe Class) -> Maybe Class)
-> IO (Messages TcRnMessage, Maybe Class) -> IO (Maybe Class)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Messages TcRnMessage, Maybe Class) -> Maybe Class
forall a b. (a, b) -> b
snd
                (IO (Messages TcRnMessage, Maybe Class) -> IO (Maybe Class))
-> (TcM Class -> IO (Messages TcRnMessage, Maybe Class))
-> TcM Class
-> IO (Maybe Class)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM Class
-> IO (Messages TcRnMessage, Maybe Class)
forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl HscEnv
hscenv TcGblEnv
thisMod RealSrcSpan
ghostSpan (TcM Class -> ExceptT PluginError (LspT Config IO) Class)
-> TcM Class -> ExceptT PluginError (LspT Config IO) Class
forall a b. (a -> b) -> a -> b
$ do
                    TcTyThing
tcthing <- Name -> TcM TcTyThing
tcLookup Name
name
                    case TcTyThing
tcthing of
                        AGlobal (AConLike (RealDataCon DataCon
con))
                            | Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe (DataCon -> TyCon
dataConOrigTyCon DataCon
con) -> Class -> TcM Class
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Class
cls
                        TcTyThing
_ -> String -> TcM Class
forall a. String -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Ide.Plugin.Class.findClassFromIdentifier"
        findClassFromIdentifier NormalizedFilePath
_ (Left ModuleName
_) = PluginError -> ExceptT PluginError (LspT Config IO) Class
forall a. PluginError -> ExceptT PluginError (LspT Config IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> PluginError
PluginInternalError Text
"Ide.Plugin.Class.findClassIdentifier")

-- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc
isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool
isClassNodeIdentifier :: forall a. Identifier -> IdentifierDetails a -> Bool
isClassNodeIdentifier (Right Name
i) IdentifierDetails a
ident  | Char
'C':Char
':':String
_ <- FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
i = (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool)
-> (IdentifierDetails a -> Maybe a) -> IdentifierDetails a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails a -> Maybe a
forall a. IdentifierDetails a -> Maybe a
identType) IdentifierDetails a
ident Bool -> Bool -> Bool
&& ContextInfo
Use ContextInfo -> Set ContextInfo -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
ident
isClassNodeIdentifier Identifier
_ IdentifierDetails a
_ = Bool
False

isClassMethodWarning :: T.Text -> Bool
isClassMethodWarning :: Text -> Bool
isClassMethodWarning = Text -> Text -> Bool
T.isPrefixOf Text
"• No explicit implementation for"

isInstanceValBind :: ContextInfo -> Bool
isInstanceValBind :: ContextInfo -> Bool
isInstanceValBind (ValBind BindType
InstanceBind Scope
_ Maybe RealSrcSpan
_) = Bool
True
isInstanceValBind ContextInfo
_                          = Bool
False

type MethodSignature = T.Text
type MethodName = T.Text
type MethodDefinition = (MethodName, MethodSignature)
type MethodGroup = (T.Text, [MethodDefinition])

makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition
makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition
makeMethodDefinition HscEnv
hsc TcGblEnv
gblEnv InstanceBindTypeSig
sig = (Text
name, Text
signature)
    where
        name :: Text
name = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
forall s. IsString s => s
bindingPrefix) (Name -> Text
forall a. Outputable a => a -> Text
printOutputable  (InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
sig))
        signature :: Text
signature = Text -> Text
prettyBindingNameString (Name -> Text
forall a. Outputable a => a -> Text
printOutputable (InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
sig)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (HscEnv -> TcGblEnv -> Type -> String
showDoc HscEnv
hsc TcGblEnv
gblEnv (InstanceBindTypeSig -> Type
bindType InstanceBindTypeSig
sig))

makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions :: HscEnv
-> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions HscEnv
hsc TcGblEnv
gblEnv Range
range [InstanceBindTypeSig]
sigs =
    [ HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition
makeMethodDefinition HscEnv
hsc TcGblEnv
gblEnv InstanceBindTypeSig
sig
    | InstanceBindTypeSig
sig <- [InstanceBindTypeSig]
sigs
    , Range -> SrcSpan -> Bool
inRange Range
range (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
sig)
    ]

signatureToName :: InstanceBindTypeSig -> T.Text
signatureToName :: InstanceBindTypeSig -> Text
signatureToName InstanceBindTypeSig
sig = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
forall s. IsString s => s
bindingPrefix) (Name -> Text
forall a. Outputable a => a -> Text
printOutputable (InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
sig))

-- Return [groupName text, [(methodName text, signature text)]]
minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
minDefToMethodGroups :: HscEnv
-> TcGblEnv
-> Range
-> [InstanceBindTypeSig]
-> BooleanFormula Name
-> [MethodGroup]
minDefToMethodGroups HscEnv
hsc TcGblEnv
gblEnv Range
range [InstanceBindTypeSig]
sigs BooleanFormula Name
minDef = [MethodDefinition] -> MethodGroup
forall {a} {b}. (Monoid a, IsString a) => [(a, b)] -> (a, [(a, b)])
makeMethodGroup ([MethodDefinition] -> MethodGroup)
-> [[MethodDefinition]] -> [MethodGroup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BooleanFormula Name -> [[MethodDefinition]]
go BooleanFormula Name
minDef
    where
        makeMethodGroup :: [(a, b)] -> (a, [(a, b)])
makeMethodGroup [(a, b)]
methodDefinitions =
            let name :: a
name = [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [a]
forall a. a -> [a] -> [a]
intersperse a
"," ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (\a
x -> a
"'" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'") (a -> a) -> ((a, b) -> a) -> (a, b) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> [(a, b)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b)]
methodDefinitions
            in  (a
name, [(a, b)]
methodDefinitions)

        go :: BooleanFormula Name -> [[MethodDefinition]]
go (Var Name
mn)   = [MethodDefinition] -> [[MethodDefinition]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([MethodDefinition] -> [[MethodDefinition]])
-> [MethodDefinition] -> [[MethodDefinition]]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions HscEnv
hsc TcGblEnv
gblEnv Range
range ([InstanceBindTypeSig] -> [MethodDefinition])
-> [InstanceBindTypeSig] -> [MethodDefinition]
forall a b. (a -> b) -> a -> b
$ (InstanceBindTypeSig -> Bool)
-> [InstanceBindTypeSig] -> [InstanceBindTypeSig]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Text
forall a. Outputable a => a -> Text
printOutputable Name
mn) (Text -> Bool)
-> (InstanceBindTypeSig -> Text) -> InstanceBindTypeSig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceBindTypeSig -> Text
signatureToName) [InstanceBindTypeSig]
sigs
        go (Or [LBooleanFormula Name]
ms)    = (LBooleanFormula Name -> [[MethodDefinition]])
-> [LBooleanFormula Name] -> [[MethodDefinition]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BooleanFormula Name -> [[MethodDefinition]]
go (BooleanFormula Name -> [[MethodDefinition]])
-> (LBooleanFormula Name -> BooleanFormula Name)
-> LBooleanFormula Name
-> [[MethodDefinition]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBooleanFormula Name -> BooleanFormula Name
forall l e. GenLocated l e -> e
unLoc) [LBooleanFormula Name]
ms
        go (And [LBooleanFormula Name]
ms)   = (LBooleanFormula Name
 -> [[MethodDefinition]] -> [[MethodDefinition]])
-> [[MethodDefinition]]
-> [LBooleanFormula Name]
-> [[MethodDefinition]]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([MethodDefinition] -> [MethodDefinition] -> [MethodDefinition])
-> [[MethodDefinition]]
-> [[MethodDefinition]]
-> [[MethodDefinition]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [MethodDefinition] -> [MethodDefinition] -> [MethodDefinition]
forall a. Semigroup a => a -> a -> a
(<>) ([[MethodDefinition]]
 -> [[MethodDefinition]] -> [[MethodDefinition]])
-> (LBooleanFormula Name -> [[MethodDefinition]])
-> LBooleanFormula Name
-> [[MethodDefinition]]
-> [[MethodDefinition]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BooleanFormula Name -> [[MethodDefinition]]
go (BooleanFormula Name -> [[MethodDefinition]])
-> (LBooleanFormula Name -> BooleanFormula Name)
-> LBooleanFormula Name
-> [[MethodDefinition]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBooleanFormula Name -> BooleanFormula Name
forall l e. GenLocated l e -> e
unLoc) [[]] [LBooleanFormula Name]
ms
        go (Parens LBooleanFormula Name
m) = BooleanFormula Name -> [[MethodDefinition]]
go (LBooleanFormula Name -> BooleanFormula Name
forall l e. GenLocated l e -> e
unLoc LBooleanFormula Name
m)