{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings     #-}

{-# LANGUAGE NoMonoLocalBinds  #-}
{-# LANGUAGE RankNTypes #-}

module Wingman.LanguageServer.Metaprogram
  ( hoverProvider
  ) where

import           Control.Applicative (empty)
import           Control.Monad
import           Control.Monad.Trans
import           Control.Monad.Trans.Maybe
import           Data.List (find)
import           Data.Maybe
import qualified Data.Text as T
import           Development.IDE (positionToRealSrcLoc, realSrcSpanToRange)
import           Development.IDE.Core.Shake (IdeState (..))
import           Development.IDE.Core.UseStale
import           Development.IDE.GHC.Compat hiding (empty)
import           Ide.Types
import           Language.LSP.Types
import           Prelude hiding (span)
import           Wingman.LanguageServer
import           Wingman.Metaprogramming.Parser (attempt_it)
import           Wingman.Types


------------------------------------------------------------------------------
-- | Provide the "empty case completion" code lens
hoverProvider :: PluginMethodHandler IdeState TextDocumentHover
hoverProvider :: PluginMethodHandler IdeState 'TextDocumentHover
hoverProvider IdeState
state PluginId
plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _)
  | 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
      let loc :: Tracked 'Current RealSrcSpan
loc = (Position -> RealSrcSpan)
-> Tracked 'Current Position -> Tracked 'Current RealSrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan)
-> (Position -> RealSrcLoc) -> Position -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> Position -> RealSrcLoc
positionToRealSrcLoc NormalizedFilePath
nfp) Tracked 'Current Position
pos
          stale :: GetMetaprograms -> MaybeT IO (RuleResult GetMetaprograms)
stale = String
-> IdeState
-> NormalizedFilePath
-> GetMetaprograms
-> MaybeT IO (RuleResult GetMetaprograms)
forall a r.
(r ~ RuleResult a, Eq a, Hashable a, Show a, Typeable a, NFData a,
 Show r, Typeable r, NFData r) =>
String -> IdeState -> NormalizedFilePath -> a -> MaybeT IO r
unsafeRunStaleIdeFast String
"hoverProvider" IdeState
state NormalizedFilePath
nfp

      Config
cfg <- PluginId -> LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => PluginId -> m Config
getTacticConfig PluginId
plId
      IO (Either ResponseError (Maybe Hover))
-> LspT Config IO (Either ResponseError (Maybe Hover))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (Maybe Hover))
 -> LspT Config IO (Either ResponseError (Maybe Hover)))
-> IO (Either ResponseError (Maybe Hover))
-> LspT Config IO (Either ResponseError (Maybe Hover))
forall a b. (a -> b) -> a -> b
$ Either ResponseError (Maybe Hover)
-> MaybeT IO (Either ResponseError (Maybe Hover))
-> IO (Either ResponseError (Maybe Hover))
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT (Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right Maybe Hover
forall a. Maybe a
Nothing) (MaybeT IO (Either ResponseError (Maybe Hover))
 -> IO (Either ResponseError (Maybe Hover)))
