{-# 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.Lens                         ((?~))
import           Control.Monad                        (mzero)
import           Control.Monad.Extra                  (whenMaybe)
import           Control.Monad.IO.Class               (MonadIO (liftIO))
import           Control.Monad.Trans.Class            (MonadTrans (lift))
import           Data.Aeson.Types                     (toJSON)
import qualified Data.Aeson.Types                     as A
import           Data.List                            (find)
import qualified Data.Map                             as Map
import           Data.Maybe                           (catMaybes, maybeToList)
import qualified Data.Text                            as T
import           Development.IDE                      (GhcSession (..),
                                                       HscEnvEq (hscEnv),
                                                       RuleResult, Rules, Uri,
                                                       define, srcSpanToRange,
                                                       usePropertyAction)
import           Development.IDE.Core.Compile         (TcModuleResult (..))
import           Development.IDE.Core.PluginUtils
import           Development.IDE.Core.PositionMapping (PositionMapping,
                                                       fromCurrentRange,
                                                       toCurrentRange)
import           Development.IDE.Core.Rules           (IdeState, runAction)
import           Development.IDE.Core.RuleTypes       (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.Types.Location       (Position (Position, _line),
                                                       Range (Range, _end, _start))
import           GHC.Generics                         (Generic)
import           Ide.Logger                           (Pretty (pretty),
                                                       Recorder, WithPriority,
                                                       cmapWithPrio)
import           Ide.Plugin.Error
import           Ide.Plugin.Properties
import           Ide.PluginUtils                      (mkLspCommand)
import           Ide.Types                            (CommandFunction,
                                                       CommandId (CommandId),
                                                       PluginCommand (PluginCommand),
                                                       PluginDescriptor (..),
                                                       PluginId,
                                                       PluginMethodHandler,
                                                       ResolveFunction,
                                                       configCustomConfig,
                                                       defaultConfigDescriptor,
                                                       defaultPluginDescriptor,
                                                       mkCustomConfig,
                                                       mkPluginHandler,
                                                       mkResolveHandler,
                                                       pluginSendRequest)
import qualified Language.LSP.Protocol.Lens           as L
import           Language.LSP.Protocol.Message        (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens),
                                                       SMethod (..))
import           Language.LSP.Protocol.Types          (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
                                                       CodeLens (..),
                                                       CodeLensParams (CodeLensParams, _textDocument),
                                                       Command, Diagnostic (..),
                                                       Null (Null),
                                                       TextDocumentIdentifier (TextDocumentIdentifier),
                                                       TextEdit (TextEdit),
                                                       WorkspaceEdit (WorkspaceEdit),
                                                       type (|?) (..))
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
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg


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 -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc)
    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider
                    <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider
    , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
    , pluginRules = rules recorder
    , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
    }
  where
    desc :: Text
desc = Text
"Provides code lenses type signatures"

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 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 :: PluginMethodHandler IdeState Method_TextDocumentCodeLens
codeLensProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeLens
codeLensProvider IdeState
ideState PluginId
pId CodeLensParams{$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument = TextDocumentIdentifier Uri
uri} = do
    Mode
