{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE ViewPatterns #-}
-- | An HLS plugin to provide code actions to change type signatures
module Ide.Plugin.ChangeTypeSignature (descriptor
                                      -- * For Unit Tests
                                      , errorMessageRegexes
                                      ) where

import           Control.Monad                  (guard)
import           Control.Monad.IO.Class         (MonadIO (liftIO))
import           Control.Monad.Trans.Except     (ExceptT)
import           Data.Foldable                  (asum)
import qualified Data.HashMap.Strict            as Map
import           Data.Maybe                     (mapMaybe)
import           Data.String                    (IsString)
import           Data.Text                      (Text)
import qualified Data.Text                      as T
import           Development.IDE                (realSrcSpanToRange)
import           Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
import           Development.IDE.Core.Service   (IdeState, runAction)
import           Development.IDE.Core.Shake     (use)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Util       (printOutputable)
import           Generics.SYB                   (extQ, something)
import           Ide.PluginUtils                (getNormalizedFilePath,
                                                 handleMaybeM, pluginResponse)
import           Ide.Types                      (PluginDescriptor (..),
                                                 PluginMethodHandler,
                                                 defaultPluginDescriptor,
                                                 mkPluginHandler)
import           Language.LSP.Types
import           Text.Regex.TDFA                ((=~))

changeTypeSignatureId :: IsString a => a
changeTypeSignatureId :: forall a. IsString a => a
changeTypeSignatureId = a
"changeTypeSignature"

descriptor :: PluginDescriptor IdeState
descriptor :: PluginDescriptor IdeState
descriptor = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor forall a. IsString a => a
changeTypeSignatureId) { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler }

codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler IdeState
ideState PluginId
_ CodeActionParams {$sel:_textDocument:CodeActionParams :: CodeActionParams -> TextDocumentIdentifier
_textDocument = TextDocumentIdentifier Uri
uri, $sel:_context:CodeActionParams :: CodeActionParams -> CodeActionContext
_context = CodeActionContext (List [Diagnostic]
diags) Maybe (List CodeActionKind)
_} = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
      NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
getNormalizedFilePath Uri
uri
      [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls <- forall (m :: * -> *).
MonadIO m =>
IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs]
getDecls IdeState
ideState NormalizedFilePath
nfp
      let actions :: [Command |? CodeAction]
actions = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SigName =>
Uri
-> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)
generateAction Uri
uri [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls) [Diagnostic]
diags
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [Command |? CodeAction]
actions

getDecls :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs]
getDecls :: forall (m :: * -> *).
MonadIO m =>
IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs]
getDecls IdeState
state = forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"Error: Could not get Parsed Module"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsModule -> [LHsDecl GhcPs]
hsmodDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ParsedSource
pm_parsed_source))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> IdeState -> Action a -> IO a
runAction (forall a. IsString a => a
changeTypeSignatureId forall a. Semigroup a => a -> a -> a
<> String
".GetParsedModule") IdeState
state
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule

-- | Text representing a Declaration's Name
type DeclName = Text
-- | The signature provided by GHC Error Message (Expected type)
type ExpectedSig = Text
-- | The signature provided by GHC Error Message (Actual type)
type ActualSig = Text

-- | DataType that encodes the necessary information for changing a type signature
data ChangeSignature = ChangeSignature {
                         -- | The expected type based on Signature
                         ChangeSignature -> Text
expectedType  :: ExpectedSig
                         -- | the Actual Type based on definition
                         , ChangeSignature -> Text
actualType  :: ActualSig
                         -- | the declaration name to be updated
                         , ChangeSignature -> Text
declName    :: DeclName
                         -- | the location of the declaration signature
                         , ChangeSignature -> RealSrcSpan
declSrcSpan :: RealSrcSpan
                         -- | the diagnostic to solve
                         , ChangeSignature -> Diagnostic
diagnostic  :: Diagnostic
                         }

-- | Constraint needed to trackdown OccNames in signatures
type SigName = (HasOccName (IdP GhcPs))

-- | Create a CodeAction from a Diagnostic
generateAction :: SigName => Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)
generateAction :: SigName =>
Uri
-> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)
generateAction Uri
uri [LHsDecl GhcPs]
decls Diagnostic
diag = Uri -> ChangeSignature -> Command |? CodeAction
changeSigToCodeAction Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
diagnosticToChangeSig [LHsDecl GhcPs]
decls Diagnostic
diag

