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

    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null
    where
        toTextDocumentEdit :: TextEdit -> TextDocumentEdit
toTextDocumentEdit TextEdit
edit =
            OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
TextDocumentEdit (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^.forall t b. AReview t b -> Getter b t
re Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier) [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)
$sel:_changes:WorkspaceEdit :: WorkspaceEdit -> Maybe (Map Uri [TextEdit])
$sel:_documentChanges:WorkspaceEdit :: WorkspaceEdit
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
$sel:_changeAnnotations:WorkspaceEdit :: WorkspaceEdit
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changeAnnotations :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_documentChanges :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_changes :: Maybe (Map Uri [TextEdit])
..} [TextEdit]
edits = WorkspaceEdit
            { $sel:_documentChanges:WorkspaceEdit :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_documentChanges =
                (\[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
x -> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
x forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> a |? b
InL forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEdit -> TextDocumentEdit
toTextDocumentEdit) [TextEdit]
edits)
                    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)
$sel:_changes:WorkspaceEdit :: Maybe (Map Uri [TextEdit])
$sel:_changeAnnotations:WorkspaceEdit :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changeAnnotations :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changes :: 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc TextDocumentIdentifier
docId
    NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
    [Command |? CodeAction]
actions <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> Diagnostic
-> ExceptT PluginError (LspT Config IO) [Command |? CodeAction]
mkActions NormalizedFilePath
nfp VersionedTextDocumentIdentifier
verTxtDocId) [Diagnostic]
methodDiags
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [Command |? CodeAction]
actions
    where
        diags :: [Diagnostic]
diags = CodeActionContext
context forall s a. s -> Getting a s a -> a
^. forall s a. HasDiagnostics s a => Lens' s a
L.diagnostics

        ghcDiags :: [Diagnostic]
ghcDiags = forall a. (a -> Bool) -> [a] -> [a]
filter (\Diagnostic
d -> Diagnostic
d forall s a. s -> Getting a s a -> a
^. forall s a. HasSource s a => Lens' s a
L.source forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
sourceTypecheck) [Diagnostic]
diags
        methodDiags :: [Diagnostic]
methodDiags = forall a. (a -> Bool) -> [a] -> [a]
filter (\Diagnostic
d -> Text -> Bool
isClassMethodWarning (Diagnostic
d forall s a. s -> Getting a s a -> a
^. forall s a. HasMessage s a => Lens' s a
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) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.findClassIdentifier.GetHieAst" IdeState
state
                forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetHieAst
GetHieAst NormalizedFilePath
docPath
            Position
instancePosition <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInvalidUserState Text
"fromCurrentRange") forall a b. (a -> b) -> a -> b
$
                              PositionMapping -> Range -> Maybe Range
fromCurrentRange PositionMapping
pmap Range
range forall s a. s -> Getting (First a) s a -> Maybe a
^? forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStart s a => Lens' s a
L.start
                              forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. HasCharacter s a => Lens' s a
L.character forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ UInt
1)
            Identifier
ident <- 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 <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.GetInstanceBindTypeSigs" IdeState
state
                forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
docPath
            [Text]
implemented <- forall a.
HieASTs a
-> Position -> ExceptT PluginError (LspT Config IO) [Text]
findImplementedMethods HieASTs a
ast Position
instancePosition
            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)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
                forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap MethodGroup -> [Command |? CodeAction]
mkAction
                forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn forall a b. (a, b) -> b
snd
                forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(/=) forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
bind, Text
_) -> Text
bind forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
implemented)))
                forall a b. (a -> b) -> a -> b
$ Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
mkMethodGroups Range
range [InstanceBindTypeSig]
sigs Class
cls
            where
                range :: Range
range = Diagnostic
diag forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
L.range

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

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

        findClassIdentifier :: HieASTs a -> Position -> ExceptT PluginError m Identifier
findClassIdentifier HieASTs a
hf Position
instancePosition =
            forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInternalError Text
"No Identifier found")
                forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe a
listToMaybe
                forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
