/
Metaprogram.hs
88 lines (73 loc) · 3.27 KB
/
Metaprogram.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
{-# 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 state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _)
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos
cfg <- getTacticConfig plId
liftIO $ fromMaybeT (Right Nothing) $ do
holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan $ unTrack loc
fmap (Right . Just) $
case (find (flip containsSpan (unTrack loc) . unTrack . fst) holes) of
Just (trss, program) -> do
let tr_range = fmap realSrcSpanToRange trss
rsl = realSrcSpanStart $ unTrack trss
HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg
z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program
pure $ Hover
{ _contents = HoverContents
$ MarkupContent MkMarkdown
$ either T.pack T.pack z
, _range = Just $ unTrack tr_range
}
Nothing -> empty
hoverProvider _ _ _ = pure $ Right Nothing
fromMaybeT :: Functor m => a -> MaybeT m a -> m a
fromMaybeT def = fmap (fromMaybe def) . runMaybeT
getMetaprogramsAtSpan
:: IdeState
-> NormalizedFilePath
-> SrcSpan
-> MaybeT IO [(Tracked 'Current RealSrcSpan, T.Text)]
getMetaprogramsAtSpan state nfp ss = do
let stale a = runStaleIde "getMetaprogramsAtSpan" state nfp a
TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck
let scrutinees = traverse (metaprogramQ ss . tcg_binds) tcg
for scrutinees $ \aged@(unTrack -> (ss, program)) -> do
case ss of
RealSrcSpan r -> do
rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
pure (rss', program)
UnhelpfulSpan _ -> empty