{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NumDecimals         #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-- | A plugin that uses tactics to synthesize code
module Ide.Plugin.Tactic
  ( descriptor
  , tacticTitle
  , TacticCommand (..)
  ) where

import           Bag                                              (bagToList,
                                                                   listToBag)
import           Control.Exception                                (evaluate)
import           Control.Monad
import           Control.Monad.Trans
import           Control.Monad.Trans.Maybe
import           Data.Aeson
import           Data.Bifunctor                                   (Bifunctor (bimap))
import           Data.Bool                                        (bool)
import           Data.Data                                        (Data)
import           Data.Generics.Aliases                            (mkQ)
import           Data.Generics.Schemes                            (everything)
import           Data.Maybe
import           Data.Monoid
import qualified Data.Text                                        as T
import           Data.Traversable
import           Development.IDE.Core.Shake                       (IdeState (..))
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.ExactPrint
import           Development.Shake.Classes
import           Ide.Plugin.Tactic.CaseSplit
import           Ide.Plugin.Tactic.FeatureSet                     (Feature (..),
                                                                   hasFeature)
import           Ide.Plugin.Tactic.GHC
import           Ide.Plugin.Tactic.LanguageServer
import           Ide.Plugin.Tactic.LanguageServer.TacticProviders
import           Ide.Plugin.Tactic.Range
import           Ide.Plugin.Tactic.Tactics
import           Ide.Plugin.Tactic.TestTypes
import           Ide.Plugin.Tactic.Types
import           Ide.Types
import           Language.LSP.Server
import           Language.LSP.Types
import           Language.LSP.Types.Capabilities
import           OccName
import           Prelude                                          hiding (span)
import           System.Timeout


descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> PluginDescriptor Any
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
    { pluginCommands :: [PluginCommand IdeState]
pluginCommands
        = (TacticCommand -> PluginCommand IdeState)
-> [TacticCommand] -> [PluginCommand IdeState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TacticCommand
tc ->
            CommandId
-> Text
-> CommandFunction IdeState TacticParams
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand
              (TacticCommand -> CommandId
tcCommandId TacticCommand
tc)
              (Text -> Text
tacticDesc (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TacticCommand -> Text
tcCommandName TacticCommand
tc)
              ((OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
tacticCmd ((OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams)
-> (OccName -> TacticsM ())
-> CommandFunction IdeState TacticParams
forall a b. (a -> b) -> a -> b
$ TacticCommand -> OccName -> TacticsM ()
commandTactic TacticCommand
tc))
              [TacticCommand
forall a. Bounded a => a
minBound .. TacticCommand
forall a. Bounded a => a
maxBound]
    , pluginHandlers :: PluginHandlers IdeState
pluginHandlers =
        SClientMethod 'TextDocumentCodeAction
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
    }



codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
state PluginId
plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx)
  | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
      FeatureSet
features <- ShakeExtras -> LspT Config IO FeatureSet
forall (m :: * -> *).
MonadLsp Config m =>
ShakeExtras -> m FeatureSet
getFeatureSet (IdeState -> ShakeExtras
shakeExtras IdeState
state)
      IO (Either ResponseError (List (Command |? CodeAction)))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (List (Command |? CodeAction)))
 -> LspT
      Config IO (Either ResponseError (List (Command |? CodeAction))))
-> IO (Either ResponseError (List (Command |? CodeAction)))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ Either ResponseError (List (Command |? CodeAction))
-> MaybeT IO (Either ResponseError (List (Command |? CodeAction)))
-> IO (Either ResponseError (List (Command |? CodeAction)))
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT (List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List []) (MaybeT IO (Either ResponseError (List (Command |? CodeAction)))
 -> IO (Either ResponseError (List (Command |? CodeAction))))
-> MaybeT IO (Either ResponseError (List (Command |? CodeAction)))
-> IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ do
        (Range
_, Judgement
jdg, Context
_, DynFlags
dflags) <- IdeState
-> NormalizedFilePath
-> Range
-> FeatureSet
-> MaybeT IO (Range, Judgement, Context, DynFlags)
judgementForHole IdeState
state NormalizedFilePath
nfp Range
range FeatureSet
features
        [Command |? CodeAction]
actions <- IO [Command |? CodeAction] -> MaybeT IO [Command |? CodeAction]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Command |? CodeAction] -> MaybeT IO [Command |? CodeAction])
-> IO [Command |? CodeAction] -> MaybeT IO [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$
          -- This foldMap is over the function monoid.
          (TacticCommand -> TacticProvider)
-> [TacticCommand] -> TacticProvider
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TacticCommand -> TacticProvider
commandProvider [TacticCommand
forall a. Bounded a => a
minBound .. TacticCommand
forall a. Bounded a => a
maxBound]
            DynFlags
dflags
            FeatureSet
features
            PluginId
plId
            Uri
uri
            Range
range
            Judgement
jdg
        Either ResponseError (List (Command |? CodeAction))
-> MaybeT IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List (Command |? CodeAction))
 -> MaybeT IO (Either ResponseError (List (Command |? CodeAction))))
