{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE ViewPatterns     #-}

module Ide.Plugin.Class.Types where

import           Control.DeepSeq                  (rwhnf)
import           Control.Monad.Extra              (mapMaybeM, whenMaybe)
import           Control.Monad.IO.Class           (liftIO)
import           Control.Monad.Trans.Maybe        (MaybeT (MaybeT, runMaybeT))
import           Data.Aeson
import qualified Data.IntMap                      as IntMap
import           Data.List.Extra                  (firstJust)
import           Data.Maybe                       (catMaybes, mapMaybe,
                                                   maybeToList)
import qualified Data.Text                        as T
import           Data.Unique                      (hashUnique, newUnique)
import           Development.IDE
import           Development.IDE.Core.PluginUtils (useMT)
import qualified Development.IDE.Core.Shake       as Shake
import           Development.IDE.GHC.Compat       hiding (newUnique, (<+>))
import           Development.IDE.GHC.Compat.Util  (bagToList)
import           Development.IDE.Graph.Classes
import           GHC.Generics
import           Ide.Plugin.Class.Utils
import           Ide.Types
import           Language.LSP.Protocol.Types      (TextEdit,
                                                   VersionedTextDocumentIdentifier)

typeLensCommandId :: CommandId
typeLensCommandId :: CommandId
typeLensCommandId = CommandId
"classplugin.typelens"

codeActionCommandId :: CommandId
codeActionCommandId :: CommandId
codeActionCommandId = CommandId
"classplugin.codeaction"

-- | Default indent size for inserting
defaultIndent :: Int
defaultIndent :: Int
defaultIndent = Int
2

data AddMinimalMethodsParams = AddMinimalMethodsParams
    { AddMinimalMethodsParams -> VersionedTextDocumentIdentifier
verTxtDocId :: VersionedTextDocumentIdentifier
    , AddMinimalMethodsParams -> Range
range       :: Range
    , AddMinimalMethodsParams -> [(Text, Text)]
methodGroup :: [(T.Text, T.Text)]
    -- ^ (name text, signature text)
    , AddMinimalMethodsParams -> Bool
withSig     :: Bool
    }
    deriving (Int -> AddMinimalMethodsParams -> ShowS
[AddMinimalMethodsParams] -> ShowS
AddMinimalMethodsParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddMinimalMethodsParams] -> ShowS
$cshowList :: [AddMinimalMethodsParams] -> ShowS
show :: AddMinimalMethodsParams -> String
$cshow :: AddMinimalMethodsParams -> String
showsPrec :: Int -> AddMinimalMethodsParams -> ShowS
$cshowsPrec :: Int -> AddMinimalMethodsParams -> ShowS
Show, AddMinimalMethodsParams -> AddMinimalMethodsParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddMinimalMethodsParams -> AddMinimalMethodsParams -> Bool
$c/= :: AddMinimalMethodsParams -> AddMinimalMethodsParams -> Bool
== :: AddMinimalMethodsParams -> AddMinimalMethodsParams -> Bool
$c== :: AddMinimalMethodsParams -> AddMinimalMethodsParams -> Bool
Eq, forall x. Rep AddMinimalMethodsParams x -> AddMinimalMethodsParams
forall x. AddMinimalMethodsParams -> Rep AddMinimalMethodsParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AddMinimalMethodsParams x -> AddMinimalMethodsParams
$cfrom :: forall x. AddMinimalMethodsParams -> Rep AddMinimalMethodsParams x
Generic, [AddMinimalMethodsParams] -> Encoding
[AddMinimalMethodsParams] -> Value
AddMinimalMethodsParams -> Encoding
AddMinimalMethodsParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AddMinimalMethodsParams] -> Encoding
$ctoEncodingList :: [AddMinimalMethodsParams] -> Encoding
toJSONList :: [AddMinimalMethodsParams] -> Value
$ctoJSONList :: [AddMinimalMethodsParams] -> Value
toEncoding :: AddMinimalMethodsParams -> Encoding
$ctoEncoding :: AddMinimalMethodsParams -> Encoding
toJSON :: AddMinimalMethodsParams -> Value
$ctoJSON :: AddMinimalMethodsParams -> Value
ToJSON, Value -> Parser [AddMinimalMethodsParams]
Value -> Parser AddMinimalMethodsParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AddMinimalMethodsParams]
$cparseJSONList :: Value -> Parser [AddMinimalMethodsParams]
parseJSON :: Value -> Parser AddMinimalMethodsParams
$cparseJSON :: Value -> Parser AddMinimalMethodsParams
FromJSON)