hf Position
instancePosition
                    ( (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter forall a. IdentifierDetails a -> Bool
isClassNodeIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieAST a -> Map Identifier (IdentifierDetails a)
getNodeIds)
                        forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
                forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                forall a b. (a -> b) -> a -> b
$ forall t a. HieASTs t -> Position -> (HieAST t -> a) -> [a]
pointCommand HieASTs a
asts Position
instancePosition
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> String
getOccString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k a. Map k a -> [k]
Map.keys
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isInstanceValBind forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Set ContextInfo
identInfo)
                            forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> Map Identifier (IdentifierDetails a)
getNodeIds HieAST a
ast
            in [Identifier]
valBindIds forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. HieAST a -> [Identifier]
findInstanceValBindIdentifiers (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
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.findClassFromIdentifier.GhcSessionDeps" IdeState
state
                forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
docPath
            (TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
thisMod, PositionMapping
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.findClassFromIdentifier.TypeCheck" IdeState
state
                forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE TypeCheck
TypeCheck NormalizedFilePath
docPath
            forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM (Text -> PluginError
PluginInternalError Text
"initTcWithGbl failed")
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hscenv TcGblEnv
thisMod RealSrcSpan
ghostSpan 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Class
cls
                        TcTyThing
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Ide.Plugin.Class.findClassFromIdentifier"
        findClassFromIdentifier NormalizedFilePath
_ (Left ModuleName
_) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> PluginError
PluginInternalError Text
"Ide.Plugin.Class.findClassIdentifier")

isClassNodeIdentifier :: IdentifierDetails a -> Bool
isClassNodeIdentifier :: forall a. IdentifierDetails a -> Bool
isClassNodeIdentifier IdentifierDetails a
ident = (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IdentifierDetails a -> Maybe a
identType) IdentifierDetails a
ident Bool -> Bool -> Bool
&& ContextInfo
Use forall a. Ord a => a -> Set a -> Bool
`Set.member` forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
ident

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 :: InstanceBindTypeSig -> MethodDefinition
makeMethodDefinition :: InstanceBindTypeSig -> MethodDefinition
makeMethodDefinition InstanceBindTypeSig
sig = (Text
name, Text
signature)
    where
        name :: Text
name = Int -> Text -> Text
T.drop (Text -> Int
T.length forall s. IsString s => s
bindingPrefix) (forall a. Outputable a => a -> Text
printOutputable  (InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
sig))
        signature :: Text
signature = InstanceBindTypeSig -> Text
bindRendered InstanceBindTypeSig
sig

makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions Range
range [InstanceBindTypeSig]
sigs =
    [ InstanceBindTypeSig -> MethodDefinition
makeMethodDefinition InstanceBindTypeSig
sig
    | InstanceBindTypeSig
sig <- [InstanceBindTypeSig]
sigs
    , Range -> SrcSpan -> Bool
inRange Range
range (forall a. NamedThing a => a -> SrcSpan
getSrcSpan 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 forall s. IsString s => s
bindingPrefix) (forall a. Outputable a => a -> Text
printOutputable (InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
sig))

-- Return [groupName text, [(methodName text, signature text)]]
minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
minDefToMethodGroups :: Range
-> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
minDefToMethodGroups Range
range [InstanceBindTypeSig]
sigs BooleanFormula Name
minDef = forall {a} {b}. (Monoid a, IsString a) => [(a, b)] -> (a, [(a, b)])
makeMethodGroup 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 = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse a
"," forall a b. (a -> b) -> a -> b
$ (\a
x -> a
"'" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
"'") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst 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)   = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Range -> [InstanceBindTypeSig] -> [MethodDefinition]
makeMethodDefinitions Range
range forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(==) (forall a. Outputable a => a -> Text
printOutputable Name
mn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceBindTypeSig -> Text
signatureToName) [InstanceBindTypeSig]
sigs
        go (Or [LBooleanFormula Name]
ms)    = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BooleanFormula Name -> [[MethodDefinition]]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LBooleanFormula Name]
ms
        go (And [LBooleanFormula Name]
ms)   = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)) [[]] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BooleanFormula Name -> [[MethodDefinition]]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LBooleanFormula Name]
ms)
        go (Parens LBooleanFormula Name
m) = BooleanFormula Name -> [[MethodDefinition]]
go (forall l e. GenLocated l e -> e
unLoc LBooleanFormula Name
m)