-> Either ResponseError (List (Command |? CodeAction))
-> MaybeT IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List [Command |? CodeAction]
actions
codeActionProvider IdeState
_ PluginId
_ MessageParams 'TextDocumentCodeAction
_ = Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List (Command |? CodeAction))
 -> LspT
      Config IO (Either ResponseError (List (Command |? CodeAction))))
-> Either ResponseError (List (Command |? CodeAction))
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall a b. (a -> b) -> a -> b
$ List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List []


tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
tacticCmd OccName -> TacticsM ()
tac IdeState
state (TacticParams Uri
uri Range
range Text
var_name)
  | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
      FeatureSet
features <- ShakeExtras -> LspT Config IO FeatureSet
forall (m :: * -> *).
MonadLsp Config m =>
ShakeExtras -> m FeatureSet
getFeatureSet (IdeState -> ShakeExtras
shakeExtras IdeState
state)
      ClientCapabilities
ccs <- LspT Config IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
      Either ResponseError (Maybe WorkspaceEdit)
res <- IO (Either ResponseError (Maybe WorkspaceEdit))
-> LspT Config IO (Either ResponseError (Maybe WorkspaceEdit))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (Maybe WorkspaceEdit))
 -> LspT Config IO (Either ResponseError (Maybe WorkspaceEdit)))
-> IO (Either ResponseError (Maybe WorkspaceEdit))
-> LspT Config IO (Either ResponseError (Maybe WorkspaceEdit))
forall a b. (a -> b) -> a -> b
$ Either ResponseError (Maybe WorkspaceEdit)
-> MaybeT IO (Either ResponseError (Maybe WorkspaceEdit))
-> IO (Either ResponseError (Maybe WorkspaceEdit))
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT (Maybe WorkspaceEdit -> Either ResponseError (Maybe WorkspaceEdit)
forall a b. b -> Either a b
Right Maybe WorkspaceEdit
forall a. Maybe a
Nothing) (MaybeT IO (Either ResponseError (Maybe WorkspaceEdit))
 -> IO (Either ResponseError (Maybe WorkspaceEdit)))
-> MaybeT IO (Either ResponseError (Maybe WorkspaceEdit))
-> IO (Either ResponseError (Maybe WorkspaceEdit))
forall a b. (a -> b) -> a -> b
$ do
        (Range
range', Judgement
jdg, Context
ctx, DynFlags
dflags) <- IdeState
-> NormalizedFilePath
-> Range
-> FeatureSet
-> MaybeT IO (Range, Judgement, Context, DynFlags)
judgementForHole IdeState
state NormalizedFilePath
nfp Range
range FeatureSet
features
        let span :: RealSrcSpan
span = String -> Range -> RealSrcSpan
rangeToRealSrcSpan (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp) Range
range'
        Annotated ParsedSource
pm <- IO (Maybe (Annotated ParsedSource))
-> MaybeT IO (Annotated ParsedSource)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Annotated ParsedSource))
 -> MaybeT IO (Annotated ParsedSource))
-> IO (Maybe (Annotated ParsedSource))
-> MaybeT IO (Annotated ParsedSource)
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> NormalizedFilePath
-> IO (Maybe (Annotated ParsedSource))
useAnnotatedSource String
"tacticsCmd" IdeState
state NormalizedFilePath
nfp

        Int
-> Either ResponseError (Maybe WorkspaceEdit)
-> MaybeT IO (Either ResponseError (Maybe WorkspaceEdit))
forall a.
Int -> Either ResponseError a -> MaybeT IO (Either ResponseError a)
timingOut Int
2e8 (Either ResponseError (Maybe WorkspaceEdit)
 -> MaybeT IO (Either ResponseError (Maybe WorkspaceEdit)))