-- |The InstanceBindTypeSigs Rule collects the instance bindings type
-- signatures (both name and type). It is used by both the code actions and the
-- code lenses
data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs
    deriving (forall x. Rep GetInstanceBindTypeSigs x -> GetInstanceBindTypeSigs
forall x. GetInstanceBindTypeSigs -> Rep GetInstanceBindTypeSigs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetInstanceBindTypeSigs x -> GetInstanceBindTypeSigs
$cfrom :: forall x. GetInstanceBindTypeSigs -> Rep GetInstanceBindTypeSigs x
Generic, Int -> GetInstanceBindTypeSigs -> ShowS
[GetInstanceBindTypeSigs] -> ShowS
GetInstanceBindTypeSigs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetInstanceBindTypeSigs] -> ShowS
$cshowList :: [GetInstanceBindTypeSigs] -> ShowS
show :: GetInstanceBindTypeSigs -> String
$cshow :: GetInstanceBindTypeSigs -> String
showsPrec :: Int -> GetInstanceBindTypeSigs -> ShowS
$cshowsPrec :: Int -> GetInstanceBindTypeSigs -> ShowS
Show, GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
$c/= :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
== :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
$c== :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
Eq, Eq GetInstanceBindTypeSigs
GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Ordering
GetInstanceBindTypeSigs
-> GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs
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 :: GetInstanceBindTypeSigs
-> GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs
$cmin :: GetInstanceBindTypeSigs
-> GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs
max :: GetInstanceBindTypeSigs
-> GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs
$cmax :: GetInstanceBindTypeSigs
-> GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs
>= :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
$c>= :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
> :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
$c> :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
<= :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
$c<= :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
< :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
$c< :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Bool
compare :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Ordering
$ccompare :: GetInstanceBindTypeSigs -> GetInstanceBindTypeSigs -> Ordering
Ord, Eq GetInstanceBindTypeSigs
Int -> GetInstanceBindTypeSigs -> Int
GetInstanceBindTypeSigs -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetInstanceBindTypeSigs -> Int
$chash :: GetInstanceBindTypeSigs -> Int
hashWithSalt :: Int -> GetInstanceBindTypeSigs -> Int
$chashWithSalt :: Int -> GetInstanceBindTypeSigs -> Int
Hashable, GetInstanceBindTypeSigs -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetInstanceBindTypeSigs -> ()
$crnf :: GetInstanceBindTypeSigs -> ()
NFData)

data InstanceBindTypeSig = InstanceBindTypeSig
    { InstanceBindTypeSig -> Name
bindName :: Name
    , InstanceBindTypeSig -> Type
bindType :: Type
    }

newtype InstanceBindTypeSigsResult =
    InstanceBindTypeSigsResult [InstanceBindTypeSig]

instance Show InstanceBindTypeSigsResult where
    show :: InstanceBindTypeSigsResult -> String
show InstanceBindTypeSigsResult
_ = String
"<InstanceBindTypeSigs>"

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

type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult

-- |The necessary data to execute our code lens
data InstanceBindLensCommand = InstanceBindLensCommand
    { -- |The URI needed to run actions in the command
      InstanceBindLensCommand -> Uri
commandUri  :: Uri
      -- |The specific TextEdit we want to apply. This does not include the
      -- pragma edit which is computed in the command
    , InstanceBindLensCommand -> TextEdit
commandEdit :: TextEdit }
    deriving (forall x. Rep InstanceBindLensCommand x -> InstanceBindLensCommand
forall x. InstanceBindLensCommand -> Rep InstanceBindLensCommand x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InstanceBindLensCommand x -> InstanceBindLensCommand
$cfrom :: forall x. InstanceBindLensCommand -> Rep InstanceBindLensCommand x
Generic, Value -> Parser [InstanceBindLensCommand]
Value -> Parser InstanceBindLensCommand
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [InstanceBindLensCommand]
$cparseJSONList :: Value -> Parser [InstanceBindLensCommand]
parseJSON :: Value -> Parser InstanceBindLensCommand
$cparseJSON :: Value -> Parser InstanceBindLensCommand
FromJSON, [InstanceBindLensCommand] -> Encoding
[InstanceBindLensCommand] -> Value
InstanceBindLensCommand -> Encoding
InstanceBindLensCommand -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [InstanceBindLensCommand] -> Encoding
$ctoEncodingList :: [InstanceBindLensCommand] -> Encoding
toJSONList :: [InstanceBindLensCommand] -> Value
$ctoJSONList :: [InstanceBindLensCommand] -> Value
toEncoding :: InstanceBindLensCommand -> Encoding
$ctoEncoding :: InstanceBindLensCommand -> Encoding
toJSON :: InstanceBindLensCommand -> Value
$ctoJSON :: InstanceBindLensCommand -> Value
ToJSON)