mode <- IO Mode -> ExceptT PluginError (HandlerM Config) Mode
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mode -> ExceptT PluginError (HandlerM Config) Mode)
-> IO Mode -> ExceptT PluginError (HandlerM Config) Mode
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action Mode -> IO Mode
forall a. String -> IdeState -> Action a -> IO a
runAction String
"codeLens.config" IdeState
ideState (Action Mode -> IO Mode) -> Action Mode -> IO Mode
forall a b. (a -> b) -> a -> b
$ KeyNameProxy "mode"
-> PluginId
-> Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
-> Action
     (ToHsType
        (FindByKeyName "mode" '[ 'PropertyKey "mode" ('TEnum Mode)]))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy "mode"
#mode PluginId
pId Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
properties
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (HandlerM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    -- We have two ways we can possibly generate code lenses for type lenses.
    -- Different options are with different "modes" of the type-lenses plugin.
    -- (Remember here, as the code lens is not resolved yet, we only really need
    -- the range and any data that will help us resolve it later)
    let -- The first option is to generate lens from diagnostics about
        -- top level bindings.
        generateLensFromGlobalDiags :: [FileDiagnostic] -> [CodeLens]
generateLensFromGlobalDiags [FileDiagnostic]
diags =
          -- We don't actually pass any data to resolve, however we need this
          -- dummy type to make sure HLS resolves our lens
          [ Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
_range Maybe Command
forall a. Maybe a
Nothing (Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ TypeLensesResolve -> Value
forall a. ToJSON a => a -> Value
toJSON TypeLensesResolve
TypeLensesResolve)
            | (NormalizedFilePath
dFile, ShowDiagnostic
_, diag :: Diagnostic
diag@Diagnostic{Range
_range :: Range
$sel:_range:Diagnostic :: Diagnostic -> Range
_range}) <- [FileDiagnostic]
diags
            , NormalizedFilePath
dFile NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
nfp
            , Diagnostic -> Bool
isGlobalDiagnostic Diagnostic
diag]
        -- The second option is to generate lenses from the GlobalBindingTypeSig
        -- rule. This is the only type that needs to have the range adjusted
        -- with PositionMapping.
        -- PositionMapping for diagnostics doesn't make sense, because we always
        -- have fresh diagnostics even if current module parsed failed (the
        -- diagnostic would then be parse failed). See
        -- https://github.com/haskell/haskell-language-server/pull/3558 for this
        -- discussion.
        generateLensFromGlobal :: [GlobalBindingTypeSig] -> PositionMapping -> [CodeLens]
generateLensFromGlobal [GlobalBindingTypeSig]
sigs PositionMapping
mp = do
          [ Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
newRange Maybe Command
forall a. Maybe a
Nothing (Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ TypeLensesResolve -> Value
forall a. ToJSON a => a -> Value
toJSON TypeLensesResolve
TypeLensesResolve)
            | GlobalBindingTypeSig
sig <- [GlobalBindingTypeSig]
sigs
            , Just Range
range <- [SrcSpan -> Maybe Range
srcSpanToRange (GlobalBindingTypeSig -> SrcSpan
gbSrcSpan GlobalBindingTypeSig
sig)]
            , Just Range
newRange <- [PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mp Range
range]]
    if Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Always Bool -> Bool -> Bool
|| Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Exported
      then do
        -- In this mode we get the global bindings from the
        -- GlobalBindingTypeSigs rule.
        (GlobalBindingTypeSigsResult [GlobalBindingTypeSig]
gblSigs, PositionMapping
gblSigsMp) <-
          String
-> IdeState
-> ExceptT
     PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
-> ExceptT
     PluginError
     (HandlerM Config)
     (GlobalBindingTypeSigsResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"codeLens.GetGlobalBindingTypeSigs" IdeState
ideState
          (ExceptT
   PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
 -> ExceptT
      PluginError
      (HandlerM Config)
      (GlobalBindingTypeSigsResult, PositionMapping))
-> ExceptT
     PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
-> ExceptT
     PluginError
     (HandlerM Config)
     (GlobalBindingTypeSigsResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetGlobalBindingTypeSigs
-> NormalizedFilePath
-> ExceptT
     PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs NormalizedFilePath
nfp
        -- Depending on whether we only want exported or not we filter our list
        -- of signatures to get what we want
        let relevantGlobalSigs :: [GlobalBindingTypeSig]
relevantGlobalSigs =
              if Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Exported
                then (GlobalBindingTypeSig -> Bool)
-> [GlobalBindingTypeSig] -> [GlobalBindingTypeSig]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalBindingTypeSig -> Bool
gbExported [GlobalBindingTypeSig]
gblSigs
                else [GlobalBindingTypeSig]
gblSigs
        ([CodeLens] |? Null)
-> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CodeLens] |? Null)
 -> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null))
-> ([CodeLens] |? Null)
-> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> [CodeLens] |? Null
forall a b. a -> a |? b
InL ([CodeLens] -> [CodeLens] |? Null)
-> [CodeLens] -> [CodeLens] |? Null
forall a b. (a -> b) -> a -> b
$ [GlobalBindingTypeSig] -> PositionMapping -> [CodeLens]
generateLensFromGlobal [GlobalBindingTypeSig]
relevantGlobalSigs PositionMapping
gblSigsMp
      else do
        -- For this mode we exclusively use diagnostics to create the lenses.
        -- However we will still use the GlobalBindingTypeSigs to resolve them.
        [FileDiagnostic]
diags <- IO [FileDiagnostic]
-> ExceptT PluginError (HandlerM Config) [FileDiagnostic]
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FileDiagnostic]
 -> ExceptT PluginError (HandlerM Config) [FileDiagnostic])