-> Either ResponseError (Maybe WorkspaceEdit)
-> MaybeT IO (Either ResponseError (Maybe WorkspaceEdit))
forall a b. (a -> b) -> a -> b
$ Either ResponseError (Either ResponseError (Maybe WorkspaceEdit))
-> Either ResponseError (Maybe WorkspaceEdit)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either ResponseError (Either ResponseError (Maybe WorkspaceEdit))
 -> Either ResponseError (Maybe WorkspaceEdit))
-> Either
     ResponseError (Either ResponseError (Maybe WorkspaceEdit))
-> Either ResponseError (Maybe WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$
          ([TacticError] -> ResponseError)
-> (RunTacticResults -> Either ResponseError (Maybe WorkspaceEdit))
-> Either [TacticError] RunTacticResults
-> Either
     ResponseError (Either ResponseError (Maybe WorkspaceEdit))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ErrorCode -> Text -> ResponseError
mkErr ErrorCode
InvalidRequest (Text -> ResponseError)
-> ([TacticError] -> Text) -> [TacticError] -> ResponseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> ([TacticError] -> String) -> [TacticError] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TacticError] -> String
forall a. Show a => a -> String
show)
                (RealSrcSpan
-> DynFlags
-> ClientCapabilities
-> Uri
-> Annotated ParsedSource
-> RunTacticResults
-> Either ResponseError (Maybe WorkspaceEdit)
mkWorkspaceEdits RealSrcSpan
span DynFlags
dflags ClientCapabilities
ccs Uri
uri Annotated ParsedSource
pm)
            (Either [TacticError] RunTacticResults
 -> Either
      ResponseError (Either ResponseError (Maybe WorkspaceEdit)))
-> Either [TacticError] RunTacticResults
-> Either
     ResponseError (Either ResponseError (Maybe WorkspaceEdit))
forall a b. (a -> b) -> a -> b
$ Context
-> Judgement
-> TacticsM ()
-> Either [TacticError] RunTacticResults
runTactic Context
ctx Judgement
jdg (TacticsM () -> Either [TacticError] RunTacticResults)
-> TacticsM () -> Either [TacticError] RunTacticResults
forall a b. (a -> b) -> a -> b
$ OccName -> TacticsM ()
tac (OccName -> TacticsM ()) -> OccName -> TacticsM ()
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
var_name

      case Either ResponseError (Maybe WorkspaceEdit)
res of
        Left ResponseError
err -> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left ResponseError
err
        Right Maybe WorkspaceEdit
medit -> do
          Maybe WorkspaceEdit
