{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Wingman.AbstractLSP.Types where

import           Control.Monad.IO.Class
import           Control.Monad.Trans.Maybe (MaybeT (MaybeT), mapMaybeT)
import qualified Data.Aeson as A
import           Data.Text (Text)
import           Development.IDE (IdeState)
import           Development.IDE.GHC.ExactPrint (Graft)
import           Development.IDE.Core.UseStale
import           Development.IDE.GHC.Compat hiding (Target)
import           GHC.Generics (Generic)
import qualified Ide.Plugin.Config as Plugin
import           Ide.Types
import           Language.LSP.Server (LspM)
import           Language.LSP.Types hiding (CodeLens, CodeAction)
import           Wingman.LanguageServer (judgementForHole)
import           Wingman.Types


------------------------------------------------------------------------------
-- | An 'Interaction' is an existential 'Continuation', which handles both
-- sides of the request/response interaction for LSP.
data Interaction where
  Interaction
      :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b)
      => Continuation sort target b
      -> Interaction


------------------------------------------------------------------------------
-- | Metadata for a command. Used by both code actions and lenses, though for
-- lenses, only 'md_title' is currently used.
data Metadata
  = Metadata
      { Metadata -> Text
md_title     :: Text
      , Metadata -> CodeActionKind
md_kind      :: CodeActionKind
      , Metadata -> Bool
md_preferred :: Bool
      }
  deriving stock (Metadata -> Metadata -> Bool
(Metadata -> Metadata -> Bool)
-> (Metadata -> Metadata -> Bool) -> Eq Metadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metadata -> Metadata -> Bool
$c/= :: Metadata -> Metadata -> Bool
== :: Metadata -> Metadata -> Bool
$c== :: Metadata -> Metadata -> Bool
Eq, Int -> Metadata -> ShowS
[Metadata] -> ShowS
Metadata -> String
(Int -> Metadata -> ShowS)
-> (Metadata -> String) -> ([Metadata] -> ShowS) -> Show Metadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metadata] -> ShowS
$cshowList :: [Metadata] -> ShowS
show :: Metadata -> String
$cshow :: Metadata -> String
showsPrec :: Int -> Metadata -> ShowS
$cshowsPrec :: Int -> Metadata -> ShowS
Show)


------------------------------------------------------------------------------
-- | Whether we're defining a CodeAction or CodeLens.
data SynthesizeCommand a b
  = SynthesizeCodeAction
      ( LspEnv
     -> TargetArgs a
     -> MaybeT (LspM Plugin.Config) [(Metadata, b)]
      )
  | SynthesizeCodeLens
      ( LspEnv
     -> TargetArgs a
     -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]
      )


------------------------------------------------------------------------------
-- | Transform a "continuation sort" into a 'CommandId'.
class IsContinuationSort a where
  toCommandId :: a -> CommandId

instance IsContinuationSort CommandId where
  toCommandId :: CommandId -> CommandId
toCommandId = CommandId -> CommandId
forall a. a -> a
id

instance IsContinuationSort Text where
  toCommandId :: Text -> CommandId
toCommandId = Text -> CommandId
CommandId


------------------------------------------------------------------------------
-- | Ways a 'Continuation' can resolve.
data ContinuationResult
  = -- | Produce some error messages.
    ErrorMessages [UserFacingMessage]
    -- | Produce an explicit 'WorkspaceEdit'.
  | RawEdit WorkspaceEdit
    -- | Produce a 'Graft', corresponding to a transformation of the current
    -- AST.
  | GraftEdit (Graft (Either String) ParsedSource)


------------------------------------------------------------------------------
-- | A 'Continuation' is a single object corresponding to an action that users
-- can take via LSP. It generalizes codeactions and codelenses, allowing for
-- a significant amount of code reuse.
--
-- Given @Continuation sort target payload@:
--
-- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions
-- rather than working directly with text. This functionality is driven via
-- 'IsContinuationSort'.
--
-- the @target@ is used to fetch data from LSP on both sides of the
-- request/response barrier. For example, you can use it to resolve what node
-- in the AST the incoming range refers to. This functionality is driven via
-- 'IsTarget'.
--
-- the @payload@ is used for data you'd explicitly like to send from the
-- request to the response. It's like @target@, but only gets computed once.
-- This is beneficial if you can do it, but requires that your data is
-- serializable via JSON.
data Continuation sort target payload = Continuation
  { Continuation sort target payload -> sort
c_sort :: sort
  , Continuation sort target payload
-> SynthesizeCommand target payload
c_makeCommand :: SynthesizeCommand target payload
  , Continuation sort target payload
-> LspEnv
-> TargetArgs target
-> FileContext
-> payload
-> MaybeT (LspM Config) [ContinuationResult]
c_runCommand
        :: LspEnv
        -> TargetArgs target
        -> FileContext
        -> payload
        -> MaybeT (LspM Plugin.Config) [ContinuationResult]
  }