-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan
diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
diagnosticToChangeSig [LHsDecl GhcPs]
decls Diagnostic
diagnostic = do
    -- regex match on the GHC Error Message
    (Text
expectedType, Text
actualType, Text
declName) <- Diagnostic -> Maybe (Text, Text, Text)
matchingDiagnostic Diagnostic
diagnostic
    -- Find the definition and it's location
    RealSrcSpan
declSrcSpan <- SigName => [LHsDecl GhcPs] -> Text -> String -> Maybe RealSrcSpan
findSigLocOfStringDecl [LHsDecl GhcPs]
decls Text
expectedType (Text -> String
T.unpack Text
declName)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ChangeSignature{Text
RealSrcSpan
Diagnostic
declSrcSpan :: RealSrcSpan
declName :: Text
actualType :: Text
expectedType :: Text
diagnostic :: Diagnostic
diagnostic :: Diagnostic
declSrcSpan :: RealSrcSpan
declName :: Text
actualType :: Text
expectedType :: Text
..}


-- | If a diagnostic has the proper message create a ChangeSignature from it
matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName)
matchingDiagnostic :: Diagnostic -> Maybe (Text, Text, Text)
matchingDiagnostic Diagnostic{Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message :: Text
_message} = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Text, Text, Text, [Text]) -> Maybe (Text, Text, Text)
unwrapMatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
(=~) Text
_message) [Text]
errorMessageRegexes
    where
        unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName)
        -- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match
        unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (Text, Text, Text)
unwrapMatch (Text
_, Text
_, Text
_, [Text
expect, Text
actual, Text
_, Text
name]) = forall a. a -> Maybe a
Just (Text
expect, Text
actual, Text
name)
        unwrapMatch (Text, Text, Text, [Text])
_                              = forall a. Maybe a
Nothing

-- | List of regexes that match various Error Messages
errorMessageRegexes :: [Text]
errorMessageRegexes :: [Text]
errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests
    Text
"Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’"
    , Text
"Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’"
    -- GHC >9.2 version of the first error regex
    , Text
"Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’"
    ]

-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches
-- both the name given and the Expected Type, and return the type signature location
findSigLocOfStringDecl :: SigName => [LHsDecl GhcPs] -> ExpectedSig -> String -> Maybe RealSrcSpan
findSigLocOfStringDecl :: SigName => [LHsDecl GhcPs] -> Text -> String -> Maybe RealSrcSpan
findSigLocOfStringDecl [LHsDecl GhcPs]
decls Text
expectedType String
declName = forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (forall a b. a -> b -> a
const forall a. Maybe a
Nothing forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` LHsDecl GhcPs -> Maybe RealSrcSpan
findSig forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` LSig GhcPs -> Maybe RealSrcSpan
findLocalSig) [LHsDecl GhcPs]
decls
    where
        -- search for Top Level Signatures
        findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan
        findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan
findSig = \case
            L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_)) (SigD XSigD GhcPs
_ Sig GhcPs
sig) -> case Sig GhcPs
sig of
              ts :: Sig GhcPs
ts@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
idsSig LHsSigWcType GhcPs
_) -> forall {t :: * -> *} {name} {l}.
(Foldable t, HasOccName name) =>
Sig GhcPs -> t (GenLocated l name) -> Maybe ()
isMatch Sig GhcPs
ts [LIdP GhcPs]
idsSig forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure RealSrcSpan
rss
              Sig GhcPs
_                       -> forall a. Maybe a
Nothing
            LHsDecl GhcPs
_ -> forall a. Maybe a
Nothing

        -- search for Local Signatures
        findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan
        findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan
findLocalSig = \case
          (L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_)) ts :: Sig GhcPs
ts@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
idsSig LHsSigWcType GhcPs
_)) -> forall {t :: * -> *} {name} {l}.
(Foldable t, HasOccName name) =>
Sig GhcPs -> t (GenLocated l name) -> Maybe ()
isMatch Sig GhcPs
ts [LIdP GhcPs]
idsSig forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure RealSrcSpan
rss
          LSig GhcPs
_          -> forall a. Maybe a
Nothing

        -- Does the declName match? and does the expected signature match?
        isMatch :: Sig GhcPs -> t (GenLocated l name) -> Maybe ()
isMatch Sig GhcPs
ts t (GenLocated l name)
idsSig = do
                Text
