{-# LANGUAGE CPP #-}
module Development.IDE.Plugin.Plugins.AddArgument (plugin) where

import           Control.Monad                             (join)
import           Control.Monad.Trans.Class                 (lift)
import           Data.Bifunctor                            (Bifunctor (..))
import           Data.Either.Extra                         (maybeToEither)
import qualified Data.Text                                 as T
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.ExactPrint     (exactPrint,
                                                            makeDeltaAst)
import           Development.IDE.GHC.Error                 (spanContainsRange)
import           Development.IDE.GHC.ExactPrint            (genAnchor1,
                                                            modifyMgMatchesT',
                                                            modifySigWithM,
                                                            modifySmallestDeclWithM)
import           Development.IDE.Plugin.Plugins.Diagnostic
import           GHC                                       (EpAnn (..),
                                                            SrcSpanAnn' (SrcSpanAnn),
                                                            SrcSpanAnnA,
                                                            SrcSpanAnnN,
                                                            emptyComments,
                                                            noAnn)
import           GHC.Types.SrcLoc                          (generatedSrcSpan)
import           Ide.Plugin.Error                          (PluginError (PluginInternalError))
import           Ide.PluginUtils                           (makeDiffTextEdit)
import           Language.Haskell.GHC.ExactPrint           (TransformT (..),
                                                            noAnnSrcSpanDP1,
                                                            runTransformT)
import           Language.LSP.Protocol.Types

#if !MIN_VERSION_ghc(9,4,0)
import           GHC                                       (TrailingAnn (..))
import           GHC.Hs                                    (IsUnicodeSyntax (..))
import           Language.Haskell.GHC.ExactPrint.Transform (d1)
#endif

#if MIN_VERSION_ghc(9,4,0)
import           Development.IDE.GHC.ExactPrint            (epl)
import           GHC.Parser.Annotation                     (TokenLocation (..))
#endif

-- When GHC tells us that a variable is not bound, it will tell us either:
--  - there is an unbound variable with a given type
--  - there is an unbound variable (GHC provides no type suggestion)
--
-- When we receive either of these errors, we produce a text edit that will add a new argument (as a new pattern in the
-- last position of each LHS of the top-level bindings for this HsDecl).
--
-- NOTE When adding a new argument to a declaration, the corresponding argument's type in declaration's signature might
--      not be the last type in the signature, such as:
--         foo :: a -> b -> c -> d
--         foo a b = \c -> ...
--      In this case a new argument would have to add its type between b and c in the signature.
plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])]
plugin :: ParsedModule
-> Diagnostic -> Either PluginError [(Text, [TextEdit])]
plugin ParsedModule
parsedModule Diagnostic {Text
_message :: Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message, Range
_range :: Range
$sel:_range:Diagnostic :: Diagnostic -> Range
_range}
  | Just (Text
name, Maybe Text
typ) <- Text -> Maybe (Text, Maybe Text)
matchVariableNotInScope Text
message = ParsedModule
-> Range
-> Text
-> Maybe Text
-> Either PluginError [(Text, [TextEdit])]
addArgumentAction ParsedModule
parsedModule Range
_range Text
name Maybe Text
typ
  | Just (Text
name, Text
typ) <- Text -> Maybe (Text, Text)
matchFoundHoleIncludeUnderscore Text
message = ParsedModule
-> Range
-> Text
-> Maybe Text
-> Either PluginError [(Text, [TextEdit])]
addArgumentAction ParsedModule
parsedModule Range
_range Text
name (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
typ)
  | Bool
otherwise = [(Text, [TextEdit])] -> Either PluginError [(Text, [TextEdit])]
forall a. a -> Either PluginError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    message :: Text
message = Text -> Text
unifySpaces Text
_message

-- Given a name for the new binding, add a new pattern to the match in the last position,
-- returning how many patterns there were in this match prior to the transformation:
--      addArgToMatch "foo" `bar arg1 arg2 = ...`
--   => (`bar arg1 arg2 foo = ...`, 2)
addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int)
addArgToMatch :: forall l body.
Text
-> GenLocated l (Match GhcPs body)
-> (GenLocated l (Match GhcPs body), Int)
addArgToMatch Text
name (L l
locMatch (Match XCMatch GhcPs body
xMatch HsMatchContext GhcPs
ctxMatch [LPat GhcPs]
pats GRHSs GhcPs body
rhs)) =
  let unqualName :: RdrName
unqualName = OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ String -> OccName
mkVarOcc (String -> OccName) -> String -> OccName
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
name
      newPat :: GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
newPat = SrcSpanAnn' (EpAnn AnnListItem)
-> Pat GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall ann. Monoid ann => SrcSpan -> SrcSpanAnn' (EpAnn ann)
noAnnSrcSpanDP1 SrcSpan
generatedSrcSpan) (Pat GhcPs
 -> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs))
-> Pat GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
NoExtField (RdrName -> LocatedAn NameAnn RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
unqualName)
  in (l -> Match GhcPs body -> GenLocated l (Match GhcPs body)
forall l e. l -> e -> GenLocated l e
L l
locMatch (XCMatch GhcPs body
-> HsMatchContext GhcPs
-> [LPat GhcPs]
-> GRHSs GhcPs body
-> Match GhcPs body
forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Match XCMatch GhcPs body
xMatch HsMatchContext GhcPs
ctxMatch ([LPat GhcPs]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
pats [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
forall a. Semigroup a => a -> a -> a
<> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)
newPat]) GRHSs GhcPs body
rhs), [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [LPat GhcPs]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcPs)]
pats)

-- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind.
-- Also return:
--   - the declaration's name
--   - the number of bound patterns in the declaration's matches prior to the transformation
--
-- For example:
--    insertArg "new_pat" `foo bar baz = 1`
-- => (`foo bar baz new_pat = 1`, Just ("foo", 2))
appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either PluginError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int))
appendFinalPatToMatches :: Text
-> LHsDecl GhcPs
-> TransformT
     (Either PluginError)
     (LHsDecl GhcPs, Maybe (LocatedAn NameAnn RdrName, Int))
appendFinalPatToMatches Text
name = \case
  (L SrcSpanAnn' (EpAnn AnnListItem)
locDecl (ValD XValD GhcPs
xVal fun :: HsBind GhcPs
fun@FunBind{fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=MatchGroup GhcPs (LHsExpr GhcPs)
mg,fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcPs
idFunBind})) -> do
    (MatchGroup GhcPs (LHsExpr GhcPs)
mg', Maybe Int
numPatsMay) <- MatchGroup GhcPs (LHsExpr GhcPs)
-> (LMatch GhcPs (LHsExpr GhcPs)
    -> TransformT
         (Either PluginError) (LMatch GhcPs (LHsExpr GhcPs), Maybe Int))
-> Maybe Int
-> (Maybe Int -> Maybe Int -> Either PluginError (Maybe Int))
-> TransformT
     (Either PluginError) (MatchGroup GhcPs (LHsExpr GhcPs), Maybe Int)
forall (m :: * -> *) r.
Monad m =>
MatchGroup GhcPs (LHsExpr GhcPs)
-> (LMatch GhcPs (LHsExpr GhcPs)
    -> TransformT m (LMatch GhcPs (LHsExpr GhcPs), r))