-- | The InstanceBindLens rule is specifically for code lenses. It  relies on
-- the InstanceBindTypeSigs rule, filters out irrelevant matches and signatures
-- that can't be matched to a source span. It provides all the signatures linked
-- to a unique ID to aid in resolving. It also provides a list of enabled
-- extensions.
data GetInstanceBindLens = GetInstanceBindLens
    deriving (forall x. Rep GetInstanceBindLens x -> GetInstanceBindLens
forall x. GetInstanceBindLens -> Rep GetInstanceBindLens x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetInstanceBindLens x -> GetInstanceBindLens
$cfrom :: forall x. GetInstanceBindLens -> Rep GetInstanceBindLens x
Generic, Int -> GetInstanceBindLens -> ShowS
[GetInstanceBindLens] -> ShowS
GetInstanceBindLens -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetInstanceBindLens] -> ShowS
$cshowList :: [GetInstanceBindLens] -> ShowS
show :: GetInstanceBindLens -> String
$cshow :: GetInstanceBindLens -> String
showsPrec :: Int -> GetInstanceBindLens -> ShowS
$cshowsPrec :: Int -> GetInstanceBindLens -> ShowS
Show, GetInstanceBindLens -> GetInstanceBindLens -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
$c/= :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
== :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
$c== :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
Eq, Eq GetInstanceBindLens
GetInstanceBindLens -> GetInstanceBindLens -> Bool
GetInstanceBindLens -> GetInstanceBindLens -> Ordering
GetInstanceBindLens -> GetInstanceBindLens -> GetInstanceBindLens
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 :: GetInstanceBindLens -> GetInstanceBindLens -> GetInstanceBindLens
$cmin :: GetInstanceBindLens -> GetInstanceBindLens -> GetInstanceBindLens
max :: GetInstanceBindLens -> GetInstanceBindLens -> GetInstanceBindLens
$cmax :: GetInstanceBindLens -> GetInstanceBindLens -> GetInstanceBindLens
>= :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
$c>= :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
> :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
$c> :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
<= :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
$c<= :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
< :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
$c< :: GetInstanceBindLens -> GetInstanceBindLens -> Bool
compare :: GetInstanceBindLens -> GetInstanceBindLens -> Ordering
$ccompare :: GetInstanceBindLens -> GetInstanceBindLens -> Ordering
Ord, Eq GetInstanceBindLens
Int -> GetInstanceBindLens -> Int
GetInstanceBindLens -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetInstanceBindLens -> Int
$chash :: GetInstanceBindLens -> Int
hashWithSalt :: Int -> GetInstanceBindLens -> Int
$chashWithSalt :: Int -> GetInstanceBindLens -> Int
Hashable, GetInstanceBindLens -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetInstanceBindLens -> ()
$crnf :: GetInstanceBindLens -> ()
NFData)

data InstanceBindLens = InstanceBindLens
    { -- |What we need to provide the code lens. The range linked with
      -- a unique ID that will allow us to resolve the rest of the data later
      InstanceBindLens -> [(Range, Int)]
lensRange             :: [(Range, Int)]
      -- |Provides the necessary data to allow us to display the
      -- title of the lens and compute a TextEdit for it.
    , InstanceBindLens -> IntMap (Range, Name, Type)
lensDetails           :: IntMap.IntMap (Range, Name, Type)
    -- |Provides currently enabled extensions, allowing us to conditionally
    -- insert needed extensions.
    , InstanceBindLens -> [Extension]
lensEnabledExtensions :: [Extension]
    }

newtype InstanceBindLensResult =
    InstanceBindLensResult InstanceBindLens