------------------------------------------------------------------------------
-- | What file are we looking at, and what bit of it?
data FileContext = FileContext
  { FileContext -> Uri
fc_uri      :: Uri
  , FileContext -> Maybe (Tracked 'Current Range)
fc_range    :: Maybe (Tracked 'Current Range)
    -- ^ For code actions, this is 'Just'. For code lenses, you'll get
    -- a 'Nothing' in the request, and a 'Just' in the response.
  }
  deriving stock (FileContext -> FileContext -> Bool
(FileContext -> FileContext -> Bool)
-> (FileContext -> FileContext -> Bool) -> Eq FileContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileContext -> FileContext -> Bool
$c/= :: FileContext -> FileContext -> Bool
== :: FileContext -> FileContext -> Bool
$c== :: FileContext -> FileContext -> Bool
Eq, Eq FileContext
Eq FileContext
-> (FileContext -> FileContext -> Ordering)
-> (FileContext -> FileContext -> Bool)
-> (FileContext -> FileContext -> Bool)
-> (FileContext -> FileContext -> Bool)
-> (FileContext -> FileContext -> Bool)
-> (FileContext -> FileContext -> FileContext)
-> (FileContext -> FileContext -> FileContext)
-> Ord FileContext
FileContext -> FileContext -> Bool
FileContext -> FileContext -> Ordering
FileContext -> FileContext -> FileContext
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileContext -> FileContext -> FileContext
$cmin :: FileContext -> FileContext -> FileContext
max :: FileContext -> FileContext -> FileContext
$cmax :: FileContext -> FileContext -> FileContext
>= :: FileContext -> FileContext -> Bool
$c>= :: FileContext -> FileContext -> Bool
> :: FileContext -> FileContext -> Bool
$c> :: FileContext -> FileContext -> Bool
<= :: FileContext -> FileContext -> Bool
$c<= :: FileContext -> FileContext -> Bool
< :: FileContext -> FileContext -> Bool
$c< :: FileContext -> FileContext -> Bool
compare :: FileContext -> FileContext -> Ordering
$ccompare :: FileContext -> FileContext -> Ordering
$cp1Ord :: Eq FileContext
Ord, Int -> FileContext -> ShowS
[FileContext] -> ShowS
FileContext -> String
(Int -> FileContext -> ShowS)
-> (FileContext -> String)
-> ([FileContext] -> ShowS)
-> Show FileContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileContext] -> ShowS
$cshowList :: [FileContext] -> ShowS
show :: FileContext -> String
$cshow :: FileContext -> String
showsPrec :: Int -> FileContext -> ShowS
$cshowsPrec :: Int -> FileContext -> ShowS
Show, (forall x. FileContext -> Rep FileContext x)
-> (forall x. Rep FileContext x -> FileContext)
-> Generic FileContext
forall x. Rep FileContext x -> FileContext
forall x. FileContext -> Rep FileContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileContext x -> FileContext
$cfrom :: forall x. FileContext -> Rep FileContext x
Generic)
  deriving anyclass ([FileContext] -> Encoding
[FileContext] -> Value
FileContext -> Encoding
FileContext -> Value
(FileContext -> Value)
-> (FileContext -> Encoding)
-> ([FileContext] -> Value)
-> ([FileContext] -> Encoding)
-> ToJSON FileContext
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FileContext] -> Encoding
$ctoEncodingList :: [FileContext] -> Encoding
toJSONList :: [FileContext] -> Value
$ctoJSONList :: [FileContext] -> Value
toEncoding :: FileContext -> Encoding
$ctoEncoding :: FileContext -> Encoding
toJSON :: FileContext -> Value
$ctoJSON :: FileContext -> Value
A.ToJSON, Value -> Parser [FileContext]
Value -> Parser FileContext
(Value -> Parser FileContext)
-> (Value -> Parser [FileContext]) -> FromJSON FileContext
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FileContext]
$cparseJSONList :: Value -> Parser [FileContext]
parseJSON :: Value -> Parser FileContext
$cparseJSON :: Value -> Parser FileContext
A.FromJSON)