-> r
-> (r -> r -> m r)
-> TransformT m (MatchGroup GhcPs (LHsExpr GhcPs), r)
modifyMgMatchesT' MatchGroup GhcPs (LHsExpr GhcPs)
mg ((GenLocated
   (SrcSpanAnn' (EpAnn AnnListItem))
   (Match
      GhcPs
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
 Maybe Int)
-> TransformT
     (Either PluginError)
     (GenLocated
        (SrcSpanAnn' (EpAnn AnnListItem))
        (Match
           GhcPs
           (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
      Maybe Int)
forall a. a -> TransformT (Either PluginError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((GenLocated
    (SrcSpanAnn' (EpAnn AnnListItem))
    (Match
       GhcPs
       (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
  Maybe Int)
 -> TransformT
      (Either PluginError)
      (GenLocated
         (SrcSpanAnn' (EpAnn AnnListItem))
         (Match
            GhcPs
            (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
       Maybe Int))
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (Match
         GhcPs
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)))
    -> (GenLocated
          (SrcSpanAnn' (EpAnn AnnListItem))
          (Match
             GhcPs
             (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
        Maybe Int))
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnListItem))
     (Match
        GhcPs
        (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)))
-> TransformT
     (Either PluginError)
     (GenLocated
        (SrcSpanAnn' (EpAnn AnnListItem))
        (Match
           GhcPs
           (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
      Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Maybe Int)
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (Match
         GhcPs
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
    Int)
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (Match
         GhcPs
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
    Maybe Int)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Int -> Maybe Int
forall a. a -> Maybe a
Just ((GenLocated
    (SrcSpanAnn' (EpAnn AnnListItem))
    (Match
       GhcPs
       (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
  Int)
 -> (GenLocated
       (SrcSpanAnn' (EpAnn AnnListItem))
       (Match
          GhcPs
          (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
     Maybe Int))
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (Match
         GhcPs
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)))
    -> (GenLocated
          (SrcSpanAnn' (EpAnn AnnListItem))
          (Match
             GhcPs
             (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
        Int))
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnListItem))
     (Match
        GhcPs
        (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)))
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (Match
         GhcPs
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
    Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnListItem))
     (Match
        GhcPs
        (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs)))
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnListItem))
      (Match
         GhcPs
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcPs))),
    Int)
forall l body.
Text
-> GenLocated l (Match GhcPs body)
-> (GenLocated l (Match GhcPs body), Int)
addArgToMatch Text
name) Maybe Int
forall a. Maybe a
Nothing Maybe Int -> Maybe Int -> Either PluginError (Maybe Int)
forall {a}.
Eq a =>
Maybe a -> Maybe a -> Either PluginError (Maybe a)
combineMatchNumPats
    Int
numPats <- RWST () [String] Int (Either PluginError) Int
-> TransformT (Either PluginError) Int
forall (m :: * -> *) a. RWST () [String] Int m a -> TransformT m a
TransformT (RWST () [String] Int (Either PluginError) Int
 -> TransformT (Either PluginError) Int)
-> RWST () [String] Int (Either PluginError) Int
-> TransformT (Either PluginError) Int
forall a b. (a -> b) -> a -> b
$ Either PluginError Int
-> RWST () [String] Int (Either PluginError) Int
forall (m :: * -> *) a. Monad m => m a -> RWST () [String] Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either PluginError Int
 -> RWST () [String] Int (Either PluginError) Int)
-> Either PluginError Int
-> RWST () [String] Int (Either PluginError) Int
forall a b. (a -> b) -> a -> b
$ PluginError -> Maybe Int -> Either PluginError Int
forall a b. a -> Maybe b -> Either a b
maybeToEither (Text -> PluginError
PluginInternalError Text
"Unexpected empty match group in HsDecl") Maybe Int
numPatsMay
    let decl' :: GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
decl' = SrcSpanAnn' (EpAnn AnnListItem)
-> HsDecl GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
locDecl (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
xVal HsBind GhcPs
fun{fun_matches=mg'})
    (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
 Maybe (LocatedAn NameAnn RdrName, Int))
-> TransformT
     (Either PluginError)
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
      Maybe (LocatedAn NameAnn RdrName, Int))
forall a. a -> TransformT (Either PluginError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
decl', (LocatedAn NameAnn RdrName, Int)
-> Maybe (LocatedAn NameAnn RdrName, Int)
forall a. a -> Maybe a
Just (LIdP GhcPs
LocatedAn NameAnn RdrName
idFunBind, Int
numPats))
  LHsDecl GhcPs
decl -> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
 Maybe (LocatedAn NameAnn RdrName, Int))
-> TransformT
     (Either PluginError)
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
      Maybe (LocatedAn NameAnn RdrName, Int))
forall a. a -> TransformT (Either PluginError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsDecl GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
decl, Maybe (LocatedAn NameAnn RdrName, Int)
forall a. Maybe a
Nothing)
  where
    combineMatchNumPats :: Maybe a -> Maybe a -> Either PluginError (Maybe a)
combineMatchNumPats  Maybe a
Nothing Maybe a
other = Maybe a -> Either PluginError (Maybe a)
forall a. a -> Either PluginError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
other
    combineMatchNumPats  Maybe a
other Maybe a
Nothing = Maybe a -> Either PluginError (Maybe a)
forall a. a -> Either PluginError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
other
    combineMatchNumPats  (Just a
l) (Just a
r)
      | a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r = Maybe a -> Either PluginError (Maybe a)
forall a. a -> Either PluginError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
l)
      | Bool
otherwise = PluginError -> Either PluginError (Maybe a)
forall a b. a -> Either a b
Left (PluginError -> Either PluginError (Maybe a))
-> PluginError -> Either PluginError (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"Unexpected different numbers of patterns in HsDecl MatchGroup"

-- The add argument works as follows:
--  1. Attempt to add the given name as the last pattern of the declaration that contains `range`.
--  2. If such a declaration exists, use that declaration's name to modify the signature of said declaration, if it
--     has a type signature.
--
-- NOTE For the following situation, the type signature is not updated (it's unclear what should happen):
--   type FunctionTySyn = () -> Int
--   foo :: FunctionTySyn
--   foo () = new_def
--
-- TODO instead of inserting a typed hole; use GHC's suggested type from the error
addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])]
addArgumentAction :: ParsedModule
-> Range
-> Text
-> Maybe Text
-> Either PluginError [(Text, [TextEdit])]
addArgumentAction (ParsedModule ModSummary
_ ParsedSource
moduleSrc [String]
_ ()
_) Range
range Text
name Maybe Text
_typ = do
    (ParsedSource
newSource, Int
_, [String]
_) <- TransformT (Either PluginError) ParsedSource
-> Either PluginError (ParsedSource, Int, [String])
forall (m :: * -> *) a. TransformT m a -> m (a, Int, [String])
runTransformT (TransformT (Either PluginError) ParsedSource
 -> Either PluginError (ParsedSource, Int, [String]))
-> TransformT (Either PluginError) ParsedSource
-> Either PluginError (ParsedSource, Int, [String])
forall a b. (a -> b) -> a -> b
$ do
      (ParsedSource
moduleSrc', Maybe (Maybe (LocatedAn NameAnn RdrName, Int))
-> Maybe (LocatedAn NameAnn RdrName, Int)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Maybe (LocatedAn NameAnn RdrName, Int)
matchedDeclNameMay) <- ParsedSource
-> TransformT
     (Either PluginError)
     (ParsedSource, Maybe (Maybe (LocatedAn NameAnn RdrName, Int)))
addNameAsLastArgOfMatchingDecl (ParsedSource -> ParsedSource
forall ast. ExactPrint ast => ast -> ast
makeDeltaAst ParsedSource
moduleSrc)
      case Maybe (LocatedAn NameAnn RdrName, Int)
matchedDeclNameMay of
          Just (LocatedAn NameAnn RdrName
matchedDeclName, Int
numPats) -> IdP GhcPs
-> (LHsSigType GhcPs -> LHsSigType GhcPs)
-> ParsedSource
-> TransformT (Either PluginError) ParsedSource
forall a (m :: * -> *).
(HasDecls a, Monad m) =>
IdP GhcPs
-> (LHsSigType GhcPs -> LHsSigType GhcPs) -> a -> TransformT m a
modifySigWithM (LocatedAn NameAnn RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedAn NameAnn RdrName
matchedDeclName) (Int -> LHsSigType GhcPs -> LHsSigType GhcPs
addTyHoleToTySigArg Int
numPats) ParsedSource
moduleSrc'
          Maybe (LocatedAn NameAnn RdrName, Int)
Nothing -> ParsedSource -> TransformT (Either PluginError) ParsedSource
forall a. a -> TransformT (Either PluginError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedSource
moduleSrc'
    let diff :: [TextEdit]
diff = Text -> Text -> [TextEdit]
makeDiffTextEdit (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParsedSource -> String
forall ast. ExactPrint ast => ast -> String
exactPrint ParsedSource
moduleSrc) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParsedSource -> String
forall ast. ExactPrint ast => ast -> String
exactPrint ParsedSource
newSource)
    [(Text, [TextEdit])] -> Either PluginError [(Text, [TextEdit])]
forall a. a -> Either PluginError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text
"Add argument ‘" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"’ to function", [TextEdit]
diff)]
  where
    addNameAsLastArgOfMatchingDecl :: ParsedSource
-> TransformT
     (Either PluginError)
     (ParsedSource, Maybe (Maybe (LocatedAn NameAnn RdrName, Int)))
addNameAsLastArgOfMatchingDecl = (SrcSpan -> Either PluginError Bool)
-> (LHsDecl GhcPs
    -> TransformT
         (Either PluginError)
         ([LHsDecl GhcPs], Maybe (LocatedAn NameAnn RdrName, Int)))
-> ParsedSource
-> TransformT
     (Either PluginError)
     (ParsedSource, Maybe (Maybe (LocatedAn NameAnn RdrName, Int)))
forall a (m :: * -> *) r.
(HasDecls a, Monad m) =>
(SrcSpan -> m Bool)
-> (LHsDecl GhcPs -> TransformT m ([LHsDecl GhcPs], r))
-> a
-> TransformT m (a, Maybe r)
modifySmallestDeclWithM SrcSpan -> Either PluginError Bool
spanContainsRangeOrErr LHsDecl GhcPs
-> TransformT
     (Either PluginError)
     ([LHsDecl GhcPs], Maybe (LocatedAn NameAnn RdrName, Int))
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> TransformT
     (Either PluginError)
     ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
      Maybe (LocatedAn NameAnn RdrName, Int))
addNameAsLastArg
    addNameAsLastArg :: GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> TransformT
     (Either PluginError)
     ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
      Maybe (LocatedAn NameAnn RdrName, Int))