instance Show InstanceBindLensResult where
    show :: InstanceBindLensResult -> String
show InstanceBindLensResult
_ = String
"<InstanceBindLens>"

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

type instance RuleResult GetInstanceBindLens = InstanceBindLensResult

data Log
  = LogImplementedMethods Class [T.Text]
  | LogShake Shake.Log

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogImplementedMethods Class
cls [Text]
methods ->
      forall a ann. Pretty a => a -> Doc ann
pretty (String
"Detected implemented methods for class" :: String)
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show (forall a. NamedThing a => a -> String
getOccString Class
cls) forall a. Semigroup a => a -> a -> a
<> String
":") -- 'show' is used here to add quotes around the class name
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [Text]
methods
    LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log

data BindInfo = BindInfo
    { BindInfo -> SrcSpan
bindSpan     :: SrcSpan
      -- ^ SrcSpan of the whole binding
    , BindInfo -> SrcSpan
bindNameSpan :: SrcSpan
      -- ^ SrcSpan of the binding name
    }

getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules ()
getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules ()
getInstanceBindLensRule Recorder (WithPriority Log)
recorder = do
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (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
$ \GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
        tmr :: TcModuleResult
tmr@(TcModuleResult -> RenamedSource
tmrRenamed ->  (forall p. HsGroup p -> [TyClGroup p]
hs_tyclds -> [TyClGroup GhcRn]
tycls, [LImportDecl GhcRn]
_, Maybe [(LIE GhcRn, Avails)]
_, Maybe LHsDocString
_)) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT TypeCheck
TypeCheck NormalizedFilePath
nfp
        (InstanceBindTypeSigsResult [InstanceBindTypeSig]
allBinds) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
nfp

        let -- declared instance methods without signatures
            bindInfos :: [BindInfo]
bindInfos = [ BindInfo
bind
                        | [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
instds <- forall a b. (a -> b) -> [a] -> [b]
map forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds [TyClGroup GhcRn]
tycls -- class instance decls
                        , GenLocated SrcSpanAnnA (InstDecl GhcRn)
instd <- [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
instds
                        , ClsInstDecl GhcRn
inst <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall {pass}. InstDecl pass -> Maybe (ClsInstDecl pass)
getClsInstD (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (InstDecl GhcRn)
instd)
                        , BindInfo
bind <- ClsInstDecl GhcRn -> [BindInfo]
getBindSpanWithoutSig ClsInstDecl GhcRn
inst
                        ]
            targetSigs :: [Maybe (InstanceBindTypeSig, SrcSpan)]
targetSigs = [BindInfo]
-> [InstanceBindTypeSig] -> [Maybe (InstanceBindTypeSig, SrcSpan)]
matchBind [BindInfo]
bindInfos [InstanceBindTypeSig]
allBinds
        [(Range, Int, Name, Type)]
rangeIntNameType <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Maybe (InstanceBindTypeSig, SrcSpan)
-> IO (Maybe (Range, Int, Name, Type))
getRangeWithSig [Maybe (InstanceBindTypeSig, SrcSpan)]
targetSigs
        let lensRange :: [(Range, Int)]
lensRange = (\(Range
range, Int
int, Name
_, Type
_) -> (Range
range, Int
int)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Range, Int, Name, Type)]
rangeIntNameType
            lensDetails :: IntMap (Range, Name, Type)
lensDetails = forall a. [(Int, a)] -> IntMap a
IntMap.fromList forall a b. (a -> b) -> a -> b
$ (\(Range
range, Int
int, Name
name, Type
typ) -> (Int
int, (Range
range, Name
name, Type
typ))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Range, Int, Name, Type)]
rangeIntNameType
            lensEnabledExtensions :: [Extension]
lensEnabledExtensions = ParsedModule -> [Extension]
getExtensions forall a b. (a -> b) -> a -> b
$ TcModuleResult -> ParsedModule
tmrParsed TcModuleResult
tmr
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ InstanceBindLens -> InstanceBindLensResult
InstanceBindLensResult forall a b. (a -> b) -> a -> b
$ InstanceBindLens{[(Range, Int)]
[Extension]
IntMap (Range, Name, Type)
lensEnabledExtensions :: [Extension]
lensDetails :: IntMap (Range, Name, Type)
lensRange :: [(Range, Int)]
lensEnabledExtensions :: [Extension]
lensDetails :: IntMap (Range, Name, Type)
lensRange :: [(Range, Int)]
..}
    where
        -- Match Binds with their signatures
        -- We try to give every `InstanceBindTypeSig` a `SrcSpan`,
        -- hence we can display signatures for `InstanceBindTypeSig` with span later.
        matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [Maybe (InstanceBindTypeSig, SrcSpan)]
        matchBind :: [BindInfo]
-> [InstanceBindTypeSig] -> [Maybe (InstanceBindTypeSig, SrcSpan)]
matchBind [BindInfo]
existedBinds [InstanceBindTypeSig]
allBindWithSigs =
            [forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust (InstanceBindTypeSig
-> BindInfo -> Maybe (InstanceBindTypeSig, SrcSpan)
go InstanceBindTypeSig
bindSig) [BindInfo]
existedBinds | InstanceBindTypeSig
bindSig <- [InstanceBindTypeSig]
allBindWithSigs]
            where
                go :: InstanceBindTypeSig -> BindInfo -> Maybe (InstanceBindTypeSig,  SrcSpan)
                go :: InstanceBindTypeSig
-> BindInfo -> Maybe (InstanceBindTypeSig, SrcSpan)
go InstanceBindTypeSig
bindSig BindInfo
bind = do
                    Range
range <- (SrcSpan -> Maybe Range
srcSpanToRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindInfo -> SrcSpan
bindNameSpan) BindInfo
bind
                    if Range -> SrcSpan -> Bool
inRange Range
range (forall a. NamedThing a => a -> SrcSpan
getSrcSpan forall a b. (a -> b) -> a -> b
$ InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
bindSig)
                    then forall a. a -> Maybe a
Just (InstanceBindTypeSig
bindSig, BindInfo -> SrcSpan
bindSpan BindInfo
bind)
                    else forall a. Maybe a
Nothing

        getClsInstD :: InstDecl pass -> Maybe (ClsInstDecl pass)
getClsInstD (ClsInstD XClsInstD pass
_ ClsInstDecl pass
d) = forall a. a -> Maybe a
Just ClsInstDecl pass
d
        getClsInstD InstDecl pass
_              = forall a. Maybe a
Nothing

        getSigName :: Sig pass -> Maybe [IdP pass]
getSigName (ClassOpSig XClassOpSig pass
_ Bool
_ [XRec pass (IdP pass)]
sigNames LHsSigType pass
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [XRec pass (IdP pass)]
sigNames
        getSigName Sig pass
_                           = forall a. Maybe a
Nothing

        getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]
        getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]
