{-# 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"
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)]
, 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)
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
data InstanceBindLensCommand = InstanceBindLensCommand
{
InstanceBindLensCommand -> Uri
commandUri :: Uri
, 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)
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
{
InstanceBindLens -> [(Range, Int)]
lensRange :: [(Range, Int)]
, InstanceBindLens -> IntMap (Range, Name, Type)
lensDetails :: IntMap.IntMap (Range, Name, Type)
, 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
":")
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
, BindInfo -> SrcSpan
bindNameSpan :: SrcSpan
}
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
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
, 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
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
..}
| 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
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)
(forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l')
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
_ = []
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