-> IO [FileDiagnostic]
-> ExceptT PluginError (HandlerM Config) [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ 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]
hDiags <- IO [FileDiagnostic]
-> ExceptT PluginError (HandlerM Config) [FileDiagnostic]
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FileDiagnostic]
 -> ExceptT PluginError (HandlerM Config) [FileDiagnostic])
-> IO [FileDiagnostic]
-> ExceptT PluginError (HandlerM Config) [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ 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 allDiags :: [FileDiagnostic]
allDiags = [FileDiagnostic]
diags [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
hDiags
        ([CodeLens] |? Null)
-> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CodeLens] |? Null)
 -> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null))
-> ([CodeLens] |? Null)
-> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> [CodeLens] |? Null
forall a b. a -> a |? b
InL ([CodeLens] -> [CodeLens] |? Null)
-> [CodeLens] -> [CodeLens] |? Null
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> [CodeLens]
generateLensFromGlobalDiags [FileDiagnostic]
allDiags

codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve
codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve 'Method_CodeLensResolve
codeLensResolveProvider IdeState
ideState PluginId
pId lens :: MessageParams 'Method_CodeLensResolve
lens@CodeLens{Range
_range :: Range
$sel:_range:CodeLens :: CodeLens -> Range
_range} Uri
uri TypeLensesResolve
TypeLensesResolve = do
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (HandlerM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  (gblSigs :: GlobalBindingTypeSigsResult
gblSigs@(GlobalBindingTypeSigsResult [GlobalBindingTypeSig]
_), PositionMapping
pm) <-
    String
-> IdeState
-> ExceptT
     PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
-> ExceptT
     PluginError
     (HandlerM Config)
     (GlobalBindingTypeSigsResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"codeLens.GetGlobalBindingTypeSigs" IdeState
ideState
    (ExceptT
   PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
 -> ExceptT
      PluginError
      (HandlerM Config)
      (GlobalBindingTypeSigsResult, PositionMapping))
-> ExceptT
     PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
-> ExceptT
     PluginError
     (HandlerM Config)
     (GlobalBindingTypeSigsResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetGlobalBindingTypeSigs
-> NormalizedFilePath
-> ExceptT
     PluginError Action (GlobalBindingTypeSigsResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetGlobalBindingTypeSigs
GetGlobalBindingTypeSigs NormalizedFilePath
nfp
  -- regardless of how the original lens was generated, we want to get the range
  -- that the global bindings rule would expect here, hence the need to reverse
  -- position map the range, regardless of whether it was position mapped in the
  -- beginning or freshly taken from diagnostics.
  Range
newRange <- PluginError
-> Maybe Range -> ExceptT PluginError (HandlerM Config) Range
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve (PositionMapping -> Range -> Maybe Range
fromCurrentRange PositionMapping
pm Range
_range)
  -- We also pass on the PositionMapping so that the generated text edit can
  -- have the range adjusted.
  (Text
title, TextEdit
edit) <-
        PluginError
-> Maybe (Text, TextEdit)
-> ExceptT PluginError (HandlerM Config) (Text, TextEdit)
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve (Maybe (Text, TextEdit)
 -> ExceptT PluginError (HandlerM Config) (Text, TextEdit))
-> Maybe (Text, TextEdit)
-> ExceptT PluginError (HandlerM Config) (Text, TextEdit)
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe GlobalBindingTypeSigsResult
-> Maybe PositionMapping
-> Range
-> Maybe (Text, TextEdit)
suggestGlobalSignature' Bool
False (GlobalBindingTypeSigsResult -> Maybe GlobalBindingTypeSigsResult
forall a. a -> Maybe a
Just GlobalBindingTypeSigsResult
gblSigs) (PositionMapping -> Maybe PositionMapping
forall a. a -> Maybe a
Just PositionMapping
pm) Range
newRange
  CodeLens -> ExceptT PluginError (HandlerM Config) CodeLens
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeLens -> ExceptT PluginError (HandlerM Config) CodeLens)
-> CodeLens -> ExceptT PluginError (HandlerM Config) CodeLens
forall a b. (a -> b) -> a -> b
$ CodeLens
MessageParams 'Method_CodeLensResolve
lens CodeLens -> (CodeLens -> CodeLens) -> CodeLens
forall a b. a -> (a -> b) -> b
& (Maybe Command -> Identity (Maybe Command))
-> CodeLens -> Identity CodeLens
forall s a. HasCommand s a => Lens' s a
Lens' CodeLens (Maybe Command)
L.command ((Maybe Command -> Identity (Maybe Command))
 -> CodeLens -> Identity CodeLens)
-> Command -> CodeLens -> CodeLens
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ PluginId -> Uri -> Text -> TextEdit -> Command
generateLensCommand PluginId
pId Uri
uri Text
title TextEdit
edit

generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command
generateLensCommand :: PluginId -> Uri -> Text -> TextEdit -> Command
generateLensCommand PluginId
pId Uri
uri Text
title TextEdit
edit =
  let wEdit :: WorkspaceEdit
wEdit = Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit]))
-> Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> a -> b
$ Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
Map.singleton Uri
uri [TextEdit
edit]) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
  in 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