getBindSpanWithoutSig ClsInstDecl{[LTyFamInstDecl GhcRn]
[LDataFamInstDecl GhcRn]
[LSig GhcRn]
Maybe (XRec GhcRn OverlapMode)
LHsSigType GhcRn
XCClsInstDecl GhcRn
LHsBinds GhcRn
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_ext :: forall pass. ClsInstDecl pass -> XCClsInstDecl pass
cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_overlap_mode :: Maybe (XRec GhcRn OverlapMode)
cid_datafam_insts :: [LDataFamInstDecl GhcRn]
cid_tyfam_insts :: [LTyFamInstDecl GhcRn]
cid_sigs :: [LSig GhcRn]
cid_binds :: LHsBinds GhcRn
cid_poly_ty :: LHsSigType GhcRn
cid_ext :: XCClsInstDecl GhcRn
..} =
            let bindNames :: [GenLocated SrcSpanAnnA (GenLocated SrcSpanAnnN (IdP GhcRn))]
bindNames = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {l} {idL} {p}.
GenLocated l (HsBindLR idL p)
-> Maybe (GenLocated l (XRec idL (IdP idL)))
go (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
cid_binds)
                go :: GenLocated l (HsBindLR idL p)
-> Maybe (GenLocated l (XRec idL (IdP idL)))
go (L l
l HsBindLR idL p
bind) = case HsBindLR idL p
bind of
                    FunBind{[CoreTickish]
MatchGroup p (LHsExpr p)
XRec idL (IdP idL)
XFunBind idL p
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick :: [CoreTickish]
fun_matches :: MatchGroup p (LHsExpr p)
fun_id :: XRec idL (IdP idL)
fun_ext :: XFunBind idL p
..}
                        -- `Generated` tagged for Template Haskell,
                        -- here we filter out nonsense generated bindings
                        -- that are nonsense for displaying code lenses.
                        --
                        -- See https://github.com/haskell/haskell-language-server/issues/3319
                        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Origin -> Bool
