{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies     #-}

-- | An HLS plugin to provide code lenses for type signatures
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)
import           Development.IDE.Core.Compile        (TcModuleResult (..))
import           Development.IDE.Core.RuleTypes      (GetBindings (GetBindings),
                                                      TypeCheck (TypeCheck))
import           Development.IDE.Core.Rules          (IdeState, runAction)
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,
                                                      usePropertyLsp)
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
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
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 :: Log -> Doc ann
pretty = \case
    LogShake Log
log -> Log -> Doc ann
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 =
  (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
    { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentCodeLens
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeLens
STextDocumentCodeLens PluginMethodHandler IdeState 'TextDocumentCodeLens
IdeState
-> PluginId
-> CodeLensParams
-> LspM Config (Either ResponseError (List CodeLens))
codeLensProvider
    , pluginCommands :: [PluginCommand IdeState]
pluginCommands = [CommandId
-> Text
-> CommandFunction IdeState WorkspaceEdit
-> PluginCommand IdeState
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 = Properties '[ 'PropertyKey "mode" ('TEnum Mode)] -> CustomConfig
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
  Properties '[]
-> (Properties '[]
    -> Properties '[ 'PropertyKey "mode" ('TEnum Mode)])
-> Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "mode"
-> Text
-> [(Mode, Text)]
-> Mode
-> Properties '[]
-> Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
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 IsLabel "mode" (KeyNameProxy "mode")
KeyNameProxy "mode"
#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 <- KeyNameProxy "mode"
-> PluginId
-> Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
-> LspT Config IO (ToHsType ('TEnum Mode))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]) (m :: * -> *).
(HasProperty s k t r, MonadLsp Config m) =>
KeyNameProxy s -> PluginId -> Properties r -> m (ToHsType t)
usePropertyLsp IsLabel "mode" (KeyNameProxy "mode")
KeyNameProxy "mode"
#mode PluginId
pId Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
properties
  ([CodeLens] -> Either ResponseError (List CodeLens))
-> LspT Config IO [CodeLens]
-> LspM Config (Either ResponseError (List CodeLens))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> ([CodeLens] -> List CodeLens)
-> [CodeLens]
-> Either ResponseError (List CodeLens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CodeLens] -> List CodeLens
forall a. [a] -> List a
List) (LspT Config IO [CodeLens]
 -> LspM Config (Either ResponseError (List CodeLens)))
-> LspT Config IO [CodeLens]
-> LspM Config (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ case Uri -> Maybe String
uriToFilePath' Uri
uri of
    Just (String -> NormalizedFilePath
toNormalizedFilePath' -> NormalizedFilePath
filePath) -> IO [CodeLens] -> LspT Config IO [CodeLens]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CodeLens] -> LspT Config IO [CodeLens])
-> IO [CodeLens] -> LspT Config IO [CodeLens]
forall a b. (a -> b) -> a -> b
$ do
      Maybe HscEnv
env <- (HscEnvEq -> HscEnv) -> Maybe HscEnvEq -> Maybe HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnvEq -> HscEnv
hscEnv (Maybe HscEnvEq -> Maybe HscEnv)
-> IO (Maybe HscEnvEq) -> IO (Maybe HscEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> IdeState -> Action (Maybe HscEnvEq) -> IO (Maybe HscEnvEq)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.GhcSession" IdeState
ideState (GhcSession -> NormalizedFilePath -> Action (Maybe HscEnvEq)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
filePath)
      Maybe TcModuleResult
tmr <- String
-> IdeState
-> Action (Maybe TcModuleResult)
-> IO (Maybe TcModuleResult)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.TypeCheck" IdeState
ideState (TypeCheck -> NormalizedFilePath -> Action (Maybe TcModuleResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
filePath)
      Maybe Bindings
bindings <- String
-> IdeState -> Action (Maybe Bindings) -> IO (Maybe Bindings)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.GetBindings" IdeState
ideState (GetBindings -> NormalizedFilePath -> Action (Maybe Bindings)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetBindings
GetBindings NormalizedFilePath
filePath)
      Maybe GlobalBindingTypeSigsResult
gblSigs <- String
-> IdeState
-> Action (Maybe GlobalBindingTypeSigsResult)
-> IO (Maybe GlobalBindingTypeSigsResult)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.GetGlobalBindingTypeSigs" IdeState
ideState (GetGlobalBindingTypeSigs
-> NormalizedFilePath -> Action (Maybe GlobalBindingTypeSigsResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs NormalizedFilePath
filePath)

      [FileDiagnostic]
diag <- STM [FileDiagnostic] -> IO [FileDiagnostic]
forall a. STM a -> IO a
atomically (STM [FileDiagnostic] -> IO [FileDiagnostic])
-> STM [FileDiagnostic] -> IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ IdeState -> STM [FileDiagnostic]
getDiagnostics IdeState
ideState
      [FileDiagnostic]
hDiag <- STM [FileDiagnostic] -> IO [FileDiagnostic]
forall a. STM a -> IO a
atomically (STM [FileDiagnostic] -> IO [FileDiagnostic])
-> STM [FileDiagnostic] -> IO [FileDiagnostic]
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 (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (WorkspaceEditMap -> Maybe WorkspaceEditMap)
-> WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a b. (a -> b) -> a -> b
$ Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Uri
uri (List TextEdit -> WorkspaceEditMap)
-> List TextEdit -> WorkspaceEditMap
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> List TextEdit
forall a. [a] -> List a
List [TextEdit]
tedit) Maybe (List DocumentChange)
forall a. Maybe a
Nothing Maybe ChangeAnnotationMap
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 (SrcSpan -> Maybe Range) -> SrcSpan -> Maybe Range
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]
            CodeLens -> Maybe CodeLens
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeLens -> Maybe CodeLens) -> CodeLens -> Maybe CodeLens
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' = [GlobalBindingTypeSig]
-> (GlobalBindingTypeSigsResult -> [GlobalBindingTypeSig])
-> Maybe GlobalBindingTypeSigsResult
-> [GlobalBindingTypeSig]
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 =
            [IO CodeLens] -> IO [CodeLens]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              [ CodeLens -> IO CodeLens
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeLens -> IO CodeLens) -> CodeLens -> IO CodeLens
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 [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
hDiag
              , NormalizedFilePath
dFile NormalizedFilePath -> NormalizedFilePath -> Bool
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 ->
          [CodeLens] -> IO [CodeLens]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Maybe CodeLens] -> [CodeLens]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CodeLens] -> [CodeLens]) -> [Maybe CodeLens] -> [CodeLens]
forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> Maybe CodeLens
generateLensForGlobal (GlobalBindingTypeSig -> Maybe CodeLens)
-> [GlobalBindingTypeSig] -> [Maybe CodeLens]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GlobalBindingTypeSig]
gblSigs')
            IO [CodeLens] -> IO [CodeLens] -> IO [CodeLens]
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) -- we still need diagnostics for local bindings
        Mode
Exported -> [CodeLens] -> IO [CodeLens]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CodeLens] -> IO [CodeLens]) -> [CodeLens] -> IO [CodeLens]
forall a b. (a -> b) -> a -> b
$ [Maybe CodeLens] -> [CodeLens]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CodeLens] -> [CodeLens]) -> [Maybe CodeLens] -> [CodeLens]
forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> Maybe CodeLens
generateLensForGlobal (GlobalBindingTypeSig -> Maybe CodeLens)
-> [GlobalBindingTypeSig] -> [Maybe CodeLens]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GlobalBindingTypeSig -> Bool)
-> [GlobalBindingTypeSig] -> [GlobalBindingTypeSig]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalBindingTypeSig -> Bool
gbExported [GlobalBindingTypeSig]
gblSigs'
        Mode