addNameAsLastArg = ((GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
  Maybe (LocatedAn NameAnn RdrName, Int))
 -> ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
     Maybe (LocatedAn NameAnn RdrName, Int)))
-> TransformT
     (Either PluginError)
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
      Maybe (LocatedAn NameAnn RdrName, Int))
-> TransformT
     (Either PluginError)
     ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
      Maybe (LocatedAn NameAnn RdrName, Int))
forall a b.
(a -> b)
-> TransformT (Either PluginError) a
-> TransformT (Either PluginError) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
 -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)])
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
    Maybe (LocatedAn NameAnn RdrName, Int))
-> ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
    Maybe (LocatedAn NameAnn RdrName, Int))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
:[])) (TransformT
   (Either PluginError)
   (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
    Maybe (LocatedAn NameAnn RdrName, Int))
 -> TransformT
      (Either PluginError)
      ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
       Maybe (LocatedAn NameAnn RdrName, Int)))
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
    -> TransformT
         (Either PluginError)
         (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs),
          Maybe (LocatedAn NameAnn RdrName, Int)))
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)
-> TransformT
     (Either PluginError)
     ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GhcPs)],
      Maybe (LocatedAn NameAnn RdrName, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> LHsDecl GhcPs
-> TransformT
     (Either PluginError)
     (LHsDecl GhcPs, Maybe (LocatedAn NameAnn RdrName, Int))
appendFinalPatToMatches Text
name

    spanContainsRangeOrErr :: SrcSpan -> Either PluginError Bool
spanContainsRangeOrErr = PluginError -> Maybe Bool -> Either PluginError Bool
forall a b. a -> Maybe b -> Either a b
maybeToEither (Text -> PluginError
PluginInternalError Text
"SrcSpan was not valid range") (Maybe Bool -> Either PluginError Bool)
-> (SrcSpan -> Maybe Bool) -> SrcSpan -> Either PluginError Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> Range -> Maybe Bool
`spanContainsRange` Range
range)