isGenerated (forall p body. MatchGroup p body -> Origin
groupOrigin MatchGroup p (LHsExpr p)
fun_matches)
                            -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L l
l XRec idL (IdP idL)
fun_id
                    HsBindLR idL p
_       -> forall a. Maybe a
Nothing
                -- Existed signatures' name
                sigNames :: [IdP GhcRn]
sigNames = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(L SrcSpanAnnA
_ Sig GhcRn
r) -> forall {pass} {l}.
(XRec pass (IdP pass) ~ GenLocated l (IdP pass)) =>
Sig pass -> Maybe [IdP pass]
getSigName Sig GhcRn
r) [LSig GhcRn]
cid_sigs
                toBindInfo :: GenLocated (SrcSpanAnn' a) (GenLocated (SrcSpanAnn' a) e)
-> BindInfo
toBindInfo (L SrcSpanAnn' a
l (L SrcSpanAnn' a
l' e
_)) = SrcSpan -> SrcSpan -> BindInfo
BindInfo
                    (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l) -- bindSpan
                    (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l') -- bindNameSpan
            in forall {a} {a} {e}.
GenLocated (SrcSpanAnn' a) (GenLocated (SrcSpanAnn' a) e)
-> BindInfo
toBindInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (\(L SrcSpanAnnA
_ GenLocated SrcSpanAnnN (IdP GhcRn)
name) -> forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN (IdP GhcRn)
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [IdP GhcRn]
sigNames) [GenLocated SrcSpanAnnA (GenLocated SrcSpanAnnN (IdP GhcRn))]
bindNames
        getBindSpanWithoutSig ClsInstDecl GhcRn
_ = []

        -- Get bind definition range with its rendered signature text
        getRangeWithSig :: Maybe (InstanceBindTypeSig, SrcSpan) -> IO (Maybe (Range, Int, Name, Type))
        getRangeWithSig :: Maybe (InstanceBindTypeSig, SrcSpan)
-> IO (Maybe (Range, Int, Name, Type))
getRangeWithSig (Just (InstanceBindTypeSig
bind, SrcSpan
span)) = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
            Range
range <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
span
            Int
uniqueID <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Unique -> Int
hashUnique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Range
range, Int
uniqueID, InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
bind, InstanceBindTypeSig -> Type
bindType InstanceBindTypeSig
bind)
        getRangeWithSig Maybe (InstanceBindTypeSig, SrcSpan)
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing


getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules ()
getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules ()
getInstanceBindTypeSigsRule Recorder (WithPriority Log)
recorder = do
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (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
$ \GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
nfp -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
        (TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
gblEnv ) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT TypeCheck
TypeCheck NormalizedFilePath
nfp
        (HscEnvEq -> HscEnv
hscEnv -> HscEnv
hsc) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT GhcSession
GhcSession NormalizedFilePath
nfp
        let binds :: [IdP GhcTc]
binds = forall p idR.
CollectPass p =>
Bag (XRec p (HsBindLR p idR)) -> [IdP p]
collectHsBindsBinders forall a b. (a -> b) -> a -> b
$ TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
gblEnv
        (Messages DecoratedSDoc
_, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. [Maybe a] -> [a]
catMaybes -> [InstanceBindTypeSig]
instanceBinds) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hsc TcGblEnv
gblEnv RealSrcSpan
ghostSpan forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe InstanceBindTypeSig)
bindToSig [IdP GhcTc]
binds
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [InstanceBindTypeSig] -> InstanceBindTypeSigsResult
InstanceBindTypeSigsResult [InstanceBindTypeSig]
instanceBinds
    where
        bindToSig :: Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe InstanceBindTypeSig)
bindToSig Id
id = do
            let name :: Name
name = Id -> Name
idName Id
id
            forall (m :: * -> *) a. Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe (Name -> Bool
isBindingName Name
name) forall a b. (a -> b) -> a -> b
$ do
                TidyEnv
env <- TcM TidyEnv
tcInitTidyEnv
                let (TidyEnv
_, Type
ty) = TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType TidyEnv
env (Id -> Type
idType Id
id)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type -> InstanceBindTypeSig
InstanceBindTypeSig Name
name Type
ty