-> (WorkspaceEdit -> LspT Config IO (LspId 'WorkspaceApplyEdit))
-> LspT Config IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WorkspaceEdit
medit ((WorkspaceEdit -> LspT Config IO (LspId 'WorkspaceApplyEdit))
 -> LspT Config IO ())
-> (WorkspaceEdit -> LspT Config IO (LspId 'WorkspaceApplyEdit))
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceEdit
edit ->
            SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest
              SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit
              (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
edit)
              (LspT Config IO ()
-> Either ResponseError ApplyWorkspaceEditResponseBody
-> LspT Config IO ()
forall a b. a -> b -> a
const (LspT Config IO ()
 -> Either ResponseError ApplyWorkspaceEditResponseBody
 -> LspT Config IO ())
-> LspT Config IO ()
-> Either ResponseError ApplyWorkspaceEditResponseBody
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null
tacticCmd OccName -> TacticsM ()
_ IdeState
_ TacticParams
_ =
  Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> ResponseError
mkErr ErrorCode
InvalidRequest Text
"Bad URI"


timingOut
    :: Int                     -- ^ Time in microseconds
    -> Either ResponseError a  -- ^ Computation to run
    -> MaybeT IO (Either ResponseError a)
timingOut :: Int -> Either ResponseError a -> MaybeT IO (Either ResponseError a)
timingOut Int
t Either ResponseError a
m = do
  Maybe (Either ResponseError a)
x <- IO (Maybe (Either ResponseError a))
-> MaybeT IO (Maybe (Either ResponseError a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe (Either ResponseError a))
 -> MaybeT IO (Maybe (Either ResponseError a)))
-> IO (Maybe (Either ResponseError a))
-> MaybeT IO (Maybe (Either ResponseError a))
forall a b. (a -> b) -> a -> b
$ Int
-> IO (Either ResponseError a)
-> IO (Maybe (Either ResponseError a))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t (IO (Either ResponseError a)
 -> IO (Maybe (Either ResponseError a)))
-> IO (Either ResponseError a)
-> IO (Maybe (Either ResponseError a))
forall a b. (a -> b) -> a -> b
$ Either ResponseError a -> IO (Either ResponseError a)
forall a. a -> IO a
evaluate Either ResponseError a
m
  Either ResponseError a -> MaybeT IO (Either ResponseError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError a -> MaybeT IO (Either ResponseError a))
-> Either ResponseError a -> MaybeT IO (Either ResponseError a)
forall a b. (a -> b) -> a -> b
$ ResponseError
-> Maybe (Either ResponseError a) -> Either ResponseError a
forall e a. e -> Maybe (Either e a) -> Either e a
joinNote (ErrorCode -> Text -> ResponseError
mkErr ErrorCode
InvalidRequest Text
"timed out") Maybe (Either ResponseError a)
x


mkErr :: ErrorCode -> T.Text -> ResponseError
mkErr :: ErrorCode -> Text -> ResponseError
mkErr ErrorCode
code Text
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
code Text
err Maybe Value
forall a. Maybe a
Nothing


joinNote :: e -> Maybe (Either e a) -> Either e a
joinNote :: e -> Maybe (Either e a) -> Either e a
joinNote e
e Maybe (Either e a)
Nothing  = e -> Either e a
forall a b. a -> Either a b
Left e
e
joinNote e
_ (Just Either e a
a) = Either e a
a


------------------------------------------------------------------------------
-- | Turn a 'RunTacticResults' into concrete edits to make in the source
-- document.
mkWorkspaceEdits
    :: RealSrcSpan
    -> DynFlags
    -> ClientCapabilities
    -> Uri
    -> Annotated ParsedSource
    -> RunTacticResults
    -> Either ResponseError (Maybe WorkspaceEdit)
mkWorkspaceEdits :: RealSrcSpan
-> DynFlags
-> ClientCapabilities
-> Uri
-> Annotated ParsedSource
-> RunTacticResults
-> Either ResponseError (Maybe WorkspaceEdit)
mkWorkspaceEdits RealSrcSpan
span DynFlags
dflags ClientCapabilities
ccs Uri
uri Annotated ParsedSource
pm RunTacticResults
rtr = do
  let g :: Graft (Either String) ParsedSource
g = SrcSpan -> RunTacticResults -> Graft (Either String) ParsedSource
graftHole (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
span) RunTacticResults
rtr
      response :: Either String WorkspaceEdit
response = DynFlags
-> ClientCapabilities
-> Uri
-> Graft (Either String) ParsedSource
-> Annotated ParsedSource
-> Either String WorkspaceEdit
transform DynFlags
dflags ClientCapabilities
ccs Uri
uri Graft (Either String) ParsedSource
g Annotated ParsedSource
pm
   in case Either String WorkspaceEdit
response of
        Right WorkspaceEdit
res -> Maybe WorkspaceEdit -> Either ResponseError (Maybe WorkspaceEdit)
forall a b. b -> Either a b
Right (Maybe WorkspaceEdit -> Either ResponseError (Maybe WorkspaceEdit))
-> Maybe WorkspaceEdit
-> Either ResponseError (Maybe WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ WorkspaceEdit -> Maybe WorkspaceEdit
forall a. a -> Maybe a
Just WorkspaceEdit
res
        Left String
err  -> ResponseError -> Either ResponseError (Maybe WorkspaceEdit)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (Maybe WorkspaceEdit))
-> ResponseError -> Either ResponseError (Maybe WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> ResponseError
mkErr ErrorCode
InternalError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err


------------------------------------------------------------------------------
-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly
-- deals with top-level holes, in which we might need to fiddle with the
-- 'Match's that bind variables.
graftHole
    :: SrcSpan
    -> RunTacticResults
    -> Graft (Either String) ParsedSource
graftHole :: SrcSpan -> RunTacticResults -> Graft (Either String) ParsedSource
graftHole SrcSpan
span RunTacticResults
rtr
  | Judgement -> Bool
forall a. Judgement' a -> Bool
_jIsTopHole (RunTacticResults -> Judgement
rtr_jdg RunTacticResults
rtr)
      = SrcSpan
-> (LHsDecl GhcPs
    -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> Graft (Either String) ParsedSource
forall a.
HasDecls a =>
SrcSpan
-> (LHsDecl GhcPs
    -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> Graft (Either String) a
graftSmallestDeclsWithM SrcSpan
span
      ((LHsDecl GhcPs
  -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
 -> Graft (Either String) ParsedSource)
-> (LHsDecl GhcPs
    -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> Graft (Either String) ParsedSource
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> ([Pat GhcPs] -> LHsDecl GhcPs)
-> LHsDecl GhcPs
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
graftDecl SrcSpan
span (([Pat GhcPs] -> LHsDecl GhcPs)
 -> LHsDecl GhcPs
 -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> ([Pat GhcPs] -> LHsDecl GhcPs)
-> LHsDecl GhcPs
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ \[Pat GhcPs]
pats ->
        OccName -> [AgdaMatch] -> LHsDecl GhcPs
splitToDecl ((OccName, CType) -> OccName
forall a b. (a, b) -> a
fst ((OccName, CType) -> OccName) -> (OccName, CType) -> OccName
forall a b. (a -> b) -> a -> b
$ [(OccName, CType)] -> (OccName, CType)
forall a. [a] -> a
last ([(OccName, CType)] -> (OccName, CType))
-> [(OccName, CType)] -> (OccName, CType)
forall a b. (a -> b) -> a -> b
$ Context -> [(OccName, CType)]
ctxDefiningFuncs (Context -> [(OccName, CType)]) -> Context -> [(OccName, CType)]
forall a b. (a -> b) -> a -> b
$ RunTacticResults -> Context
rtr_ctx RunTacticResults
rtr)
      ([AgdaMatch] -> LHsDecl GhcPs) -> [AgdaMatch] -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ AgdaMatch -> [AgdaMatch]
iterateSplit
      (AgdaMatch -> [AgdaMatch]) -> AgdaMatch -> [AgdaMatch]
forall a b. (a -> b) -> a -> b
$ [Pat GhcPs] -> HsExpr GhcPs -> AgdaMatch
mkFirstAgda ((Pat GhcPs -> Pat GhcPs) -> [Pat GhcPs] -> [Pat GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat GhcPs -> Pat GhcPs
unXPat [Pat GhcPs]
pats)
      (HsExpr GhcPs -> AgdaMatch) -> HsExpr GhcPs -> AgdaMatch
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
      (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs))
-> LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ RunTacticResults -> LHsExpr GhcPs
rtr_extract RunTacticResults
rtr
graftHole SrcSpan
span RunTacticResults
rtr
  = SrcSpan -> LHsExpr GhcPs -> Graft (Either String) ParsedSource
forall ast a.
(Data a, ASTElement ast) =>
SrcSpan -> Located ast -> Graft (Either String) a
graftWithoutParentheses SrcSpan
span
    -- Parenthesize the extract iff we're not in a top level hole
  (LHsExpr GhcPs -> Graft (Either String) ParsedSource)
-> LHsExpr GhcPs -> Graft (Either String) ParsedSource
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall a. a -> a -> Bool -> a
bool LHsExpr GhcPs -> LHsExpr GhcPs
forall ast. ASTElement ast => Located ast -> Located ast
maybeParensAST LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id (Judgement -> Bool
forall a. Judgement' a -> Bool
_jIsTopHole (Judgement -> Bool) -> Judgement -> Bool
forall a b. (a -> b) -> a -> b
$ RunTacticResults -> Judgement
rtr_jdg RunTacticResults
rtr)
  (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RunTacticResults -> LHsExpr GhcPs
rtr_extract RunTacticResults
rtr


------------------------------------------------------------------------------
-- | Merge in the 'Match'es of a 'FunBind' into a 'HsDecl'. Used to perform
-- agda-style case splitting in which we need to separate one 'Match' into
-- many, without affecting any matches which might exist but don't need to be
-- split.
mergeFunBindMatches
    :: ([Pat GhcPs] -> LHsDecl GhcPs)
    -> SrcSpan
    -> HsBind GhcPs
    -> Either String (HsBind GhcPs)
mergeFunBindMatches :: ([Pat GhcPs] -> LHsDecl GhcPs)
-> SrcSpan -> HsBind GhcPs -> Either String (HsBind GhcPs)
mergeFunBindMatches [Pat GhcPs] -> LHsDecl GhcPs
make_decl SrcSpan
span
    (fb :: HsBind GhcPs
fb@FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg@MG {mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
alts_src [LMatch GhcPs (LHsExpr GhcPs)]
alts}}) =
  HsBind GhcPs -> Either String (HsBind GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsBind GhcPs -> Either String (HsBind GhcPs))
-> HsBind GhcPs -> Either String (HsBind GhcPs)
forall a b. (a -> b) -> a -> b
$ HsBind GhcPs
fb
    { fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = MatchGroup GhcPs (LHsExpr GhcPs)
mg
      { mg_alts :: GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = SrcSpan
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
alts_src ([LMatch GhcPs (LHsExpr GhcPs)]
 -> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ do
          alt :: LMatch GhcPs (LHsExpr GhcPs)
alt@(L SrcSpan
alt_src Match GhcPs (LHsExpr GhcPs)
match) <- [LMatch GhcPs (LHsExpr GhcPs)]
alts
          case SrcSpan
span SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
alt_src of
            Bool
True -> do
              let pats :: [Pat GhcPs]
pats = (Located (Pat GhcPs) -> Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Pat GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatCompat GhcPs -> Pat GhcPs
Located (Pat GhcPs) -> Pat GhcPs
fromPatCompatPs ([Located (Pat GhcPs)] -> [Pat GhcPs])
-> [Located (Pat GhcPs)] -> [Pat GhcPs]
forall a b. (a -> b) -> a -> b
$ Match GhcPs (LHsExpr GhcPs) -> [PatCompat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (LHsExpr GhcPs)
match
                  L SrcSpan
_ (ValD XValD GhcPs
_ (FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MG
                        {mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
to_add}})) = [Pat GhcPs] -> LHsDecl GhcPs
make_decl [Pat GhcPs]
pats
              [LMatch GhcPs (LHsExpr GhcPs)]
to_add
            Bool
False -> LMatch GhcPs (LHsExpr GhcPs) -> [LMatch GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure LMatch GhcPs (LHsExpr GhcPs)
alt
      }
    }
mergeFunBindMatches [Pat GhcPs] -> LHsDecl GhcPs
_ SrcSpan
_ HsBind GhcPs
_ =
  String -> Either String (HsBind GhcPs)
forall a b. a -> Either a b
Left String
"mergeFunBindMatches: called on something that isnt a funbind"


throwError :: String -> TransformT (Either String) a
throwError :: String -> TransformT (Either String) a
throwError = Either String a -> TransformT (Either String) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String a -> TransformT (Either String) a)
-> (String -> Either String a)
-> String
-> TransformT (Either String) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left


------------------------------------------------------------------------------
-- | Helper function to route 'mergeFunBindMatches' into the right place in an
-- AST --- correctly dealing with inserting into instance declarations.
graftDecl
    :: SrcSpan
    -> ([Pat GhcPs] -> LHsDecl GhcPs)
    -> LHsDecl GhcPs
    -> TransformT (Either String) (Maybe [LHsDecl GhcPs])
graftDecl :: SrcSpan
-> ([Pat GhcPs] -> LHsDecl GhcPs)
-> LHsDecl GhcPs
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
graftDecl SrcSpan
span
    [Pat GhcPs] -> LHsDecl GhcPs
make_decl
    (L SrcSpan
src (ValD XValD GhcPs
ext HsBind GhcPs
fb))
  = (String -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> (HsBind GhcPs
    -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> Either String (HsBind GhcPs)
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall a. String -> TransformT (Either String) a
throwError (Maybe [LHsDecl GhcPs]
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [LHsDecl GhcPs]
 -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> (HsBind GhcPs -> Maybe [LHsDecl GhcPs])
-> HsBind GhcPs
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsDecl GhcPs] -> Maybe [LHsDecl GhcPs]
forall a. a -> Maybe a
Just ([LHsDecl GhcPs] -> Maybe [LHsDecl GhcPs])
-> (HsBind GhcPs -> [LHsDecl GhcPs])
-> HsBind GhcPs
-> Maybe [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDecl GhcPs -> [LHsDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsDecl GhcPs -> [LHsDecl GhcPs])
-> (HsBind GhcPs -> LHsDecl GhcPs)
-> HsBind GhcPs
-> [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
src (HsDecl GhcPs -> LHsDecl GhcPs)
-> (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> LHsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
ext) (Either String (HsBind GhcPs)
 -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> Either String (HsBind GhcPs)
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$
      ([Pat GhcPs] -> LHsDecl GhcPs)
-> SrcSpan -> HsBind GhcPs -> Either String (HsBind GhcPs)
mergeFunBindMatches [Pat GhcPs] -> LHsDecl GhcPs
make_decl SrcSpan
span HsBind GhcPs
fb
-- TODO(sandy): add another case for default methods in class definitions
graftDecl SrcSpan
span
    [Pat GhcPs] -> LHsDecl GhcPs
make_decl
    (L SrcSpan
src (InstD XInstD GhcPs
ext
      cid :: InstDecl GhcPs
cid@ClsInstD{cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst =
        cidi :: ClsInstDecl GhcPs
cidi@ClsInstDecl{cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig GhcPs]
_sigs, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds GhcPs
binds}}))
  = do
      [GenLocated SrcSpan (HsBind GhcPs)]
binds' <-
        [GenLocated SrcSpan (HsBind GhcPs)]
-> (GenLocated SrcSpan (HsBind GhcPs)
    -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
-> TransformT (Either String) [GenLocated SrcSpan (HsBind GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (LHsBinds GhcPs -> [GenLocated SrcSpan (HsBind GhcPs)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcPs
binds) ((GenLocated SrcSpan (HsBind GhcPs)
  -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
 -> TransformT (Either String) [GenLocated SrcSpan (HsBind GhcPs)])
-> (GenLocated SrcSpan (HsBind GhcPs)
    -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
-> TransformT (Either String) [GenLocated SrcSpan (HsBind GhcPs)]
forall a b. (a -> b) -> a -> b
$ \b :: GenLocated SrcSpan (HsBind GhcPs)
b@(L SrcSpan
bsrc HsBind GhcPs
bind) -> do
          case HsBind GhcPs
bind of
            fb :: HsBind GhcPs
fb@FunBind{} | SrcSpan
span SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
bsrc ->
              (String
 -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
-> (HsBind GhcPs
    -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
-> Either String (HsBind GhcPs)
-> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String
-> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs))
forall a. String -> TransformT (Either String) a
throwError (GenLocated SrcSpan (HsBind GhcPs)
-> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpan (HsBind GhcPs)
 -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
-> (HsBind GhcPs -> GenLocated SrcSpan (HsBind GhcPs))
-> HsBind GhcPs
-> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsBind GhcPs -> GenLocated SrcSpan (HsBind GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
bsrc) (Either String (HsBind GhcPs)
 -> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs)))
-> Either String (HsBind GhcPs)
-> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs))
forall a b. (a -> b) -> a -> b
$
                ([Pat GhcPs] -> LHsDecl GhcPs)
-> SrcSpan -> HsBind GhcPs -> Either String (HsBind GhcPs)
mergeFunBindMatches [Pat GhcPs] -> LHsDecl GhcPs
make_decl SrcSpan
span HsBind GhcPs
fb
            HsBind GhcPs
_ -> GenLocated SrcSpan (HsBind GhcPs)
-> TransformT (Either String) (GenLocated SrcSpan (HsBind GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpan (HsBind GhcPs)
b

      Maybe [LHsDecl GhcPs]
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [LHsDecl GhcPs]
 -> TransformT (Either String) (Maybe [LHsDecl GhcPs]))
-> Maybe [LHsDecl GhcPs]
-> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ [LHsDecl GhcPs] -> Maybe [LHsDecl GhcPs]
forall a. a -> Maybe a
Just ([LHsDecl GhcPs] -> Maybe [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> Maybe [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> [LHsDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsDecl GhcPs -> [LHsDecl GhcPs])
-> LHsDecl GhcPs -> [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
src (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
ext (InstDecl GhcPs -> HsDecl GhcPs) -> InstDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ InstDecl GhcPs
cid
        { cid_inst :: ClsInstDecl GhcPs
cid_inst = ClsInstDecl GhcPs
cidi
          { cid_binds :: LHsBinds GhcPs
cid_binds = [GenLocated SrcSpan (HsBind GhcPs)] -> LHsBinds GhcPs
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpan (HsBind GhcPs)]
binds'
          }
        }
graftDecl SrcSpan
span [Pat GhcPs] -> LHsDecl GhcPs
_ LHsDecl GhcPs
x = do
  String -> String -> TransformT (Either String) ()
forall (m :: * -> *) a. (Monad m, Show a) => String -> a -> m ()
traceMX String
"biggest" (String -> TransformT (Either String) ())
-> String -> TransformT (Either String) ()
forall a b. (a -> b) -> a -> b
$
    Maybe (Match GhcPs (LHsExpr GhcPs)) -> String
forall a. Outputable a => a -> String
unsafeRender (Maybe (Match GhcPs (LHsExpr GhcPs)) -> String)
-> Maybe (Match GhcPs (LHsExpr GhcPs)) -> String
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> LHsDecl GhcPs -> Maybe (Match GhcPs (LHsExpr GhcPs))
forall r a. (Data r, Data a) => SrcSpan -> a -> Maybe r
locateBiggest @(Match GhcPs (LHsExpr GhcPs)) SrcSpan
span LHsDecl GhcPs
x
  String -> String -> TransformT (Either String) ()
forall (m :: * -> *) a. (Monad m, Show a) => String -> a -> m ()
traceMX String
"first" (String -> TransformT (Either String) ())
-> String -> TransformT (Either String) ()
forall a b. (a -> b) -> a -> b
$
    Maybe (Match GhcPs (LHsExpr GhcPs)) -> String
forall a. Outputable a => a -> String
unsafeRender (Maybe (Match GhcPs (LHsExpr GhcPs)) -> String)
-> Maybe (Match GhcPs (LHsExpr GhcPs)) -> String
forall a b. (a -> b) -> a -> b
$
      LHsDecl GhcPs -> Maybe (Match GhcPs (LHsExpr GhcPs))
forall r a. (Data r, Data a) => a -> Maybe r
locateFirst @(Match GhcPs (LHsExpr GhcPs)) LHsDecl GhcPs
x
  String -> TransformT (Either String) (Maybe [LHsDecl GhcPs])
forall a. String -> TransformT (Either String) a
throwError String
"graftDecl: don't know about this AST form"


fromMaybeT :: Functor m => a -> MaybeT m a -> m a
fromMaybeT :: a -> MaybeT m a -> m a
fromMaybeT a
def = (Maybe a -> a) -> m (Maybe a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def) (m (Maybe a) -> m a)
-> (MaybeT m a -> m (Maybe a)) -> MaybeT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT


locateBiggest :: (Data r, Data a) => SrcSpan -> a -> Maybe r
locateBiggest :: SrcSpan -> a -> Maybe r
locateBiggest SrcSpan
ss a
x = First r -> Maybe r
forall a. First a -> Maybe a
getFirst (First r -> Maybe r) -> First r -> Maybe r
forall a b. (a -> b) -> a -> b
$ (First r -> First r -> First r)
-> GenericQ (First r) -> a -> First r
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything First r -> First r -> First r
forall a. Semigroup a => a -> a -> a
(<>)
  ( First r -> (GenLocated SrcSpan r -> First r) -> a -> First r
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ First r
forall a. Monoid a => a
mempty ((GenLocated SrcSpan r -> First r) -> a -> First r)
-> (GenLocated SrcSpan r -> First r) -> a -> First r
forall a b. (a -> b) -> a -> b
$ \case
    L SrcSpan
span r
r | SrcSpan
ss SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
span -> r -> First r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    GenLocated SrcSpan r
_                                -> First r
forall a. Monoid a => a
mempty
  ) a
x


locateFirst :: (Data r, Data a) => a -> Maybe r
locateFirst :: a -> Maybe r
locateFirst a
x = First r -> Maybe r
forall a. First a -> Maybe a
getFirst (First r -> Maybe r) -> First r -> Maybe r
forall a b. (a -> b) -> a -> b
$ (First r -> First r -> First r)
-> GenericQ (First r) -> a -> First r
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything First r -> First r -> First r
forall a. Semigroup a => a -> a -> a
(<>)
  ( First r -> (r -> First r) -> a -> First r
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ First r
forall a. Monoid a => a
mempty ((r -> First r) -> a -> First r) -> (r -> First r) -> a -> First r
forall a b. (a -> b) -> a -> b
$ \case
    r
r -> r -> First r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
  ) a
x