{-# LANGUAGE OverloadedStrings #-}

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

import           Control.Exception (evaluate)
import           Control.Monad
import           Control.Monad.Trans
import           Control.Monad.Trans.Maybe
import           Data.Aeson
import           Data.Bifunctor (first)
import           Data.Data
import           Data.Foldable (for_)
import           Data.Maybe
import qualified Data.Text as T
import           Development.IDE.Core.Shake (IdeState (..))
import           Development.IDE.Core.UseStale (Tracked, TrackedStale(..), unTrack, mapAgeFrom, unsafeMkCurrent)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.ExactPrint
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
import           Wingman.CaseSplit
import           Wingman.GHC
import           Wingman.LanguageServer
import           Wingman.LanguageServer.TacticProviders
import           Wingman.Machinery (scoreSolution)
import           Wingman.Range
import           Wingman.Tactics
import           Wingman.Types


descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> PluginDescriptor IdeState
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 ())
-> PluginId -> CommandFunction IdeState TacticParams
tacticCmd (TacticCommand -> OccName -> TacticsM ()
commandTactic TacticCommand
tc) PluginId
plId))
            [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
  , pluginRules :: Rules ()
pluginRules = PluginId -> Rules ()
wingmanRules PluginId
plId
  , pluginCustomConfig :: CustomConfig
pluginCustomConfig =
      Properties
  '[ 'PropertyKey
       "hole_severity" ('TEnum (Maybe DiagnosticSeverity)),
     'PropertyKey "max_use_ctor_actions" 'TInteger,
     'PropertyKey "features" 'TString,
     'PropertyKey "timeout_duration" 'TInteger]
-> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties
  '[ 'PropertyKey
       "hole_severity" ('TEnum (Maybe DiagnosticSeverity)),
     'PropertyKey "max_use_ctor_actions" 'TInteger,
     'PropertyKey "features" 'TString,
     'PropertyKey "timeout_duration" 'TInteger]
properties
  }


codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
state PluginId
plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (unsafeMkCurrent -> 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
      Config
cfg <- PluginId -> LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => PluginId -> m Config
getTacticConfig PluginId
plId
      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
        (Tracked 'Current Range
_, Judgement
jdg, Context
_, DynFlags
dflags) <- IdeState
-> NormalizedFilePath
-> Tracked 'Current Range
-> FeatureSet
-> MaybeT IO (Tracked 'Current Range, Judgement, Context, DynFlags)
judgementForHole IdeState
state NormalizedFilePath
nfp Tracked 'Current Range
range (FeatureSet
 -> MaybeT
      IO (Tracked 'Current Range, Judgement, Context, DynFlags))
-> FeatureSet
-> MaybeT IO (Tracked 'Current Range, Judgement, Context, DynFlags)
forall a b. (a -> b) -> a -> b
$ Config -> FeatureSet
cfg_feature_set Config
cfg
        [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] TacticProvider -> TacticProvider
forall a b. (a -> b) -> a -> b
$ TacticProviderData :: DynFlags
-> Config
-> PluginId
-> Uri
-> Tracked 'Current Range
-> Judgement
-> TacticProviderData
TacticProviderData
            { tpd_dflags :: DynFlags
tpd_dflags = DynFlags
dflags
            , tpd_config :: Config
tpd_config = Config
cfg
            , tpd_plid :: PluginId
tpd_plid   = PluginId
plId
            , tpd_uri :: Uri
tpd_uri    = Uri
uri
            , tpd_range :: Tracked 'Current Range
tpd_range  = Tracked 'Current Range
range
            , tpd_jdg :: Judgement
tpd_jdg    = 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 []


showUserFacingMessage
    :: MonadLsp cfg m
    => UserFacingMessage
    -> m (Either ResponseError a)
showUserFacingMessage :: UserFacingMessage -> m (Either ResponseError a)
showUserFacingMessage UserFacingMessage
ufm = do
  ShowMessageParams -> m ()
forall cfg (m :: * -> *).
MonadLsp cfg m =>
ShowMessageParams -> m ()
showLspMessage (ShowMessageParams -> m ()) -> ShowMessageParams -> m ()
forall a b. (a -> b) -> a -> b
$ UserFacingMessage -> ShowMessageParams
mkShowMessageParams UserFacingMessage
ufm
  Either ResponseError a -> m (Either ResponseError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError a -> m (Either ResponseError a))
-> Either ResponseError a -> m (Either ResponseError a)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError a
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError a)
-> ResponseError -> Either ResponseError a
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 -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UserFacingMessage -> String
forall a. Show a => a -> String
show UserFacingMessage
ufm


tacticCmd :: (OccName -> TacticsM ()) -> PluginId -> CommandFunction IdeState TacticParams
tacticCmd :: (OccName -> TacticsM ())
-> PluginId -> CommandFunction IdeState TacticParams
tacticCmd OccName -> TacticsM ()
tac PluginId
pId IdeState
state (TacticParams Uri
uri Tracked 'Current 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 <- PluginId -> LspT Config IO FeatureSet
forall (m :: * -> *). MonadLsp Config m => PluginId -> m FeatureSet
getFeatureSet PluginId
pId
      ClientCapabilities
ccs <- LspT Config IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
      Config
cfg <- PluginId -> LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => PluginId -> m Config
getTacticConfig PluginId
pId
      Maybe (Either UserFacingMessage WorkspaceEdit)
res <- IO (Maybe (Either UserFacingMessage WorkspaceEdit))
-> LspT Config IO (Maybe (Either UserFacingMessage WorkspaceEdit))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either UserFacingMessage WorkspaceEdit))
 -> LspT Config IO (Maybe (Either UserFacingMessage WorkspaceEdit)))
-> IO (Maybe (Either UserFacingMessage WorkspaceEdit))
-> LspT Config IO (Maybe (Either UserFacingMessage WorkspaceEdit))
forall a b. (a -> b) -> a -> b
$ MaybeT IO (Either UserFacingMessage WorkspaceEdit)
-> IO (Maybe (Either UserFacingMessage WorkspaceEdit))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (Either UserFacingMessage WorkspaceEdit)
 -> IO (Maybe (Either UserFacingMessage WorkspaceEdit)))
-> MaybeT IO (Either UserFacingMessage WorkspaceEdit)
-> IO (Maybe (Either UserFacingMessage WorkspaceEdit))
forall a b. (a -> b) -> a -> b
$ do
        (Tracked 'Current Range
range', Judgement
jdg, Context
ctx, DynFlags
dflags) <- IdeState
-> NormalizedFilePath
-> Tracked 'Current Range
-> FeatureSet
-> MaybeT IO (Tracked 'Current Range, Judgement, Context, DynFlags)
judgementForHole IdeState
state NormalizedFilePath
nfp Tracked 'Current Range
range FeatureSet
features
        let span :: Tracked 'Current RealSrcSpan
span = (Range -> RealSrcSpan)
-> Tracked 'Current Range -> Tracked 'Current RealSrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Range -> RealSrcSpan
rangeToRealSrcSpan (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp)) Tracked 'Current Range
range'
        TrackedStale Tracked ('Stale s) (Annotated ParsedSource)
pm PositionMap ('Stale s) 'Current
pmmap <- IdeState
-> NormalizedFilePath
-> GetAnnotatedParsedSource
-> MaybeT IO (TrackedStale (Annotated ParsedSource))
forall a r.
(r ~ RuleResult a, Eq a, Hashable a, Binary a, Show a, Typeable a,
 NFData a, Show r, Typeable r, NFData r) =>
IdeState -> NormalizedFilePath -> a -> MaybeT IO (TrackedStale r)
runStaleIde IdeState
state NormalizedFilePath
nfp GetAnnotatedParsedSource
GetAnnotatedParsedSource
        Tracked ('Stale s) RealSrcSpan
pm_span <- Maybe (Tracked ('Stale s) RealSrcSpan)
-> MaybeT IO (Tracked ('Stale s) RealSrcSpan)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe (Tracked ('Stale s) RealSrcSpan)
 -> MaybeT IO (Tracked ('Stale s) RealSrcSpan))
-> Maybe (Tracked ('Stale s) RealSrcSpan)
-> MaybeT IO (Tracked ('Stale s) RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ PositionMap ('Stale s) 'Current
-> Tracked 'Current RealSrcSpan
-> Maybe (Tracked ('Stale s) RealSrcSpan)
forall a (from :: Age) (to :: Age).
MapAge a =>
PositionMap from to -> Tracked to a -> Maybe (Tracked from a)
mapAgeFrom PositionMap ('Stale s) 'Current
pmmap Tracked 'Current RealSrcSpan
span

        Int
-> Either UserFacingMessage WorkspaceEdit
-> MaybeT IO (Either UserFacingMessage WorkspaceEdit)
forall a. Int -> a -> MaybeT IO a
timingOut (Config -> Int
cfg_timeout_seconds Config
cfg Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
seconds) (Either UserFacingMessage WorkspaceEdit
 -> MaybeT IO (Either UserFacingMessage WorkspaceEdit))
-> Either UserFacingMessage WorkspaceEdit
-> MaybeT IO (Either UserFacingMessage WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ Either UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
-> Either UserFacingMessage WorkspaceEdit
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
 -> Either UserFacingMessage WorkspaceEdit)
-> Either
     UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
-> Either UserFacingMessage WorkspaceEdit
forall a b. (a -> b) -> a -> b
$
          case 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 of
            Left [TacticError]
_ -> UserFacingMessage
-> Either
     UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
forall a b. a -> Either a b
Left UserFacingMessage
TacticErrors
            Right RunTacticResults
rtr ->
              case RunTacticResults -> LHsExpr GhcPs
rtr_extract RunTacticResults
rtr of
                L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
rdr)) | OccName -> Bool
isHole (RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName IdP GhcPs
RdrName
rdr) ->
                  UserFacingMessage
-> Either
     UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
forall a b. a -> Either a b
Left UserFacingMessage
NothingToDo
                LHsExpr GhcPs
_ -> Either UserFacingMessage WorkspaceEdit
-> Either
     UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UserFacingMessage WorkspaceEdit
 -> Either
      UserFacingMessage (Either UserFacingMessage WorkspaceEdit))
-> Either UserFacingMessage WorkspaceEdit
-> Either
     UserFacingMessage (Either UserFacingMessage WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ Tracked ('Stale s) RealSrcSpan
-> DynFlags
-> ClientCapabilities
-> Uri
-> Tracked ('Stale s) (Annotated ParsedSource)
-> RunTacticResults
-> Either UserFacingMessage WorkspaceEdit
forall (age :: Age).
Tracked age RealSrcSpan
-> DynFlags
-> ClientCapabilities
-> Uri
-> Tracked age (Annotated ParsedSource)
-> RunTacticResults
-> Either UserFacingMessage WorkspaceEdit
mkWorkspaceEdits Tracked ('Stale s) RealSrcSpan
pm_span DynFlags
dflags ClientCapabilities
ccs Uri
uri Tracked ('Stale s) (Annotated ParsedSource)
pm RunTacticResults
rtr

      case Maybe (Either UserFacingMessage WorkspaceEdit)
res of
        Maybe (Either UserFacingMessage WorkspaceEdit)
Nothing -> do
          UserFacingMessage -> LspM Config (Either ResponseError Value)
forall cfg (m :: * -> *) a.
MonadLsp cfg m =>
UserFacingMessage -> m (Either ResponseError a)
showUserFacingMessage UserFacingMessage
TimedOut
        Just (Left UserFacingMessage
ufm) -> do
          UserFacingMessage -> LspM Config (Either ResponseError Value)
forall cfg (m :: * -> *) a.
MonadLsp cfg m =>
UserFacingMessage -> m (Either ResponseError a)
showUserFacingMessage UserFacingMessage
ufm
        Just (Right WorkspaceEdit
edit) -> do
          LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
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 ()
_ PluginId
_ 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"


------------------------------------------------------------------------------
-- | The number of microseconds in a second
seconds :: Num a => a
seconds :: a
seconds = a
1e6


timingOut
    :: Int  -- ^ Time in microseconds
    -> a    -- ^ Computation to run
    -> MaybeT IO a
timingOut :: Int -> a -> MaybeT IO a
timingOut Int
t a
m = IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe a) -> MaybeT IO a) -> IO (Maybe a) -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$ Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate a
m


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


------------------------------------------------------------------------------
-- | Turn a 'RunTacticResults' into concrete edits to make in the source
-- document.
mkWorkspaceEdits
    :: Tracked age RealSrcSpan
    -> DynFlags
    -> ClientCapabilities
    -> Uri
    -> Tracked age (Annotated ParsedSource)
    -> RunTacticResults
    -> Either UserFacingMessage WorkspaceEdit
mkWorkspaceEdits :: Tracked age RealSrcSpan
-> DynFlags
-> ClientCapabilities
-> Uri
-> Tracked age (Annotated ParsedSource)
-> RunTacticResults
-> Either UserFacingMessage WorkspaceEdit
mkWorkspaceEdits (Tracked age RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack -> RealSrcSpan
span) DynFlags
dflags ClientCapabilities
ccs Uri
uri (Tracked age (Annotated ParsedSource) -> Annotated ParsedSource
forall (age :: Age) a. Tracked age a -> a
unTrack -> Annotated ParsedSource
pm) RunTacticResults
rtr = do
  [Synthesized (LHsExpr GhcPs)]
-> (Synthesized (LHsExpr GhcPs) -> Either UserFacingMessage ())
-> Either UserFacingMessage ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (RunTacticResults -> [Synthesized (LHsExpr GhcPs)]
rtr_other_solns RunTacticResults
rtr) ((Synthesized (LHsExpr GhcPs) -> Either UserFacingMessage ())
 -> Either UserFacingMessage ())
-> (Synthesized (LHsExpr GhcPs) -> Either UserFacingMessage ())
-> Either UserFacingMessage ()
forall a b. (a -> b) -> a -> b
$ \Synthesized (LHsExpr GhcPs)
soln -> do
    String -> LHsExpr GhcPs -> Either UserFacingMessage ()
forall (m :: * -> *) a. (Monad m, Show a) => String -> a -> m ()
traceMX String
"other solution" (LHsExpr GhcPs -> Either UserFacingMessage ())
-> LHsExpr GhcPs -> Either UserFacingMessage ()
forall a b. (a -> b) -> a -> b
$ Synthesized (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. Synthesized a -> a
syn_val Synthesized (LHsExpr GhcPs)
soln
    String
-> (Penalize Int, Reward Bool, Penalize Int, Penalize Int,
    Reward Int, Penalize Int, Penalize Int)
-> Either UserFacingMessage ()
forall (m :: * -> *) a. (Monad m, Show a) => String -> a -> m ()
traceMX String
"with score" ((Penalize Int, Reward Bool, Penalize Int, Penalize Int,
  Reward Int, Penalize Int, Penalize Int)
 -> Either UserFacingMessage ())
-> (Penalize Int, Reward Bool, Penalize Int, Penalize Int,
    Reward Int, Penalize Int, Penalize Int)
-> Either UserFacingMessage ()
forall a b. (a -> b) -> a -> b
$ Synthesized (LHsExpr GhcPs)
-> Judgement
-> [Judgement]
-> (Penalize Int, Reward Bool, Penalize Int, Penalize Int,
    Reward Int, Penalize Int, Penalize Int)
scoreSolution Synthesized (LHsExpr GhcPs)
soln (RunTacticResults -> Judgement
rtr_jdg RunTacticResults
rtr) []
  String -> LHsExpr GhcPs -> Either UserFacingMessage ()
forall (m :: * -> *) a. (Monad m, Show a) => String -> a -> m ()
traceMX String
"solution" (LHsExpr GhcPs -> Either UserFacingMessage ())
-> LHsExpr GhcPs -> Either UserFacingMessage ()
forall a b. (a -> b) -> a -> b
$ RunTacticResults -> LHsExpr GhcPs
rtr_extract RunTacticResults
rtr
  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 (String -> UserFacingMessage)
-> Either String WorkspaceEdit
-> Either UserFacingMessage WorkspaceEdit
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> UserFacingMessage
InfrastructureError (Text -> UserFacingMessage)
-> (String -> Text) -> String -> UserFacingMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) Either String WorkspaceEdit
response


------------------------------------------------------------------------------
-- | 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)
      = Proxy (Located [LMatch GhcPs (LHsExpr GhcPs)])
-> SrcSpan
-> (DynFlags -> GenericM (TransformT (Either String)))
-> Graft (Either String) ParsedSource
forall (m :: * -> *) a ast.
(Monad m, Data a, Typeable ast) =>
Proxy (Located ast)
-> SrcSpan -> (DynFlags -> GenericM (TransformT m)) -> Graft m a
genericGraftWithSmallestM (Proxy (Located [LMatch GhcPs (LHsExpr GhcPs)])
forall k (t :: k). Proxy t
Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) SrcSpan
span ((DynFlags -> GenericM (TransformT (Either String)))
 -> Graft (Either String) ParsedSource)
-> (DynFlags -> GenericM (TransformT (Either String)))
-> Graft (Either String) ParsedSource
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
        GenericM (TransformT (Either String))
-> GenericM (TransformT (Either String))
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM'
          (GenericM (TransformT (Either String))
 -> GenericM (TransformT (Either String)))
-> GenericM (TransformT (Either String))
-> GenericM (TransformT (Either String))
forall a b. (a -> b) -> a -> b
$ (Int
 -> LMatch GhcPs (LHsExpr GhcPs)
 -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)])
-> GenericM (TransformT (Either String))
forall b (m :: * -> *).
(Data b, Monad m) =>
(Int -> b -> m [b]) -> GenericM m
mkBindListT ((Int
  -> LMatch GhcPs (LHsExpr GhcPs)
  -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)])
 -> GenericM (TransformT (Either String)))
-> (Int
    -> LMatch GhcPs (LHsExpr GhcPs)
    -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)])
-> GenericM (TransformT (Either String))
forall a b. (a -> b) -> a -> b
$ \Int
ix ->
            DynFlags
-> SrcSpan
-> Int
-> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
graftDecl DynFlags
dflags SrcSpan
span Int
ix ((RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)
 -> LMatch GhcPs (LHsExpr GhcPs)
 -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)])
-> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ \RdrName
name [Pat GhcPs]
pats ->
            OccName -> [AgdaMatch] -> LHsDecl GhcPs
splitToDecl (RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
name)
          ([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.
(ASTElement ast, Data a) =>
SrcSpan -> Located ast -> Graft (Either String) a
graft SrcSpan
span
  (LHsExpr GhcPs -> Graft (Either String) ParsedSource)
-> LHsExpr GhcPs -> Graft (Either String) ParsedSource
forall a b. (a -> b) -> a -> b
$ RunTacticResults -> LHsExpr GhcPs
rtr_extract RunTacticResults
rtr


------------------------------------------------------------------------------
-- | Helper function to route 'mergeFunBindMatches' into the right place in an
-- AST --- correctly dealing with inserting into instance declarations.
graftDecl
    :: DynFlags
    -> SrcSpan
    -> Int
    -> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)
    -> LMatch GhcPs (LHsExpr GhcPs)
    -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
graftDecl :: DynFlags
-> SrcSpan
-> Int
-> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
graftDecl DynFlags
dflags SrcSpan
dst Int
ix RdrName -> [Pat GhcPs] -> LHsDecl GhcPs
make_decl (L SrcSpan
src (AMatch (FunRhs (L SrcSpan
_ NameOrRdrName (IdP GhcPs)
name) LexicalFixity
_ SrcStrictness
_) [Pat GhcPs]
pats HsExpr GhcPs
_))
  | SrcSpan
dst SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
src = do
      L SrcSpan
_ HsDecl GhcPs
dec <- DynFlags
-> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)
annotateDecl DynFlags
dflags (LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs))
-> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ RdrName -> [Pat GhcPs] -> LHsDecl GhcPs
make_decl NameOrRdrName (IdP GhcPs)
RdrName
name [Pat GhcPs]
pats
      case HsDecl GhcPs
dec of
        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
_ alts :: [LMatch GhcPs (LHsExpr GhcPs)]
alts@(LMatch GhcPs (LHsExpr GhcPs)
first_match : [LMatch GhcPs (LHsExpr GhcPs)]
_)}
                  }) -> do
          -- For whatever reason, ExactPrint annotates newlines to the ends of
          -- case matches and type signatures, but only allows us to insert
          -- them at the beginning of those things. Thus, we need want to
          -- insert a preceeding newline (done in 'annotateDecl') on all
          -- matches, except for the first one --- since it gets its newline
          -- from the line above.
          Bool
-> TransformT (Either String) () -> TransformT (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (TransformT (Either String) () -> TransformT (Either String) ())
-> TransformT (Either String) () -> TransformT (Either String) ()
forall a b. (a -> b) -> a -> b
$
            LMatch GhcPs (LHsExpr GhcPs)
-> Int -> Int -> TransformT (Either String) ()
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> Int -> Int -> TransformT m ()
setPrecedingLinesT LMatch GhcPs (LHsExpr GhcPs)
first_match Int
0 Int
0
          [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LMatch GhcPs (LHsExpr GhcPs)]
alts
        HsDecl GhcPs
_ -> Either String [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String [LMatch GhcPs (LHsExpr GhcPs)]
 -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)])
-> Either String [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ String -> Either String [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. a -> Either a b
Left String
"annotateDecl didn't produce a funbind"
graftDecl DynFlags
_ SrcSpan
_ Int
_ RdrName -> [Pat GhcPs] -> LHsDecl GhcPs
_ LMatch GhcPs (LHsExpr GhcPs)
x = [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LMatch GhcPs (LHsExpr GhcPs)]
 -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)])
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ LMatch GhcPs (LHsExpr GhcPs) -> [LMatch GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure LMatch GhcPs (LHsExpr GhcPs)
x


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