-- Transform an LHsType into a list of arguments and return type, to make transformations easier.
hsTypeToFunTypeAsList :: LHsType GhcPs -> ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs)
hsTypeToFunTypeAsList :: LHsType GhcPs
-> ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
      LHsType GhcPs)],
    LHsType GhcPs)
hsTypeToFunTypeAsList = \case
  L SrcSpanAnn' (EpAnn AnnListItem)
spanAnnA (HsFunTy XFunTy GhcPs
xFunTy HsArrow GhcPs
arrow LHsType GhcPs
lhs LHsType GhcPs
rhs) ->
    let ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
  LHsType GhcPs)]
rhsArgs, LHsType GhcPs
rhsRes) = LHsType GhcPs
-> ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
      LHsType GhcPs)],
    LHsType GhcPs)
hsTypeToFunTypeAsList LHsType GhcPs
rhs
    in ((SrcSpanAnn' (EpAnn AnnListItem)
spanAnnA, XFunTy GhcPs
EpAnnCO
xFunTy, HsArrow GhcPs
arrow, LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
lhs)(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
rhsArgs, LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
rhsRes)
  LHsType GhcPs
ty -> ([], LHsType GhcPs
ty)

-- The inverse of `hsTypeToFunTypeAsList`
hsTypeFromFunTypeAsList :: ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) -> LHsType GhcPs
hsTypeFromFunTypeAsList :: ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
   LHsType GhcPs)],
 LHsType GhcPs)
-> LHsType GhcPs
hsTypeFromFunTypeAsList ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
  LHsType GhcPs)]
