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

module Ide.Plugin.Class.Types where

import           Control.DeepSeq               (rwhnf)
import           Control.Monad.Extra           (whenMaybe)
import           Control.Monad.IO.Class        (liftIO)
import           Data.Aeson
import           Data.Maybe                    (catMaybes)
import qualified Data.Text                     as T
import           Development.IDE
import qualified Development.IDE.Core.Shake    as Shake
import           Development.IDE.GHC.Compat    hiding ((<+>))
import           Development.IDE.Graph.Classes
import           GHC.Generics
import           Ide.Plugin.Class.Utils
import           Ide.Types

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 -> Uri
uri         :: Uri
    , AddMinimalMethodsParams -> Range
range       :: Range
    , AddMinimalMethodsParams -> List (Text, Text)
methodGroup :: List (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)

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 -> Text
bindRendered :: T.Text
    , InstanceBindTypeSig -> Maybe SrcSpan
bindDefSpan  :: Maybe SrcSpan
    -- ^SrcSpan for the bind definition
    }

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 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 implmented 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
    }

rules :: Recorder (WithPriority Log) -> Rules ()
rules :: Recorder (WithPriority Log) -> Rules ()
rules Recorder (WithPriority Log)
recorder = do
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
nfp -> do
        Maybe TcModuleResult
tmr <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp
        Maybe HscEnvEq
hsc <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
nfp
        Maybe InstanceBindTypeSigsResult
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe HscEnv
-> Maybe TcGblEnv -> IO (Maybe InstanceBindTypeSigsResult)
instanceBindType (HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HscEnvEq
hsc) (TcModuleResult -> TcGblEnv
tmrTypechecked forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TcModuleResult
tmr)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe InstanceBindTypeSigsResult
result)
    where
        instanceBindType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe InstanceBindTypeSigsResult)
        instanceBindType :: Maybe HscEnv
-> Maybe TcGblEnv -> IO (Maybe InstanceBindTypeSigsResult)
instanceBindType (Just HscEnv
hsc) (Just TcGblEnv
gblEnv) = do
            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 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
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [InstanceBindTypeSig] -> InstanceBindTypeSigsResult
InstanceBindTypeSigsResult [InstanceBindTypeSig]
instanceBinds
            where
                rdrEnv :: GlobalRdrEnv
rdrEnv = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gblEnv
                showDoc :: Type -> String
showDoc Type
ty = HscEnv -> PrintUnqualified -> SDoc -> String
showSDocForUser' HscEnv
hsc (HscEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualifiedDefault HscEnv
hsc GlobalRdrEnv
rdrEnv) (Type -> SDoc
pprSigmaType Type
ty)

                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 -> Text -> Maybe SrcSpan -> InstanceBindTypeSig
InstanceBindTypeSig Name
name
                                (Text -> Text
prettyBindingNameString (forall a. Outputable a => a -> Text
printOutputable Name
name) forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Type -> String
showDoc Type
ty))
                                forall a. Maybe a
Nothing
        instanceBindType Maybe HscEnv
_ Maybe TcGblEnv
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing