{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Plugin.TypeLenses (
descriptor,
suggestSignature,
typeLensCommandId,
GlobalBindingTypeSig (..),
GetGlobalBindingTypeSigs (..),
GlobalBindingTypeSigsResult (..),
Log(..)
) where
import Control.Concurrent.STM.Stats (atomically)
import Control.DeepSeq (rwhnf)
import Control.Monad (mzero)
import Control.Monad.Extra (whenMaybe)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson.Types (Value (..), toJSON)
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as Map
import Data.List (find)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Development.IDE (GhcSession (..),
HscEnvEq (hscEnv),
RuleResult, Rules, define,
srcSpanToRange,
usePropertyAction)
import Development.IDE.Core.Compile (TcModuleResult (..))
import Development.IDE.Core.Rules (IdeState, runAction)
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
TypeCheck (TypeCheck))
import Development.IDE.Core.Service (getDiagnostics)
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Util (printName)
import Development.IDE.Graph.Classes
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
import Development.IDE.Types.Location (Position (Position, _character, _line),
Range (Range, _end, _start),
toNormalizedFilePath',
uriToFilePath')
import Development.IDE.Types.Logger (Pretty (pretty), Recorder,
WithPriority,
cmapWithPrio)
import GHC.Generics (Generic)
import Ide.Plugin.Config (Config)
import Ide.Plugin.Properties
import Ide.PluginUtils (mkLspCommand)
import Ide.Types (CommandFunction,
CommandId (CommandId),
PluginCommand (PluginCommand),
PluginDescriptor (..),
PluginId,
configCustomConfig,
defaultConfigDescriptor,
defaultPluginDescriptor,
mkCustomConfig,
mkPluginHandler)
import qualified Language.LSP.Server as LSP
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
CodeLens (CodeLens),
CodeLensParams (CodeLensParams, _textDocument),
Diagnostic (..),
List (..), ResponseError,
SMethod (..),
TextDocumentIdentifier (TextDocumentIdentifier),
TextEdit (TextEdit),
WorkspaceEdit (WorkspaceEdit))
import Text.Regex.TDFA ((=~), (=~~))
data Log = LogShake Shake.Log deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
typeLensCommandId :: T.Text
typeLensCommandId :: Text
typeLensCommandId = Text
"typesignature.add"
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
(forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeLens
STextDocumentCodeLens IdeState
-> PluginId
-> CodeLensParams
-> LspM Config (Either ResponseError (List CodeLens))
codeLensProvider
, pluginCommands :: [PluginCommand IdeState]
pluginCommands = [forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand (Text -> CommandId
CommandId Text
typeLensCommandId) Text
"adds a signature" CommandFunction IdeState WorkspaceEdit
commandHandler]
, pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
rules Recorder (WithPriority Log)
recorder
, pluginConfigDescriptor :: ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor {configCustomConfig :: CustomConfig
configCustomConfig = forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
properties}
}
properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
properties = Properties '[]
emptyProperties
forall a b. a -> (a -> b) -> b
& forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a, Eq a, Show a) =>
KeyNameProxy s
-> Text
-> [(a, Text)]
-> a
-> Properties r
-> Properties ('PropertyKey s ('TEnum a) : r)
defineEnumProperty forall a. IsLabel "mode" a => a
#mode Text
"Control how type lenses are shown"
[ (Mode
Always, Text
"Always displays type lenses of global bindings")
, (Mode
Exported, Text
"Only display type lenses of exported global bindings")
, (Mode
Diagnostics, Text
"Follows error messages produced by GHC about missing signatures")
] Mode
Always
codeLensProvider ::
IdeState ->
PluginId ->
CodeLensParams ->
LSP.LspM Config (Either ResponseError (List CodeLens))
codeLensProvider :: IdeState
-> PluginId
-> CodeLensParams
-> LspM Config (Either ResponseError (List CodeLens))
codeLensProvider IdeState
ideState PluginId
pId CodeLensParams{$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument = TextDocumentIdentifier Uri
uri} = do
Mode
mode <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.config" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
(r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction forall a. IsLabel "mode" a => a
#mode PluginId
pId Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
properties
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> List a
List) forall a b. (a -> b) -> a -> b
$ case Uri -> Maybe String
uriToFilePath' Uri
uri of
Just (String -> NormalizedFilePath
toNormalizedFilePath' -> NormalizedFilePath
filePath) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe HscEnv
env <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.GhcSession" IdeState
ideState (forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
filePath)
Maybe TcModuleResult
tmr <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.TypeCheck" IdeState
ideState (forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
filePath)
Maybe Bindings
bindings <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.GetBindings" IdeState
ideState (forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetBindings
GetBindings NormalizedFilePath
filePath)
Maybe GlobalBindingTypeSigsResult
gblSigs <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.GetGlobalBindingTypeSigs" IdeState
ideState (forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs NormalizedFilePath
filePath)
[FileDiagnostic]
diag <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ IdeState -> STM [FileDiagnostic]
getDiagnostics IdeState
ideState
[FileDiagnostic]
hDiag <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ IdeState -> STM [FileDiagnostic]
getHiddenDiagnostics IdeState
ideState
let toWorkSpaceEdit :: [TextEdit] -> WorkspaceEdit
toWorkSpaceEdit [TextEdit]
tedit = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Uri
uri forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [TextEdit]
tedit) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
generateLensForGlobal :: GlobalBindingTypeSig -> Maybe CodeLens
generateLensForGlobal sig :: GlobalBindingTypeSig
sig@GlobalBindingTypeSig{Bool
String
Name
gbExported :: GlobalBindingTypeSig -> Bool
gbRendered :: GlobalBindingTypeSig -> String
gbName :: GlobalBindingTypeSig -> Name
gbExported :: Bool
gbRendered :: String
gbName :: Name
..} = do
Range
range <- SrcSpan -> Maybe Range
srcSpanToRange forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> SrcSpan
gbSrcSpan GlobalBindingTypeSig
sig
TextEdit
tedit <- GlobalBindingTypeSig -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig
sig
let wedit :: WorkspaceEdit
wedit = [TextEdit] -> WorkspaceEdit
toWorkSpaceEdit [TextEdit
tedit]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PluginId -> Range -> Text -> WorkspaceEdit -> CodeLens
generateLens PluginId
pId Range
range (String -> Text
T.pack String
gbRendered) WorkspaceEdit
wedit
gblSigs' :: [GlobalBindingTypeSig]
gblSigs' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(GlobalBindingTypeSigsResult [GlobalBindingTypeSig]
x) -> [GlobalBindingTypeSig]
x) Maybe GlobalBindingTypeSigsResult
gblSigs
generateLensFromDiags :: (Diagnostic -> [(Text, [TextEdit])]) -> IO [CodeLens]
generateLensFromDiags Diagnostic -> [(Text, [TextEdit])]
f =
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PluginId -> Range -> Text -> WorkspaceEdit -> CodeLens
generateLens PluginId
pId Range
_range Text
title WorkspaceEdit
edit
| (NormalizedFilePath
dFile, ShowDiagnostic
_, dDiag :: Diagnostic
dDiag@Diagnostic{$sel:_range:Diagnostic :: Diagnostic -> Range
_range = Range
_range}) <- [FileDiagnostic]
diag forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
hDiag
, NormalizedFilePath
dFile forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
filePath
, (Text
title, [TextEdit]
tedit) <- Diagnostic -> [(Text, [TextEdit])]
f Diagnostic
dDiag
, let edit :: WorkspaceEdit
edit = [TextEdit] -> WorkspaceEdit
toWorkSpaceEdit [TextEdit]
tedit
]
case Mode
mode of
Mode
Always ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> Maybe CodeLens
generateLensForGlobal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GlobalBindingTypeSig]
gblSigs')
forall a. Semigroup a => a -> a -> a
<> (Diagnostic -> [(Text, [TextEdit])]) -> IO [CodeLens]
generateLensFromDiags (Bool
-> Maybe HscEnv
-> Maybe TcModuleResult
-> Maybe Bindings
-> Diagnostic
-> [(Text, [TextEdit])]
suggestLocalSignature Bool
False Maybe HscEnv
env Maybe TcModuleResult
tmr Maybe Bindings
bindings)
Mode
Exported -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> Maybe CodeLens
generateLensForGlobal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter GlobalBindingTypeSig -> Bool
gbExported [GlobalBindingTypeSig]
gblSigs'
Mode
Diagnostics -> (Diagnostic -> [(Text, [TextEdit])]) -> IO [CodeLens]
generateLensFromDiags forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe HscEnv
-> Maybe GlobalBindingTypeSigsResult
-> Maybe TcModuleResult
-> Maybe Bindings
-> Diagnostic
-> [(Text, [TextEdit])]
suggestSignature Bool
False Maybe HscEnv
env Maybe GlobalBindingTypeSigsResult
gblSigs Maybe TcModuleResult
tmr Maybe Bindings
bindings
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
generateLens :: PluginId -> Range -> Text -> WorkspaceEdit -> CodeLens
generateLens PluginId
pId Range
_range Text
title WorkspaceEdit
edit =
let cId :: Command
cId = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
pId (Text -> CommandId
CommandId Text
typeLensCommandId) Text
title (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON WorkspaceEdit
edit])
in Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
_range (forall a. a -> Maybe a
Just Command
cId) forall a. Maybe a
Nothing
commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler IdeState
_ideState WorkspaceEdit
wedit = do
LspId 'WorkspaceApplyEdit
_ <- forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null
suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
suggestSignature :: Bool
-> Maybe HscEnv
-> Maybe GlobalBindingTypeSigsResult
-> Maybe TcModuleResult
-> Maybe Bindings
-> Diagnostic
-> [(Text, [TextEdit])]
suggestSignature Bool
isQuickFix Maybe HscEnv
env Maybe GlobalBindingTypeSigsResult
mGblSigs Maybe TcModuleResult
mTmr Maybe Bindings
mBindings Diagnostic
diag =
Bool
-> Maybe GlobalBindingTypeSigsResult
-> Diagnostic
-> [(Text, [TextEdit])]
suggestGlobalSignature Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs Diagnostic
diag forall a. Semigroup a => a -> a -> a
<> Bool
-> Maybe HscEnv
-> Maybe TcModuleResult
-> Maybe Bindings
-> Diagnostic
-> [(Text, [TextEdit])]
suggestLocalSignature Bool
isQuickFix Maybe HscEnv
env Maybe TcModuleResult
mTmr Maybe Bindings
mBindings Diagnostic
diag
suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])]
suggestGlobalSignature :: Bool
-> Maybe GlobalBindingTypeSigsResult
-> Diagnostic
-> [(Text, [TextEdit])]
suggestGlobalSignature Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs Diagnostic{Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message :: Text
_message, Range
_range :: Range
$sel:_range:Diagnostic :: Diagnostic -> Range
_range}
| Text
_message
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"(Top-level binding|Pattern synonym) with no type signature" :: T.Text)
, Just (GlobalBindingTypeSigsResult [GlobalBindingTypeSig]
sigs) <- Maybe GlobalBindingTypeSigsResult
mGblSigs
, Just GlobalBindingTypeSig
sig <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\GlobalBindingTypeSig
x -> SrcSpan -> Range -> Bool
sameThing (GlobalBindingTypeSig -> SrcSpan
gbSrcSpan GlobalBindingTypeSig
x) Range
_range) [GlobalBindingTypeSig]
sigs
, Text
signature <- String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> String
gbRendered GlobalBindingTypeSig
sig
, Text
title <- if Bool
isQuickFix then Text
"add signature: " forall a. Semigroup a => a -> a -> a
<> Text
signature else Text
signature
, Just TextEdit
action <- GlobalBindingTypeSig -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig
sig =
[(Text
title, [TextEdit
action])]
| Bool
otherwise = []
suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
suggestLocalSignature :: Bool
-> Maybe HscEnv
-> Maybe TcModuleResult
-> Maybe Bindings
-> Diagnostic
-> [(Text, [TextEdit])]
suggestLocalSignature Bool
isQuickFix Maybe HscEnv
mEnv Maybe TcModuleResult
mTmr Maybe Bindings
mBindings Diagnostic{Text
_message :: Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message, $sel:_range:Diagnostic :: Diagnostic -> Range
_range = _range :: Range
_range@Range{Position
_end :: Position
_start :: Position
_start :: Range -> Position
_end :: Range -> Position
..}}
| Just (Text
_ :: T.Text, Text
_ :: T.Text, Text
_ :: T.Text, [Text
identifier]) <-
([Text] -> Text
T.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words forall a b. (a -> b) -> a -> b
$ Text
_message)
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ (Text
"Polymorphic local binding with no type signature: (.*) ::" :: T.Text)
, Just Bindings
bindings <- Maybe Bindings
mBindings
, Just HscEnv
env <- Maybe HscEnv
mEnv
, [(Name, Maybe Type)]
localScope <- Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyScope Bindings
bindings Position
_start Position
_end
,
Just (Name
name, Type
ty) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Name
x, Maybe Type
_) -> Name -> String
printName Name
x forall a. Eq a => a -> a -> Bool
== Text -> String
T.unpack Text
identifier) [(Name, Maybe Type)]
localScope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Name
name, Maybe Type
mTy) -> (Name
name,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Type
mTy
, Just TcModuleResult{tmrTypechecked :: TcModuleResult -> TcGblEnv
tmrTypechecked = TcGblEnv{GlobalRdrEnv
tcg_rdr_env :: TcGblEnv -> GlobalRdrEnv
tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env, NameSet
tcg_sigs :: TcGblEnv -> NameSet
tcg_sigs :: NameSet
tcg_sigs}} <- Maybe TcModuleResult
mTmr
,
Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
tcg_sigs
, String
tyMsg <- PrintUnqualified -> SDoc -> String
printSDocQualifiedUnsafe (HscEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualifiedDefault HscEnv
env GlobalRdrEnv
tcg_rdr_env) forall a b. (a -> b) -> a -> b
$ Type -> SDoc
pprSigmaType Type
ty
, Text
signature <- String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Name -> String
printName Name
name forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> String
tyMsg
, UInt
startCharacter <- Position -> UInt
_character Position
_start
, Position
startOfLine <- UInt -> UInt -> Position
Position (Position -> UInt
_line Position
_start) UInt
startCharacter
, Range
beforeLine <- Position -> Position -> Range
Range Position
startOfLine Position
startOfLine
, Text
title <- if Bool
isQuickFix then Text
"add signature: " forall a. Semigroup a => a -> a -> a
<> Text
signature else Text
signature
, TextEdit
action <- Range -> Text -> TextEdit
TextEdit Range
beforeLine forall a b. (a -> b) -> a -> b
$ Text
signature forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
startCharacter) Text
" " =
[(Text
title, [TextEdit
action])]
| Bool
otherwise = []
sameThing :: SrcSpan -> Range -> Bool
sameThing :: SrcSpan -> Range -> Bool
sameThing SrcSpan
s1 Range
s2 = (Range -> Position
_start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
s1) forall a. Eq a => a -> a -> Bool
== (Range -> Position
_start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a
Just Range
s2)
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig{Bool
String
Name
gbExported :: Bool
gbRendered :: String
gbName :: Name
gbExported :: GlobalBindingTypeSig -> Bool
gbRendered :: GlobalBindingTypeSig -> String
gbName :: GlobalBindingTypeSig -> Name
..}
| Just Range{Position
_end :: Position
_start :: Position
_start :: Range -> Position
_end :: Range -> Position
..} <- SrcSpan -> Maybe Range
srcSpanToRange forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
gbName
, Position
startOfLine <- UInt -> UInt -> Position
Position (Position -> UInt
_line Position
_start) UInt
0
, Range
beforeLine <- Position -> Position -> Range
Range Position
startOfLine Position
startOfLine =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Range -> Text -> TextEdit
TextEdit Range
beforeLine forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
gbRendered forall a. Semigroup a => a -> a -> a
<> Text
"\n"
| Bool
otherwise = forall a. Maybe a
Nothing
data Mode
=
Always
|
Exported
|
Diagnostics
deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Eq Mode
Mode -> Mode -> Bool
Mode -> Mode -> Ordering
Mode -> Mode -> Mode
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 :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmax :: Mode -> Mode -> Mode
>= :: Mode -> Mode -> Bool
$c>= :: Mode -> Mode -> Bool
> :: Mode -> Mode -> Bool
$c> :: Mode -> Mode -> Bool
<= :: Mode -> Mode -> Bool
$c<= :: Mode -> Mode -> Bool
< :: Mode -> Mode -> Bool
$c< :: Mode -> Mode -> Bool
compare :: Mode -> Mode -> Ordering
$ccompare :: Mode -> Mode -> Ordering
Ord, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show, ReadPrec [Mode]
ReadPrec Mode
Int -> ReadS Mode
ReadS [Mode]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Mode]
$creadListPrec :: ReadPrec [Mode]
readPrec :: ReadPrec Mode
$creadPrec :: ReadPrec Mode
readList :: ReadS [Mode]
$creadList :: ReadS [Mode]
readsPrec :: Int -> ReadS Mode
$creadsPrec :: Int -> ReadS Mode
Read, Int -> Mode
Mode -> Int
Mode -> [Mode]
Mode -> Mode
Mode -> Mode -> [Mode]
Mode -> Mode -> Mode -> [Mode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Mode -> Mode -> Mode -> [Mode]
$cenumFromThenTo :: Mode -> Mode -> Mode -> [Mode]
enumFromTo :: Mode -> Mode -> [Mode]
$cenumFromTo :: Mode -> Mode -> [Mode]
enumFromThen :: Mode -> Mode -> [Mode]
$cenumFromThen :: Mode -> Mode -> [Mode]
enumFrom :: Mode -> [Mode]
$cenumFrom :: Mode -> [Mode]
fromEnum :: Mode -> Int
$cfromEnum :: Mode -> Int
toEnum :: Int -> Mode
$ctoEnum :: Int -> Mode
pred :: Mode -> Mode
$cpred :: Mode -> Mode
succ :: Mode -> Mode
$csucc :: Mode -> Mode
Enum)
instance A.ToJSON Mode where
toJSON :: Mode -> Value
toJSON Mode
Always = Value
"always"
toJSON Mode
Exported = Value
"exported"
toJSON Mode
Diagnostics = Value
"diagnostics"
instance A.FromJSON Mode where
parseJSON :: Value -> Parser Mode
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Mode" forall a b. (a -> b) -> a -> b
$ \case
Text
"always" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Always
Text
"exported" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Exported
Text
"diagnostics" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Diagnostics
Text
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String
showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String
showDocRdrEnv HscEnv
env GlobalRdrEnv
rdrEnv = HscEnv -> PrintUnqualified -> SDoc -> String
showSDocForUser' HscEnv
env (HscEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualifiedDefault HscEnv
env GlobalRdrEnv
rdrEnv)
data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs
deriving (forall x.
Rep GetGlobalBindingTypeSigs x -> GetGlobalBindingTypeSigs
forall x.
GetGlobalBindingTypeSigs -> Rep GetGlobalBindingTypeSigs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep GetGlobalBindingTypeSigs x -> GetGlobalBindingTypeSigs
$cfrom :: forall x.
GetGlobalBindingTypeSigs -> Rep GetGlobalBindingTypeSigs x
Generic, Int -> GetGlobalBindingTypeSigs -> ShowS
[GetGlobalBindingTypeSigs] -> ShowS
GetGlobalBindingTypeSigs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetGlobalBindingTypeSigs] -> ShowS
$cshowList :: [GetGlobalBindingTypeSigs] -> ShowS
show :: GetGlobalBindingTypeSigs -> String
$cshow :: GetGlobalBindingTypeSigs -> String
showsPrec :: Int -> GetGlobalBindingTypeSigs -> ShowS
$cshowsPrec :: Int -> GetGlobalBindingTypeSigs -> ShowS
Show, GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c/= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
== :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c== :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
Eq, Eq GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Ordering
GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
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 :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
$cmin :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
max :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
$cmax :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
>= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c>= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
> :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c> :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
<= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c<= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
< :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c< :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
compare :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Ordering
$ccompare :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Ordering
Ord, Eq GetGlobalBindingTypeSigs
Int -> GetGlobalBindingTypeSigs -> Int
GetGlobalBindingTypeSigs -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetGlobalBindingTypeSigs -> Int
$chash :: GetGlobalBindingTypeSigs -> Int
hashWithSalt :: Int -> GetGlobalBindingTypeSigs -> Int
$chashWithSalt :: Int -> GetGlobalBindingTypeSigs -> Int
Hashable, GetGlobalBindingTypeSigs -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetGlobalBindingTypeSigs -> ()
$crnf :: GetGlobalBindingTypeSigs -> ()
NFData)
data GlobalBindingTypeSig = GlobalBindingTypeSig
{ GlobalBindingTypeSig -> Name
gbName :: Name
, GlobalBindingTypeSig -> String
gbRendered :: String
, GlobalBindingTypeSig -> Bool
gbExported :: Bool
}
gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan
gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan
gbSrcSpan GlobalBindingTypeSig{Name
gbName :: Name
gbName :: GlobalBindingTypeSig -> Name
gbName} = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
gbName
newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig]
instance Show GlobalBindingTypeSigsResult where
show :: GlobalBindingTypeSigsResult -> String
show GlobalBindingTypeSigsResult
_ = String
"<GetTypeResult>"
instance NFData GlobalBindingTypeSigsResult where
rnf :: GlobalBindingTypeSigsResult -> ()
rnf = forall a. a -> ()
rwhnf
type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult
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
$ \GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs 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 GlobalBindingTypeSigsResult
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe HscEnv
-> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
gblBindingType (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 GlobalBindingTypeSigsResult
result)
gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
gblBindingType :: Maybe HscEnv
-> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
gblBindingType (Just HscEnv
hsc) (Just TcGblEnv
gblEnv) = do
let exports :: NameSet
exports = [AvailInfo] -> NameSet
availsToNameSet forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
gblEnv
sigs :: NameSet
sigs = TcGblEnv -> NameSet
tcg_sigs TcGblEnv
gblEnv
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
patSyns :: [PatSyn]
patSyns = TcGblEnv -> [PatSyn]
tcg_patsyns TcGblEnv
gblEnv
rdrEnv :: GlobalRdrEnv
rdrEnv = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gblEnv
showDoc :: SDoc -> String
showDoc = HscEnv -> GlobalRdrEnv -> SDoc -> String
showDocRdrEnv HscEnv
hsc GlobalRdrEnv
rdrEnv
hasSig :: (Monad m) => Name -> m a -> m (Maybe a)
hasSig :: forall (m :: * -> *) a. Monad m => Name -> m a -> m (Maybe a)
hasSig Name
name m a
f = forall (m :: * -> *) a. Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe (Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
sigs) m a
f
bindToSig :: Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
bindToSig Id
id = do
let name :: Name
name = Id -> Name
idName Id
id
forall (m :: * -> *) a. Monad m => Name -> m a -> m (Maybe a)
hasSig 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 -> String -> Bool -> GlobalBindingTypeSig
GlobalBindingTypeSig Name
name (Name -> String
printName Name
name forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> SDoc -> String
showDoc (Type -> SDoc
pprSigmaType Type
ty)) (Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
exports)
patToSig :: PatSyn -> IO (Maybe GlobalBindingTypeSig)
patToSig PatSyn
p = do
let name :: Name
name = PatSyn -> Name
patSynName PatSyn
p
forall (m :: * -> *) a. Monad m => Name -> m a -> m (Maybe a)
hasSig Name
name forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> String -> Bool -> GlobalBindingTypeSig
GlobalBindingTypeSig Name
name (String
"pattern " forall a. Semigroup a => a -> a -> a
<> Name -> String
printName Name
name forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> SDoc -> String
showDoc (PatSyn -> SDoc
pprPatSynTypeWithoutForalls PatSyn
p)) (Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
exports)
(Messages DecoratedSDoc
_, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. [Maybe a] -> [a]
catMaybes -> [GlobalBindingTypeSig]
bindings) <- forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hsc TcGblEnv
gblEnv (RealSrcLoc -> RealSrcSpan
realSrcLocSpan forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"<dummy>" Int
1 Int
1) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
bindToSig [IdP GhcTc]
binds
[GlobalBindingTypeSig]
patterns <- forall a. [Maybe a] -> [a]
catMaybes 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 PatSyn -> IO (Maybe GlobalBindingTypeSig)
patToSig [PatSyn]
patSyns
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GlobalBindingTypeSig] -> GlobalBindingTypeSigsResult
GlobalBindingTypeSigsResult forall a b. (a -> b) -> a -> b
$ [GlobalBindingTypeSig]
bindings forall a. Semigroup a => a -> a -> a
<> [GlobalBindingTypeSig]
patterns
gblBindingType Maybe HscEnv
_ Maybe TcGblEnv
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
pprPatSynTypeWithoutForalls :: PatSyn -> SDoc
pprPatSynTypeWithoutForalls :: PatSyn -> SDoc
pprPatSynTypeWithoutForalls PatSyn
p = PatSyn -> SDoc
pprPatSynType PatSyn
pWithoutTypeVariables
where
pWithoutTypeVariables :: PatSyn
pWithoutTypeVariables = Name
-> Bool
-> ([InvisTVBinder], ThetaType)
-> ([InvisTVBinder], ThetaType)
-> ThetaType
-> Type
-> PatSynMatcher
-> PatSynBuilder
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
name Bool
declared_infix ([], ThetaType
req_theta) ([], ThetaType
prov_theta) ThetaType
orig_args' Type
orig_res_ty PatSynMatcher
matcher PatSynBuilder
builder [FieldLabel]
field_labels
([Id]
_univ_tvs, ThetaType
req_theta, [Id]
_ex_tvs, ThetaType
prov_theta, [Scaled Type]
orig_args, Type
orig_res_ty) = PatSyn -> ([Id], ThetaType, [Id], ThetaType, [Scaled Type], Type)
patSynSig PatSyn
p
name :: Name
name = PatSyn -> Name
patSynName PatSyn
p
declared_infix :: Bool
declared_infix = PatSyn -> Bool
patSynIsInfix PatSyn
p
matcher :: PatSynMatcher
matcher = PatSyn -> PatSynMatcher
patSynMatcher PatSyn
p
builder :: PatSynBuilder
builder = PatSyn -> PatSynBuilder
patSynBuilder PatSyn
p
field_labels :: [FieldLabel]
field_labels = PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
p
orig_args' :: ThetaType
orig_args' = forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
orig_args