------------------------------------------------------------------------------
-- | Everything we need to resolve continuations.
data LspEnv = LspEnv
  { LspEnv -> IdeState
le_ideState    :: IdeState
  , LspEnv -> PluginId
le_pluginId    :: PluginId
  , LspEnv -> DynFlags
le_dflags      :: DynFlags
  , LspEnv -> Config
le_config      :: Config
  , LspEnv -> FileContext
le_fileContext :: FileContext
  }


------------------------------------------------------------------------------
-- | Extract some information from LSP, so it can be passed to the requests and
-- responses of a 'Continuation'.
class IsTarget t where
  type TargetArgs t
  fetchTargetArgs
      :: LspEnv
      -> MaybeT (LspM Plugin.Config) (TargetArgs t)

------------------------------------------------------------------------------
-- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given
-- range is an HsExpr hole. It gives continuations access to the resulting
-- tactic judgement.
data HoleTarget = HoleTarget
  deriving stock (HoleTarget -> HoleTarget -> Bool
(HoleTarget -> HoleTarget -> Bool)
-> (HoleTarget -> HoleTarget -> Bool) -> Eq HoleTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HoleTarget -> HoleTarget -> Bool
$c/= :: HoleTarget -> HoleTarget -> Bool
== :: HoleTarget -> HoleTarget -> Bool
$c== :: HoleTarget -> HoleTarget -> Bool
Eq, Eq HoleTarget
Eq HoleTarget
-> (HoleTarget -> HoleTarget -> Ordering)
-> (HoleTarget -> HoleTarget -> Bool)
-> (HoleTarget -> HoleTarget -> Bool)
-> (HoleTarget -> HoleTarget -> Bool)
-> (HoleTarget -> HoleTarget -> Bool)
-> (HoleTarget -> HoleTarget -> HoleTarget)
-> (HoleTarget -> HoleTarget -> HoleTarget)
-> Ord HoleTarget
HoleTarget -> HoleTarget -> Bool
HoleTarget -> HoleTarget -> Ordering
HoleTarget -> HoleTarget -> HoleTarget
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HoleTarget -> HoleTarget -> HoleTarget
$cmin :: HoleTarget -> HoleTarget -> HoleTarget
max :: HoleTarget -> HoleTarget -> HoleTarget
$cmax :: HoleTarget -> HoleTarget -> HoleTarget
>= :: HoleTarget -> HoleTarget -> Bool
$c>= :: HoleTarget -> HoleTarget -> Bool
> :: HoleTarget -> HoleTarget -> Bool
$c> :: HoleTarget -> HoleTarget -> Bool
<= :: HoleTarget -> HoleTarget -> Bool
$c<= :: HoleTarget -> HoleTarget -> Bool
< :: HoleTarget -> HoleTarget -> Bool
$c< :: HoleTarget -> HoleTarget -> Bool
compare :: HoleTarget -> HoleTarget -> Ordering
$ccompare :: HoleTarget -> HoleTarget -> Ordering
$cp1Ord :: Eq HoleTarget
Ord, Int -> HoleTarget -> ShowS
[HoleTarget] -> ShowS
HoleTarget -> String
(Int -> HoleTarget -> ShowS)
-> (HoleTarget -> String)
-> ([HoleTarget] -> ShowS)
-> Show HoleTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HoleTarget] -> ShowS
$cshowList :: [HoleTarget] -> ShowS
show :: HoleTarget -> String
$cshow :: HoleTarget -> String
showsPrec :: Int -> HoleTarget -> ShowS
$cshowsPrec :: Int -> HoleTarget -> ShowS
Show, Int -> HoleTarget
HoleTarget -> Int
HoleTarget -> [HoleTarget]
HoleTarget -> HoleTarget
HoleTarget -> HoleTarget -> [HoleTarget]
HoleTarget -> HoleTarget -> HoleTarget -> [HoleTarget]
(HoleTarget -> HoleTarget)
-> (HoleTarget -> HoleTarget)
-> (Int -> HoleTarget)
-> (HoleTarget -> Int)
-> (HoleTarget -> [HoleTarget])
-> (HoleTarget -> HoleTarget -> [HoleTarget])
-> (HoleTarget -> HoleTarget -> [HoleTarget])
-> (HoleTarget -> HoleTarget -> HoleTarget -> [HoleTarget])
-> Enum HoleTarget
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: HoleTarget -> HoleTarget -> HoleTarget -> [HoleTarget]
$cenumFromThenTo :: HoleTarget -> HoleTarget -> HoleTarget -> [HoleTarget]
enumFromTo :: HoleTarget -> HoleTarget -> [HoleTarget]
$cenumFromTo :: HoleTarget -> HoleTarget -> [HoleTarget]
enumFromThen :: HoleTarget -> HoleTarget -> [HoleTarget]
$cenumFromThen :: HoleTarget -> HoleTarget -> [HoleTarget]
enumFrom :: HoleTarget -> [HoleTarget]
$cenumFrom :: HoleTarget -> [HoleTarget]
fromEnum :: HoleTarget -> Int
$cfromEnum :: HoleTarget -> Int
toEnum :: Int -> HoleTarget
$ctoEnum :: Int -> HoleTarget
pred :: HoleTarget -> HoleTarget
$cpred :: HoleTarget -> HoleTarget
succ :: HoleTarget -> HoleTarget
$csucc :: HoleTarget -> HoleTarget
Enum, HoleTarget
HoleTarget -> HoleTarget -> Bounded HoleTarget
forall a. a -> a -> Bounded a
maxBound :: HoleTarget
$cmaxBound :: HoleTarget
minBound :: HoleTarget
$cminBound :: HoleTarget
Bounded)

getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath
getNfp :: Uri -> MaybeT m NormalizedFilePath
getNfp = m (Maybe NormalizedFilePath) -> MaybeT m NormalizedFilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe NormalizedFilePath) -> MaybeT m NormalizedFilePath)
-> (Uri -> m (Maybe NormalizedFilePath))
-> Uri
-> MaybeT m NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe NormalizedFilePath -> m (Maybe NormalizedFilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NormalizedFilePath -> m (Maybe NormalizedFilePath))
-> (Uri -> Maybe NormalizedFilePath)
-> Uri
-> m (Maybe NormalizedFilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> (Uri -> NormalizedUri) -> Uri -> Maybe NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> NormalizedUri
toNormalizedUri

instance IsTarget HoleTarget where
  type TargetArgs HoleTarget = HoleJudgment
  fetchTargetArgs :: LspEnv -> MaybeT (LspM Config) (TargetArgs HoleTarget)
fetchTargetArgs LspEnv{DynFlags
IdeState
PluginId
Config
FileContext
le_fileContext :: FileContext
le_config :: Config
le_dflags :: DynFlags
le_pluginId :: PluginId
le_ideState :: IdeState
le_fileContext :: LspEnv -> FileContext
le_config :: LspEnv -> Config
le_dflags :: LspEnv -> DynFlags
le_pluginId :: LspEnv -> PluginId
le_ideState :: LspEnv -> IdeState
..} = do
    let FileContext{Maybe (Tracked 'Current Range)
Uri
fc_range :: Maybe (Tracked 'Current Range)
fc_uri :: Uri
fc_range :: FileContext -> Maybe (Tracked 'Current Range)
fc_uri :: FileContext -> Uri
..} = FileContext
le_fileContext
    Tracked 'Current Range
range <- LspM Config (Maybe (Tracked 'Current Range))
-> MaybeT (LspM Config) (Tracked 'Current Range)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LspM Config (Maybe (Tracked 'Current Range))
 -> MaybeT (LspM Config) (Tracked 'Current Range))
-> LspM Config (Maybe (Tracked 'Current Range))
-> MaybeT (LspM Config) (Tracked 'Current Range)
forall a b. (a -> b) -> a -> b
$ Maybe (Tracked 'Current Range)
-> LspM Config (Maybe (Tracked 'Current Range))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Tracked 'Current Range)
fc_range
    NormalizedFilePath
nfp <- Uri -> MaybeT (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Applicative m =>
Uri -> MaybeT m NormalizedFilePath
getNfp Uri
fc_uri
    (IO (Maybe HoleJudgment) -> LspM Config (Maybe HoleJudgment))
-> MaybeT IO HoleJudgment -> MaybeT (LspM Config) HoleJudgment
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe HoleJudgment) -> LspM Config (Maybe HoleJudgment)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO HoleJudgment -> MaybeT (LspM Config) HoleJudgment)
-> MaybeT IO HoleJudgment -> MaybeT (LspM Config) HoleJudgment
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> Tracked 'Current Range
-> Config
-> MaybeT IO HoleJudgment
judgementForHole IdeState
le_ideState NormalizedFilePath
nfp Tracked 'Current Range
range Config
le_config