ghcSig <- Sig GhcPs -> Maybe Text
sigToText Sig GhcPs
ts
                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {name} {l}. HasOccName name => GenLocated l name -> Bool
compareId t (GenLocated l name)
idsSig Bool -> Bool -> Bool
&& Text
expectedType forall a. Eq a => a -> a -> Bool
== Text
ghcSig)

        -- Given an IdP check to see if it matches the declName
        compareId :: GenLocated l name -> Bool
compareId (L l
_ name
id') = String
declName forall a. Eq a => a -> a -> Bool
== OccName -> String
occNameString (forall name. HasOccName name => name -> OccName
occName name
id')


-- | Pretty Print the Type Signature (to validate GHC Error Message)
sigToText :: Sig GhcPs -> Maybe Text
sigToText :: Sig GhcPs -> Maybe Text
sigToText = \case
  ts :: Sig GhcPs
ts@TypeSig {} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
stripSignature forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> Text
printOutputable Sig GhcPs
ts
  Sig GhcPs
_             -> forall a. Maybe a
Nothing

stripSignature :: Text -> Text
-- for whatever reason incoming signatures MAY have new lines after "::" or "=>"
stripSignature :: Text -> Text
stripSignature ((Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\n') -> Text
sig) = if Text -> Text -> Bool
T.isInfixOf Text
" => " Text
sig
                                                -- remove constraints
                                                then Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
" => " Text
sig
                                                else Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
" :: " Text
sig

changeSigToCodeAction :: Uri -> ChangeSignature -> Command |? CodeAction
changeSigToCodeAction :: Uri -> ChangeSignature -> Command |? CodeAction
changeSigToCodeAction Uri
uri ChangeSignature{Text
RealSrcSpan
Diagnostic
diagnostic :: Diagnostic
declSrcSpan :: RealSrcSpan
declName :: Text
actualType :: Text
expectedType :: Text
diagnostic :: ChangeSignature -> Diagnostic
declSrcSpan :: ChangeSignature -> RealSrcSpan
declName :: ChangeSignature -> Text
actualType :: ChangeSignature -> Text
expectedType :: ChangeSignature -> Text
..} = forall a b. b -> a |? b
InR CodeAction { $sel:_title:CodeAction :: Text
_title       = Text -> Text -> Text
mkChangeSigTitle Text
declName Text
actualType
                                                               , $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind        = forall a. a -> Maybe a
Just (Text -> CodeActionKind
CodeActionUnknown (Text
"quickfix." forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => a
changeTypeSignatureId))
                                                               , $sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
_diagnostics = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [Diagnostic
diagnostic]
                                                               , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. Maybe a
Nothing
                                                               , $sel:_disabled:CodeAction :: Maybe Reason
_disabled    = forall a. Maybe a
Nothing
                                                               , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit        = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Uri -> RealSrcSpan -> Text -> WorkspaceEdit
mkChangeSigEdit Uri
uri RealSrcSpan
declSrcSpan (Text -> Text -> Text
mkNewSignature Text
declName Text
actualType)
                                                               , $sel:_command:CodeAction :: Maybe Command
_command     = forall a. Maybe a
Nothing
                                                               , $sel:_xdata:CodeAction :: Maybe Value
_xdata       = forall a. Maybe a
Nothing
                                                               }

mkChangeSigTitle :: Text -> Text -> Text
mkChangeSigTitle :: Text -> Text -> Text
mkChangeSigTitle Text
declName Text
actualType = Text
"Change signature for ‘" forall a. Semigroup a => a -> a -> a
<> Text
declName forall a. Semigroup a => a -> a -> a
<> Text
"’ to: " forall a. Semigroup a => a -> a -> a
<> Text
actualType

mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit
mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit
mkChangeSigEdit Uri
uri RealSrcSpan
ss Text
replacement =
        let txtEdit :: TextEdit
txtEdit = Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss) Text
replacement
            changes :: Maybe (HashMap Uri (List TextEdit))
changes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Uri
uri (forall a. [a] -> List a
List [TextEdit
txtEdit])
        in Maybe (HashMap Uri (List TextEdit))
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit Maybe (HashMap Uri (List TextEdit))
changes forall a. Maybe a
Nothing forall a. Maybe a
Nothing

mkNewSignature :: Text -> Text -> Text
mkNewSignature :: Text -> Text -> Text
mkNewSignature Text
declName Text
actualType = Text
declName forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
actualType