wEdit])

-- Since the lenses are created with diagnostics, and since the globalTypeSig
-- rule can't be changed as it is also used by the hls-refactor plugin, we can't
-- rely on actions. Because we can't rely on actions it doesn't make sense to
-- recompute the edit upon command. Hence the command here just takes a edit
-- and applies it.
commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler IdeState
_ideState Maybe ProgressToken
_ WorkspaceEdit
wedit = do
  LspId 'Method_WorkspaceApplyEdit
_ <- HandlerM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (HandlerM Config) (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HandlerM Config (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT
      PluginError (HandlerM Config) (LspId 'Method_WorkspaceApplyEdit))
-> HandlerM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     PluginError (HandlerM Config) (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either
      (TResponseError 'Method_WorkspaceApplyEdit)
      (MessageResult 'Method_WorkspaceApplyEdit)
    -> HandlerM Config ())
-> HandlerM Config (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) config.
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m)
    -> HandlerM config ())
-> HandlerM config (LspId m)
pluginSendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either
  (TResponseError 'Method_WorkspaceApplyEdit)
  (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> HandlerM Config ()
forall a. a -> HandlerM Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  (Value |? Null)
-> ExceptT PluginError (HandlerM Config) (Value |? Null)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null)
 -> ExceptT PluginError (HandlerM Config) (Value |? Null))
-> (Value |? Null)
-> ExceptT PluginError (HandlerM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null

--------------------------------------------------------------------------------
suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)]
suggestSignature :: Bool
-> Maybe GlobalBindingTypeSigsResult
-> Diagnostic
-> [(Text, TextEdit)]
suggestSignature Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs Diagnostic
diag =
  Maybe (Text, TextEdit) -> [(Text, TextEdit)]
forall a. Maybe a -> [a]
maybeToList (Bool
-> Maybe GlobalBindingTypeSigsResult
-> Diagnostic
-> Maybe (Text, TextEdit)
suggestGlobalSignature Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs Diagnostic
diag)

-- The suggestGlobalSignature is separated into two functions. The main function
-- works with a diagnostic, which then calls the secondary function with
-- whatever pieces of the diagnostic it needs. This allows the resolve function,
-- which no longer has the Diagnostic, to still call the secondary functions.
suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit)
suggestGlobalSignature :: Bool
-> Maybe GlobalBindingTypeSigsResult
-> Diagnostic
-> Maybe (Text, TextEdit)
suggestGlobalSignature Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs diag :: Diagnostic
diag@Diagnostic{Range
$sel:_range:Diagnostic :: Diagnostic -> Range
_range :: Range
_range}
  | Diagnostic -> Bool
isGlobalDiagnostic Diagnostic
diag =
    Bool
-> Maybe GlobalBindingTypeSigsResult
-> Maybe PositionMapping
-> Range
-> Maybe (Text, TextEdit)
suggestGlobalSignature' Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs Maybe PositionMapping
forall a. Maybe a
Nothing Range
_range
  | Bool
otherwise = Maybe (Text, TextEdit)
forall a. Maybe a
Nothing

isGlobalDiagnostic :: Diagnostic -> Bool
isGlobalDiagnostic :: Diagnostic -> Bool
isGlobalDiagnostic Diagnostic{Text
_message :: Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message} = 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)

-- If a PositionMapping is supplied, this function will call
-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location.
suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit)
suggestGlobalSignature' :: Bool
-> Maybe GlobalBindingTypeSigsResult
-> Maybe PositionMapping
-> Range
-> Maybe (Text, TextEdit)
suggestGlobalSignature' Bool
isQuickFix Maybe GlobalBindingTypeSigsResult
mGblSigs Maybe PositionMapping
pm Range
range
  |   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 PositionMapping -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig
sig Maybe PositionMapping
pm =
    (Text, TextEdit) -> Maybe (Text, TextEdit)
forall a. a -> Maybe a
Just (Text
title, TextEdit
action)
  | Bool
otherwise = Maybe (Text, TextEdit)
forall a. Maybe a
Nothing

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 PositionMapping -> Maybe TextEdit
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe PositionMapping -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig{Bool
String
Name
gbExported :: GlobalBindingTypeSig -> Bool
gbRendered :: GlobalBindingTypeSig -> String
gbName :: Name
gbRendered :: String
gbExported :: Bool
gbName :: GlobalBindingTypeSig -> Name
..} Maybe PositionMapping
mmp
  | Just Range{Position
$sel:_end:Range :: Range -> Position
$sel:_start:Range :: Range -> Position
_start :: Position
_end :: 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
    -- If `mmp` is `Nothing`, return the original range,
    -- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed.
    , Just Range
range <- Maybe Range
-> (PositionMapping -> Maybe Range)
-> Maybe PositionMapping
-> Maybe Range
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
beforeLine) ((PositionMapping -> Range -> Maybe Range)
-> Range -> PositionMapping -> Maybe Range
forall a b c. (a -> b -> c) -> b -> a -> c
flip PositionMapping -> Range -> Maybe Range
toCurrentRange Range
beforeLine) Maybe PositionMapping
mmp
    -- We need to flatten the signature, as otherwise long signatures are
    -- rendered on multiple lines with invalid formatting.
    , String