-> MaybeT IO (Either ResponseError (Maybe Hover))
-> IO (Either ResponseError (Maybe Hover))
forall a b. (a -> b) -> a -> b
$ do
        [(Tracked 'Current RealSrcSpan, Text)]
holes <- GetMetaprograms -> MaybeT IO (RuleResult GetMetaprograms)
stale GetMetaprograms
GetMetaprograms

        (Hover -> Either ResponseError (Maybe Hover))
-> MaybeT IO Hover
-> MaybeT IO (Either ResponseError (Maybe Hover))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right (Maybe Hover -> Either ResponseError (Maybe Hover))
-> (Hover -> Maybe Hover)
-> Hover
-> Either ResponseError (Maybe Hover)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hover -> Maybe Hover
forall a. a -> Maybe a
Just) (MaybeT IO Hover -> MaybeT IO (Either ResponseError (Maybe Hover)))
-> MaybeT IO Hover
-> MaybeT IO (Either ResponseError (Maybe Hover))
forall a b. (a -> b) -> a -> b
$
          case ((Tracked 'Current RealSrcSpan, Text) -> Bool)
-> [(Tracked 'Current RealSrcSpan, Text)]
-> Maybe (Tracked 'Current RealSrcSpan, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((RealSrcSpan -> RealSrcSpan -> Bool)
-> RealSrcSpan -> RealSrcSpan -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealSrcSpan -> RealSrcSpan -> Bool
containsSpan (Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current RealSrcSpan
loc) (RealSrcSpan -> Bool)
-> ((Tracked 'Current RealSrcSpan, Text) -> RealSrcSpan)
-> (Tracked 'Current RealSrcSpan, Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack (Tracked 'Current RealSrcSpan -> RealSrcSpan)
-> ((Tracked 'Current RealSrcSpan, Text)
    -> Tracked 'Current RealSrcSpan)
-> (Tracked 'Current RealSrcSpan, Text)
-> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tracked 'Current RealSrcSpan, Text)
-> Tracked 'Current RealSrcSpan
forall a b. (a, b) -> a
fst) [(Tracked 'Current RealSrcSpan, Text)]
holes of
            Just (Tracked 'Current RealSrcSpan
trss, Text
program) -> do
              let tr_range :: Tracked 'Current Range
tr_range = (RealSrcSpan -> Range)
-> Tracked 'Current RealSrcSpan -> Tracked 'Current Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RealSrcSpan -> Range
realSrcSpanToRange Tracked 'Current RealSrcSpan
trss
                  rsl :: RealSrcLoc
rsl = RealSrcSpan -> RealSrcLoc
realSrcSpanStart (RealSrcSpan -> RealSrcLoc) -> RealSrcSpan -> RealSrcLoc
forall a b. (a -> b) -> a -> b
$ Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current RealSrcSpan
trss
              HoleJudgment{hj_jdg :: HoleJudgment -> Judgement
hj_jdg=Judgement
jdg, hj_ctx :: HoleJudgment -> Context
hj_ctx=Context
ctx} <- IdeState
-> NormalizedFilePath
-> Tracked 'Current Range
-> Config
-> MaybeT IO HoleJudgment
judgementForHole IdeState
state NormalizedFilePath
nfp Tracked 'Current Range
tr_range Config
cfg
              Either String String
z <- IO (Either String String) -> MaybeT IO (Either String String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String) -> MaybeT IO (Either String String))
-> IO (Either String String) -> MaybeT IO (Either String String)
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> Context -> Judgement -> String -> IO (Either String String)
attempt_it RealSrcLoc
rsl Context
ctx Judgement
jdg (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
program
              Hover -> MaybeT IO Hover
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hover -> MaybeT IO Hover) -> Hover -> MaybeT IO Hover
forall a b. (a -> b) -> a -> b
$ Hover :: HoverContents -> Maybe Range -> Hover
Hover
                { $sel:_contents:Hover :: HoverContents
_contents = MarkupContent -> HoverContents
HoverContents
                            (MarkupContent -> HoverContents) -> MarkupContent -> HoverContents
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
MarkupContent MarkupKind
MkMarkdown
                            (Text -> MarkupContent) -> Text -> MarkupContent
forall a b. (a -> b) -> a -> b
$ (String -> Text)
-> (String -> Text) -> Either String String -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Text
T.pack String -> Text
T.pack Either String String
z
                , $sel:_range:Hover :: Maybe Range
_range = Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ Tracked 'Current Range -> Range
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current Range
tr_range
                }
            Maybe (Tracked 'Current RealSrcSpan, Text)
Nothing -> MaybeT IO Hover
forall (f :: * -> *) a. Alternative f => f a
empty
hoverProvider IdeState
_ PluginId
_ MessageParams 'TextDocumentHover
_ = Either ResponseError (Maybe Hover)
-> LspT Config IO (Either ResponseError (Maybe Hover))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (Maybe Hover)
 -> LspT Config IO (Either ResponseError (Maybe Hover)))
-> Either ResponseError (Maybe Hover)
-> LspT Config IO (Either ResponseError (Maybe Hover))
forall a b. (a -> b) -> a -> b
$ Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right Maybe Hover
forall a. Maybe a
Nothing

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