{-# 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           Data.Traversable
import           Development.IDE (positionToRealSrcLoc)
import           Development.IDE (realSrcSpanToRange)
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake (IdeState (..))
import           Development.IDE.Core.UseStale
import           Development.IDE.GHC.Compat
import           GhcPlugins (containsSpan, realSrcLocSpan, realSrcSpanStart)
import           Ide.Types
import           Language.LSP.Types
import           Prelude hiding (span)
import           Prelude hiding (span)
import           TcRnTypes (tcg_binds)
import           Wingman.GHC
import           Wingman.Judgements.SYB (metaprogramQ)
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

      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 <- IdeState
-> NormalizedFilePath
-> SrcSpan
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)]
getMetaprogramsAtSpan IdeState
state NormalizedFilePath
nfp (SrcSpan -> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)])
-> SrcSpan -> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)]
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> SrcSpan
RealSrcSpan (RealSrcSpan -> SrcSpan) -> RealSrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current RealSrcSpan
loc

        (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


getMetaprogramsAtSpan
    :: IdeState
    -> NormalizedFilePath
    -> SrcSpan
    -> MaybeT IO [(Tracked 'Current RealSrcSpan, T.Text)]
getMetaprogramsAtSpan :: IdeState
-> NormalizedFilePath
-> SrcSpan
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)]
getMetaprogramsAtSpan IdeState
state NormalizedFilePath
nfp SrcSpan
ss = do
    let stale :: a -> MaybeT IO (TrackedStale (RuleResult a))
stale a
a = String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale (RuleResult a))
forall a r.
(r ~ RuleResult a, Eq a, Hashable a, Binary a, Show a, Typeable a,
 NFData a, Show r, Typeable r, NFData r) =>
String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale r)
runStaleIde String
"getMetaprogramsAtSpan" IdeState
state NormalizedFilePath
nfp a
a

    TrackedStale Tracked ('Stale s) TcGblEnv
tcg PositionMap ('Stale s) 'Current
tcg_map <- (TrackedStale TcModuleResult -> TrackedStale TcGblEnv)
-> MaybeT IO (TrackedStale TcModuleResult)
-> MaybeT IO (TrackedStale TcGblEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TcModuleResult -> TcGblEnv)
-> TrackedStale TcModuleResult -> TrackedStale TcGblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcModuleResult -> TcGblEnv
tmrTypechecked) (MaybeT IO (TrackedStale TcModuleResult)
 -> MaybeT IO (TrackedStale TcGblEnv))
-> MaybeT IO (TrackedStale TcModuleResult)
-> MaybeT IO (TrackedStale TcGblEnv)
forall a b. (a -> b) -> a -> b
$ TypeCheck -> MaybeT IO (TrackedStale (RuleResult TypeCheck))
forall a.
(Eq a, Hashable a, Binary a, Show a, Show (RuleResult a),
 Typeable a, Typeable (RuleResult a), NFData a,
 NFData (RuleResult a)) =>
a -> MaybeT IO (TrackedStale (RuleResult a))
stale TypeCheck
TypeCheck

    let scrutinees :: [Tracked ('Stale s) (SrcSpan, Text)]
scrutinees = (TcGblEnv -> [(SrcSpan, Text)])
-> Tracked ('Stale s) TcGblEnv
-> [Tracked ('Stale s) (SrcSpan, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SrcSpan -> GenericQ [(SrcSpan, Text)]
metaprogramQ SrcSpan
ss (LHsBinds GhcTc -> [(SrcSpan, Text)])
-> (TcGblEnv -> LHsBinds GhcTc) -> TcGblEnv -> [(SrcSpan, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> LHsBinds GhcTc
tcg_binds) Tracked ('Stale s) TcGblEnv
tcg
    [Tracked ('Stale s) (SrcSpan, Text)]
-> (Tracked ('Stale s) (SrcSpan, Text)
    -> MaybeT IO (Tracked 'Current RealSrcSpan, Text))
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Tracked ('Stale s) (SrcSpan, Text)]
scrutinees ((Tracked ('Stale s) (SrcSpan, Text)
  -> MaybeT IO (Tracked 'Current RealSrcSpan, Text))
 -> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)])
-> (Tracked ('Stale s) (SrcSpan, Text)
    -> MaybeT IO (Tracked 'Current RealSrcSpan, Text))
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Text)]
forall a b. (a -> b) -> a -> b
$ \aged :: Tracked ('Stale s) (SrcSpan, Text)
aged@(Tracked ('Stale s) (SrcSpan, Text) -> (SrcSpan, Text)
forall (age :: Age) a. Tracked age a -> a
unTrack -> (SrcSpan
ss, Text
program)) -> do
      case SrcSpan
ss of
        RealSrcSpan RealSrcSpan
r   -> do
          Tracked 'Current RealSrcSpan
rss' <- Maybe (Tracked 'Current RealSrcSpan)
-> MaybeT IO (Tracked 'Current RealSrcSpan)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe (Tracked 'Current RealSrcSpan)
 -> MaybeT IO (Tracked 'Current RealSrcSpan))
-> Maybe (Tracked 'Current RealSrcSpan)
-> MaybeT IO (Tracked 'Current RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ PositionMap ('Stale s) 'Current
-> Tracked ('Stale s) RealSrcSpan
-> Maybe (Tracked 'Current RealSrcSpan)
forall a (from :: Age) (to :: Age).
MapAge a =>
PositionMap from to -> Tracked from a -> Maybe (Tracked to a)
mapAgeTo PositionMap ('Stale s) 'Current
tcg_map (Tracked ('Stale s) RealSrcSpan
 -> Maybe (Tracked 'Current RealSrcSpan))
-> Tracked ('Stale s) RealSrcSpan
-> Maybe (Tracked 'Current RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ Tracked ('Stale s) (SrcSpan, Text)
-> RealSrcSpan -> Tracked ('Stale s) RealSrcSpan
forall (age :: Age) a b. Tracked age a -> b -> Tracked age b
unsafeCopyAge Tracked ('Stale s) (SrcSpan, Text)
aged RealSrcSpan
r
          (Tracked 'Current RealSrcSpan, Text)
-> MaybeT IO (Tracked 'Current RealSrcSpan, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracked 'Current RealSrcSpan
rss', Text
program)
        UnhelpfulSpan FastString
_ -> MaybeT IO (Tracked 'Current RealSrcSpan, Text)
forall (f :: * -> *) a. Alternative f => f a
empty