args, LHsType GhcPs
res) =
  ((SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
 -> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
 -> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(SrcSpanAnn' (EpAnn AnnListItem)
spanAnnA, EpAnnCO
xFunTy, HsArrow GhcPs
arrow, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
argTy) GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
res -> SrcSpanAnn' (EpAnn AnnListItem)
-> HsType GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
spanAnnA (HsType GhcPs
 -> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
-> HsType GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XFunTy GhcPs
-> HsArrow GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
EpAnnCO
xFunTy HsArrow GhcPs
arrow LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
argTy LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
res) LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
res [(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
  LHsType GhcPs)]
[(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
args

-- Add a typed hole to a type signature in the given argument position:
--   0 `foo :: ()` => foo :: _ -> ()
--   2 `foo :: FunctionTySyn` => foo :: FunctionTySyn
--   1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int
addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs)
addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> LHsSigType GhcPs
addTyHoleToTySigArg Int
loc (L SrcSpanAnn' (EpAnn AnnListItem)
annHsSig (HsSig XHsSig GhcPs
xHsSig HsOuterSigTyVarBndrs GhcPs
tyVarBndrs LHsType GhcPs
lsigTy)) =
    let ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
  LHsType GhcPs)]
args, LHsType GhcPs
res) = LHsType GhcPs
-> ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
      LHsType GhcPs)],
    LHsType GhcPs)
hsTypeToFunTypeAsList LHsType GhcPs
lsigTy
#if MIN_VERSION_ghc(9,4,0)
        wildCardAnn :: SrcSpanAnn' (EpAnn AnnListItem)
wildCardAnn = EpAnn AnnListItem -> SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> AnnListItem -> EpAnnComments -> EpAnn AnnListItem
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
genAnchor1 ([TrailingAnn] -> AnnListItem
AnnListItem []) EpAnnComments
emptyComments) SrcSpan
generatedSrcSpan
        arrowAnn :: TokenLocation
arrowAnn = EpaLocation -> TokenLocation
TokenLoc (Int -> EpaLocation
epl Int
1)
        newArg :: (SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
newArg = (EpAnn AnnListItem -> SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn AnnListItem
forall a. Monoid a => a
mempty SrcSpan
generatedSrcSpan, EpAnn a
forall a. EpAnn a
noAnn, LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs
forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow (TokenLocation
-> HsUniToken "->" "\8594"
-> GenLocated TokenLocation (HsUniToken "->" "\8594")
forall l e. l -> e -> GenLocated l e
L TokenLocation
arrowAnn HsUniToken "->" "\8594"
forall (tok :: Symbol) (utok :: Symbol). HsUniToken tok utok
HsNormalTok), SrcSpanAnn' (EpAnn AnnListItem)
-> HsType GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
wildCardAnn (HsType GhcPs
 -> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
-> HsType GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XWildCardTy GhcPs -> HsType GhcPs
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy GhcPs
NoExtField
noExtField)
#else
        wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan
        newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField)
#endif
        -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments
        --      in the signature, then we return the original type signature.
        --      This situation most likely occurs due to a function type synonym in the signature
        insertArg :: t
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
insertArg t
n [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
_ | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 = String
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
forall a. HasCallStack => String -> a
error String
"Not possible"
        insertArg t
0 [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
as = (SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
forall {a}.
(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
newArg(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
forall a. a -> [a] -> [a]
:[(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
as
        insertArg t
_ [] = []
        insertArg t
n ((SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
a:[(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
as) = (SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
a (SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
 GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
forall a. a -> [a] -> [a]
: t
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
insertArg (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
as
        lsigTy' :: LHsType GhcPs
lsigTy' = ([(SrcSpanAnn' (EpAnn AnnListItem), XFunTy GhcPs, HsArrow GhcPs,
   LHsType GhcPs)],
 LHsType GhcPs)
-> LHsType GhcPs
hsTypeFromFunTypeAsList (Int
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
forall {t} {a}.
(Ord t, Num t) =>
t
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
-> [(SrcSpanAnn' (EpAnn AnnListItem), EpAnn a, HsArrow GhcPs,
     GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
insertArg Int
loc [(SrcSpanAnn' (EpAnn AnnListItem), EpAnnCO, HsArrow GhcPs,
  GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs))]
args, LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
res)
    in SrcSpanAnn' (EpAnn AnnListItem)
-> HsSigType GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
annHsSig (XHsSig GhcPs
-> HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsSigType GhcPs
forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig XHsSig GhcPs
xHsSig HsOuterSigTyVarBndrs GhcPs
tyVarBndrs LHsType GhcPs
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsType GhcPs)
lsigTy')