renderedFlat <- [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
gbRendered
    = 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
range (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
renderedFlat Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  | Bool
otherwise = Maybe TextEdit
forall a. Maybe a
Nothing

-- |We don't need anything to resolve our lens, but a data field is mandatory
-- to get types resolved in HLS
data TypeLensesResolve = TypeLensesResolve
  deriving ((forall x. TypeLensesResolve -> Rep TypeLensesResolve x)
-> (forall x. Rep TypeLensesResolve x -> TypeLensesResolve)
-> Generic TypeLensesResolve
forall x. Rep TypeLensesResolve x -> TypeLensesResolve
forall x. TypeLensesResolve -> Rep TypeLensesResolve x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TypeLensesResolve -> Rep TypeLensesResolve x
from :: forall x. TypeLensesResolve -> Rep TypeLensesResolve x
$cto :: forall x. Rep TypeLensesResolve x -> TypeLensesResolve
to :: forall x. Rep TypeLensesResolve x -> TypeLensesResolve
Generic, Maybe TypeLensesResolve
Value -> Parser [TypeLensesResolve]
Value -> Parser TypeLensesResolve
(Value -> Parser TypeLensesResolve)
-> (Value -> Parser [TypeLensesResolve])
-> Maybe TypeLensesResolve
-> FromJSON TypeLensesResolve
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser TypeLensesResolve
parseJSON :: Value -> Parser TypeLensesResolve
$cparseJSONList :: Value -> Parser [TypeLensesResolve]
parseJSONList :: Value -> Parser [TypeLensesResolve]
$comittedField :: Maybe TypeLensesResolve
omittedField :: Maybe TypeLensesResolve
A.FromJSON, [TypeLensesResolve] -> Value
[TypeLensesResolve] -> Encoding
TypeLensesResolve -> Bool
TypeLensesResolve -> Value
TypeLensesResolve -> Encoding
(TypeLensesResolve -> Value)
-> (TypeLensesResolve -> Encoding)
-> ([TypeLensesResolve] -> Value)
-> ([TypeLensesResolve] -> Encoding)
-> (TypeLensesResolve -> Bool)
-> ToJSON TypeLensesResolve
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: TypeLensesResolve -> Value
toJSON :: TypeLensesResolve -> Value
$ctoEncoding :: TypeLensesResolve -> Encoding
toEncoding :: TypeLensesResolve -> Encoding
$ctoJSONList :: [TypeLensesResolve] -> Value
toJSONList :: [TypeLensesResolve] -> Value
$ctoEncodingList :: [TypeLensesResolve] -> Encoding
toEncodingList :: [TypeLensesResolve] -> Encoding
$comitField :: TypeLensesResolve -> Bool
omitField :: TypeLensesResolve -> Bool
A.ToJSON)

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
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: 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
$ccompare :: Mode -> Mode -> Ordering
compare :: Mode -> Mode -> Ordering
$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
>= :: Mode -> Mode -> Bool
$cmax :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
min :: Mode -> Mode -> 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
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS Mode
readsPrec :: Int -> ReadS Mode
$creadList :: ReadS [Mode]
readList :: ReadS [Mode]
$creadPrec :: ReadPrec Mode
readPrec :: ReadPrec Mode
$creadListPrec :: ReadPrec [Mode]
readListPrec :: ReadPrec [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
$csucc :: Mode -> Mode
succ :: Mode -> Mode
$cpred :: Mode -> Mode
pred :: Mode -> Mode
$ctoEnum :: Int -> Mode
toEnum :: Int -> Mode
$cfromEnum :: Mode -> Int
fromEnum :: Mode -> Int
$cenumFrom :: Mode -> [Mode]
enumFrom :: Mode -> [Mode]
$cenumFromThen :: Mode -> Mode -> [Mode]
enumFromThen :: Mode -> Mode -> [Mode]
$cenumFromTo :: Mode -> Mode -> [Mode]
enumFromTo :: Mode -> Mode -> [Mode]
$cenumFromThenTo :: Mode -> Mode -> Mode -> [Mode]
enumFromThenTo :: Mode -> Mode -> 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 a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Always
    Text
"exported"    -> Mode -> Parser Mode
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Exported
    Text
"diagnostics" -> Mode -> Parser Mode
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Diagnostics
    Text
_             -> Parser Mode
forall a. Parser a
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
$cfrom :: forall x.
GetGlobalBindingTypeSigs -> Rep GetGlobalBindingTypeSigs x
from :: forall x.
GetGlobalBindingTypeSigs -> Rep GetGlobalBindingTypeSigs x
$cto :: forall x.
Rep GetGlobalBindingTypeSigs x -> GetGlobalBindingTypeSigs
to :: forall x.
Rep GetGlobalBindingTypeSigs x -> GetGlobalBindingTypeSigs
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
$cshowsPrec :: Int -> GetGlobalBindingTypeSigs -> ShowS
showsPrec :: Int -> GetGlobalBindingTypeSigs -> ShowS
$cshow :: GetGlobalBindingTypeSigs -> String
show :: GetGlobalBindingTypeSigs -> String
$cshowList :: [GetGlobalBindingTypeSigs] -> ShowS
showList :: [GetGlobalBindingTypeSigs] -> ShowS
Show, GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
(GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> (GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool)
-> Eq GetGlobalBindingTypeSigs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
== :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$c/= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
/= :: 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
$ccompare :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Ordering
compare :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Ordering
$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
>= :: GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs -> Bool
$cmax :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
max :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
$cmin :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> GetGlobalBindingTypeSigs
min :: GetGlobalBindingTypeSigs
-> GetGlobalBindingTypeSigs -> 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
$chashWithSalt :: Int -> GetGlobalBindingTypeSigs -> Int
hashWithSalt :: Int -> GetGlobalBindingTypeSigs -> Int
$chash :: GetGlobalBindingTypeSigs -> Int
hash :: GetGlobalBindingTypeSigs -> Int
Hashable, GetGlobalBindingTypeSigs -> ()
(GetGlobalBindingTypeSigs -> ()) -> NFData GetGlobalBindingTypeSigs
forall a. (a -> ()) -> NFData a
$crnf :: GetGlobalBindingTypeSigs -> ()
rnf :: 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 :: GlobalBindingTypeSig -> Name
gbName :: 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 a. IO a -> Action a
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 a. a -> Action a
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 GhcTc]
binds = Bag (XRec GhcTc (HsBindLR GhcTc GhcTc)) -> [IdP GhcTc]
forall p idR.
CollectPass p =>
Bag (XRec p (HsBindLR p idR)) -> [IdP p]
collectHsBindsBinders (Bag (XRec GhcTc (HsBindLR GhcTc GhcTc)) -> [IdP GhcTc])
-> Bag (XRec GhcTc (HsBindLR GhcTc GhcTc)) -> [IdP GhcTc]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Bag (XRec GhcTc (HsBindLR GhcTc 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 = 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
identifier = IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
forall a. a -> a
liftZonkM (IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
forall a b. (a -> b) -> a -> b
$ do
        let name :: Name
name = Id -> Name
idName Id
identifier
        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
identifier)
          GlobalBindingTypeSig
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalBindingTypeSig
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 a. a -> IO a
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 TcRnMessage
_, [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 TcRnMessage, Maybe [Maybe GlobalBindingTypeSig])
forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, 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 TcRnMessage, Maybe [Maybe GlobalBindingTypeSig]))
-> TcM [Maybe GlobalBindingTypeSig]
-> IO (Messages TcRnMessage, 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe GlobalBindingTypeSig)
bindToSig [IdP GhcTc]
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PatSyn -> IO (Maybe GlobalBindingTypeSig)
patToSig [PatSyn]
patSyns
  Maybe GlobalBindingTypeSigsResult
-> IO (Maybe GlobalBindingTypeSigsResult)
forall a. a -> IO a
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 a. a -> IO a
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
-> ([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' = (Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
orig_args