Diagnostics -> (Diagnostic -> [(Text, [TextEdit])]) -> IO [CodeLens]
generateLensFromDiags ((Diagnostic -> [(Text, [TextEdit])]) -> IO [CodeLens])
-> (Diagnostic -> [(Text, [TextEdit])]) -> IO [CodeLens]
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 -> [CodeLens] -> LspT Config IO [CodeLens]
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 ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [WorkspaceEdit -> Value
forall a. ToJSON a => a -> Value
toJSON WorkspaceEdit
edit])
   in Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
_range (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cId) Maybe Value
forall a. Maybe a
Nothing

commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler IdeState
_ideState WorkspaceEdit
wedit = do
  LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (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 SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
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 [(Text, [TextEdit])]
-> [(Text, [TextEdit])] -> [(Text, [TextEdit])]
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
      Text -> Text -> Bool
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 <- (GlobalBindingTypeSig -> Bool)
-> [GlobalBindingTypeSig] -> Maybe GlobalBindingTypeSig
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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> String
gbRendered GlobalBindingTypeSig
sig
    , Text
title <- if Bool
isQuickFix then Text
"add signature: " Text -> Text -> Text
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 ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
_message)
        Text -> Text -> Maybe (Text, Text, Text, [Text])
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
    , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name
      Just (Name
name, Type
ty) <- ((Name, Maybe Type) -> Bool)
-> [(Name, Maybe Type)] -> Maybe (Name, Maybe Type)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Name
x, Maybe Type
_) -> Name -> String
printName Name
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> String
T.unpack Text
identifier) [(Name, Maybe Type)]
localScope Maybe (Name, Maybe Type)
-> ((Name, Maybe Type) -> Maybe (Name, Type)) -> Maybe (Name, Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Name
name, Maybe Type
mTy) -> (Name
name,) (Type -> (Name, Type)) -> Maybe Type -> Maybe (Name, Type)
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
    , -- not a top-level thing, to avoid duplication
      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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) (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
pprSigmaType Type
ty
    , Text
signature <- String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
printName Name
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
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: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signature else Text
signature
    , TextEdit
action <- Range -> Text -> TextEdit
TextEdit Range
beforeLine (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ Text
signature Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (UInt -> Int
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 (Range -> Position) -> Maybe Range -> Maybe Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
s1) Maybe Position -> Maybe Position -> Bool
forall a. Eq a => a -> a -> Bool
== (Range -> Position
_start (Range -> Position) -> Maybe Range -> Maybe Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Maybe Range
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 (SrcSpan -> Maybe Range) -> SrcSpan -> Maybe Range
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan
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 =
    TextEdit -> Maybe TextEdit
forall a. a -> Maybe a
Just (TextEdit -> Maybe TextEdit) -> TextEdit -> Maybe TextEdit
forall a b. (a -> b) -> a -> b
$ Range -> Text -> TextEdit
TextEdit Range
beforeLine (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
gbRendered Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  | Bool
otherwise = Maybe TextEdit
forall a. Maybe a
Nothing

data Mode
  = -- | always displays type lenses of global bindings, no matter what GHC flags are set
    Always
  | -- | similar to 'Always', but only displays for exported global bindings
    Exported
  | -- |  follows error messages produced by GHC
    Diagnostics
  deriving (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
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
Eq Mode
-> (Mode -> Mode -> Ordering)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Mode)
-> (Mode -> Mode -> Mode)
-> Ord 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
$cp1Ord :: Eq Mode
Ord, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
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]
(Int -> ReadS Mode)
-> ReadS [Mode] -> ReadPrec Mode -> ReadPrec [Mode] -> Read 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]
(Mode -> Mode)
-> (Mode -> Mode)
-> (Int -> Mode)
-> (Mode -> Int)
-> (Mode -> [Mode])
-> (Mode -> Mode -> [Mode])
-> (Mode -> Mode -> [Mode])
-> (Mode -> Mode -> Mode -> [Mode])
-> Enum 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 = String -> (Text -> Parser Mode) -> Value -> Parser Mode
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Mode" ((Text -> Parser Mode) -> Value -> Parser Mode)
-> (Text -> Parser Mode) -> Value -> Parser Mode
forall a b. (a -> b) -> a -> b
$ \case
    Text
"always"      -> Mode -> Parser Mode
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Always
    Text
"exported"    -> Mode -> Parser Mode
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Exported
    Text
"diagnostics" -> Mode -> Parser Mode
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Diagnostics
    Text
_             -> Parser Mode
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.
 GetGlobalBindingTypeSigs -> Rep GetGlobalBindingTypeSigs x)
-> (forall x.
    Rep GetGlobalBindingTypeSigs x -> GetGlobalBindingTypeSigs)
-> Generic GetGlobalBindingTypeSigs
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
(Int -> GetGlobalBindingTypeSigs -> ShowS)
-> (GetGlobalBindingTypeSigs -> String)
-> ([GetGlobalBindingTypeSigs] -> ShowS)
-> Show GetGlobalBindingTypeSigs
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
(GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> (GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> Eq GetGlobalBindingTypeSigs
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
Eq GetGlobalBindingTypeSigs
-> (GetGlobalBindingTypeSigs
    -> GetGlobalBindingTypeSigs -> Ordering)
-> (GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> (GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> (GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> (GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> (GetGlobalBindingTypeSigs
    -> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs)
-> (GetGlobalBindingTypeSigs
    -> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs)
-> Ord 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
$cp1Ord :: Eq GetGlobalBindingTypeSigs
Ord, Eq GetGlobalBindingTypeSigs
Eq GetGlobalBindingTypeSigs
-> (Int -> GetGlobalBindingTypeSigs -> Int)
-> (GetGlobalBindingTypeSigs -> Int)
-> Hashable 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
$cp1Hashable :: Eq GetGlobalBindingTypeSigs
Hashable, GetGlobalBindingTypeSigs -> ()
(GetGlobalBindingTypeSigs -> ()) -> NFData 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} = Name -> SrcSpan
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 = GlobalBindingTypeSigsResult -> ()
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
  Recorder (WithPriority Log)
-> (GetGlobalBindingTypeSigs
    -> NormalizedFilePath
    -> Action (IdeResult GlobalBindingTypeSigsResult))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((GetGlobalBindingTypeSigs
  -> NormalizedFilePath
  -> Action (IdeResult GlobalBindingTypeSigsResult))
 -> Rules ())
-> (GetGlobalBindingTypeSigs
    -> NormalizedFilePath
    -> Action (IdeResult GlobalBindingTypeSigsResult))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs NormalizedFilePath
nfp -> do
    Maybe TcModuleResult
tmr <- TypeCheck -> NormalizedFilePath -> Action (Maybe TcModuleResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp
    -- we need session here for tidying types
    Maybe HscEnvEq
hsc <- GhcSession -> NormalizedFilePath -> Action (Maybe HscEnvEq)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
nfp
    Maybe GlobalBindingTypeSigsResult
result <- IO (Maybe GlobalBindingTypeSigsResult)
-> Action (Maybe GlobalBindingTypeSigsResult)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe GlobalBindingTypeSigsResult)
 -> Action (Maybe GlobalBindingTypeSigsResult))
-> IO (Maybe GlobalBindingTypeSigsResult)
-> Action (Maybe GlobalBindingTypeSigsResult)
forall a b. (a -> b) -> a -> b
$ Maybe HscEnv
-> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
gblBindingType (HscEnvEq -> HscEnv
hscEnv (HscEnvEq -> HscEnv) -> Maybe HscEnvEq -> Maybe HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HscEnvEq
hsc) (TcModuleResult -> TcGblEnv
tmrTypechecked (TcModuleResult -> TcGblEnv)
-> Maybe TcModuleResult -> Maybe TcGblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TcModuleResult
tmr)
    IdeResult GlobalBindingTypeSigsResult
-> Action (IdeResult GlobalBindingTypeSigsResult)
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 ([AvailInfo] -> NameSet) -> [AvailInfo] -> NameSet
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
gblEnv
      sigs :: NameSet
sigs = TcGblEnv -> NameSet
tcg_sigs TcGblEnv
gblEnv
      binds :: [IdP (GhcPass 'Typechecked)]
binds = LHsBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> [IdP (GhcPass 'Typechecked)]
forall (p :: Pass) idR.
LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
collectHsBindsBinders (LHsBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
 -> [IdP (GhcPass 'Typechecked)])
-> LHsBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> [IdP (GhcPass 'Typechecked)]
forall a b. (a -> b) -> a -> b
$ TcGblEnv
-> LHsBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
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 :: Name -> m a -> m (Maybe a)
hasSig Name
name m a
f = Bool -> m a -> m (Maybe a)
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
        Name
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
forall (m :: * -> *) a. Monad m => Name -> m a -> m (Maybe a)
hasSig Name
name (IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig))
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
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)
          GlobalBindingTypeSig
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalBindingTypeSig
 -> IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig)
-> GlobalBindingTypeSig
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig
forall a b. (a -> b) -> a -> b
$ Name -> String -> Bool -> GlobalBindingTypeSig
GlobalBindingTypeSig Name
name (Name -> String
printName Name
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
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
        Name -> IO GlobalBindingTypeSig -> IO (Maybe GlobalBindingTypeSig)
forall (m :: * -> *) a. Monad m => Name -> m a -> m (Maybe a)
hasSig Name
name (IO GlobalBindingTypeSig -> IO (Maybe GlobalBindingTypeSig))
-> IO GlobalBindingTypeSig -> IO (Maybe GlobalBindingTypeSig)
forall a b. (a -> b) -> a -> b
$ GlobalBindingTypeSig -> IO GlobalBindingTypeSig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalBindingTypeSig -> IO GlobalBindingTypeSig)
-> GlobalBindingTypeSig -> IO GlobalBindingTypeSig
forall a b. (a -> b) -> a -> b
$ Name -> String -> Bool -> GlobalBindingTypeSig
GlobalBindingTypeSig Name
name (String
"pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
printName Name
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SDoc -> String
showDoc (PatSyn -> SDoc
pprPatSynTypeWithoutForalls PatSyn
p)) (Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
exports)
  (Messages
_, [GlobalBindingTypeSig]
-> ([Maybe GlobalBindingTypeSig] -> [GlobalBindingTypeSig])
-> Maybe [Maybe GlobalBindingTypeSig]
-> [GlobalBindingTypeSig]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Maybe GlobalBindingTypeSig] -> [GlobalBindingTypeSig]
forall a. [Maybe a] -> [a]
catMaybes -> [GlobalBindingTypeSig]
bindings) <- HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM [Maybe GlobalBindingTypeSig]
-> IO (Messages, Maybe [Maybe GlobalBindingTypeSig])
forall r.
HscEnv
-> TcGblEnv -> RealSrcSpan -> TcM r -> IO (Messages, Maybe r)
initTcWithGbl HscEnv
hsc TcGblEnv
gblEnv (RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"<dummy>" Int
1 Int
1) (TcM [Maybe GlobalBindingTypeSig]
 -> IO (Messages, Maybe [Maybe GlobalBindingTypeSig]))
-> TcM [Maybe GlobalBindingTypeSig]
-> IO (Messages, Maybe [Maybe GlobalBindingTypeSig])
forall a b. (a -> b) -> a -> b
$ (Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig))
-> [Id] -> TcM [Maybe GlobalBindingTypeSig]
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 (GhcPass 'Typechecked)]
[Id]
binds
  [GlobalBindingTypeSig]
patterns <- [Maybe GlobalBindingTypeSig] -> [GlobalBindingTypeSig]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe GlobalBindingTypeSig] -> [GlobalBindingTypeSig])
-> IO [Maybe GlobalBindingTypeSig] -> IO [GlobalBindingTypeSig]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PatSyn -> IO (Maybe GlobalBindingTypeSig))
-> [PatSyn] -> IO [Maybe GlobalBindingTypeSig]
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
  Maybe GlobalBindingTypeSigsResult
-> IO (Maybe GlobalBindingTypeSigsResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GlobalBindingTypeSigsResult
 -> IO (Maybe GlobalBindingTypeSigsResult))
-> ([GlobalBindingTypeSig] -> Maybe GlobalBindingTypeSigsResult)
-> [GlobalBindingTypeSig]
-> IO (Maybe GlobalBindingTypeSigsResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalBindingTypeSigsResult -> Maybe GlobalBindingTypeSigsResult
forall a. a -> Maybe a
Just (GlobalBindingTypeSigsResult -> Maybe GlobalBindingTypeSigsResult)
-> ([GlobalBindingTypeSig] -> GlobalBindingTypeSigsResult)
-> [GlobalBindingTypeSig]
-> Maybe GlobalBindingTypeSigsResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GlobalBindingTypeSig] -> GlobalBindingTypeSigsResult
GlobalBindingTypeSigsResult ([GlobalBindingTypeSig] -> IO (Maybe GlobalBindingTypeSigsResult))
-> [GlobalBindingTypeSig] -> IO (Maybe GlobalBindingTypeSigsResult)
forall a b. (a -> b) -> a -> b
$ [GlobalBindingTypeSig]
bindings [GlobalBindingTypeSig]
-> [GlobalBindingTypeSig] -> [GlobalBindingTypeSig]
forall a. Semigroup a => a -> a -> a
<> [GlobalBindingTypeSig]
patterns
gblBindingType Maybe HscEnv
_ Maybe TcGblEnv
_ = Maybe GlobalBindingTypeSigsResult
-> IO (Maybe GlobalBindingTypeSigsResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GlobalBindingTypeSigsResult
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
-> ([TyVarBinder], ThetaType)
-> ([TyVarBinder], ThetaType)
-> ThetaType
-> Type
-> (Id, Bool)
-> Maybe (Id, Bool)
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
name Bool
declared_infix ([], ThetaType
req_theta) ([], ThetaType
prov_theta) ThetaType
orig_args' Type
orig_res_ty (Id, Bool)
matcher Maybe (Id, Bool)
builder [FieldLabel]
field_labels
    ([Id]
_univ_tvs, ThetaType
req_theta, [Id]
_ex_tvs, ThetaType
prov_theta, ThetaType
orig_args, Type
orig_res_ty) = PatSyn -> ([Id], ThetaType, [Id], ThetaType, ThetaType, Type)
patSynSig PatSyn
p
    name :: Name
name = PatSyn -> Name
patSynName PatSyn
p
    declared_infix :: Bool
declared_infix = PatSyn -> Bool
patSynIsInfix PatSyn
p
    matcher :: (Id, Bool)
matcher = PatSyn -> (Id, Bool)
patSynMatcher PatSyn
p
    builder :: Maybe (Id, Bool)
builder = PatSyn -> Maybe (Id, Bool)
patSynBuilder PatSyn
p
    field_labels :: [FieldLabel]
field_labels = PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
p
    orig_args' :: ThetaType
orig_args' = (Type -> Type) -> ThetaType -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
forall a. Scaled a -> Scaled a
scaledThing ThetaType
orig_args