Skip to content

Commit 0c9cbf1

Browse files
wz1000wz1000
committed
Improve hls-fixity-plugin
1 parent bd1d0a1 commit 0c9cbf1

File tree

2 files changed

+45
-91
lines changed

2 files changed

+45
-91
lines changed

Diff for: ‎plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ library
3131
, hls-plugin-api ^>=1.5
3232
, lsp >=1.2.0.1
3333
, text
34+
, transformers
3435

3536
ghc-options:
3637
-Wall

Diff for: ‎plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs

+44-91
Original file line numberDiff line numberDiff line change
@@ -1,32 +1,30 @@
11
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TupleSections #-}
23
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE NamedFieldPuns #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE TypeFamilies #-}
6-
{-# OPTIONS_GHC -Wno-deprecations #-}
7-
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
8-
{-# HLINT ignore "Use nubOrdOn" #-}
7+
{-# OPTIONS_GHC -Wno-orphans #-}
8+
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
99

1010
module Ide.Plugin.ExplicitFixity(descriptor) where
1111

1212
import Control.DeepSeq
13-
import Control.Monad (forM)
13+
import Control.Monad.Trans.Maybe
1414
import Control.Monad.IO.Class (MonadIO, liftIO)
15-
import Data.Coerce (coerce)
1615
import Data.Either.Extra
1716
import Data.Hashable
18-
import Data.List.Extra (nubOn)
19-
import qualified Data.Map as M
17+
import qualified Data.Map.Strict as M
18+
import qualified Data.Set as S
2019
import Data.Maybe
21-
import Data.Monoid
2220
import qualified Data.Text as T
2321
import Development.IDE hiding (pluginHandlers,
2422
pluginRules)
2523
import Development.IDE.Core.PositionMapping (idDelta)
2624
import Development.IDE.Core.Shake (addPersistentRule)
2725
import qualified Development.IDE.Core.Shake as Shake
26+
import Development.IDE.Spans.AtPoint
2827
import Development.IDE.GHC.Compat
29-
import Development.IDE.GHC.Compat.Util (FastString)
3028
import qualified Development.IDE.GHC.Compat.Util as Util
3129
import Development.IDE.LSP.Notifications (ghcideNotificationsPluginPriority)
3230
import GHC.Generics (Generic)
@@ -51,14 +49,14 @@ descriptor recorder = (defaultPluginDescriptor pluginId)
5149
hover :: PluginMethodHandler IdeState TextDocumentHover
5250
hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do
5351
nfp <- getNormalizedFilePath uri
54-
fixityTrees <- handleMaybeM "ExplicitFixity: Unable to get fixity"
55-
$ liftIO
56-
$ runAction "ExplicitFixity.GetFixity" state
57-
$ use GetFixity nfp
58-
-- We don't have much fixities on one position, so `nubOn` is acceptable.
59-
pure $ toHover $ nubOn snd $ findInTree fixityTrees pos fNodeFixty
52+
handleMaybeM "ExplicitFixity: Unable to get fixity" $ liftIO $ runIdeAction "ExplicitFixity" (shakeExtras state) $ runMaybeT $ do
53+
(FixityMap fixmap, _) <- useE GetFixity nfp
54+
(HAR{hieAst}, mapping) <- useE GetHieAst nfp
55+
let ns = getNamesAtPoint hieAst pos mapping
56+
fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns
57+
pure $ toHover $ fs
6058
where
61-
toHover :: [(T.Text, Fixity)] -> Maybe Hover
59+
toHover :: [(Name, Fixity)] -> Maybe Hover
6260
toHover [] = Nothing
6361
toHover fixities =
6462
let -- Splicing fixity info
@@ -67,44 +65,19 @@ hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse
6765
contents' = "\n" <> sectionSeparator <> contents
6866
in Just $ Hover (HoverContents $ unmarkedUpContent contents') Nothing
6967

70-
fixityText :: (T.Text, Fixity) -> T.Text
68+
fixityText :: (Name, Fixity) -> T.Text
7169
fixityText (name, Fixity _ precedence direction) =
72-
printOutputable direction <> " " <> printOutputable precedence <> " `" <> name <> "`"
73-
74-
-- | Transferred from ghc `selectSmallestContaining`
75-
selectSmallestContainingForFixityTree :: Span -> FixityTree -> Maybe FixityTree
76-
selectSmallestContainingForFixityTree sp node
77-
| sp `containsSpan` fNodeSpan node = Just node
78-
| fNodeSpan node `containsSpan` sp = getFirst $ mconcat
79-
[ foldMap (First . selectSmallestContainingForFixityTree sp) $ fNodeChildren node
80-
, First (Just node)
81-
]
82-
| otherwise = Nothing
83-
84-
-- | Transferred from ghcide `pointCommand`
85-
findInTree :: FixityTrees -> Position -> (FixityTree -> [a]) -> [a]
86-
findInTree tree pos k =
87-
concat $ M.elems $ flip M.mapWithKey tree $ \fs ast ->
88-
maybe [] k (selectSmallestContainingForFixityTree (sp fs) ast)
89-
where
90-
sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1)
91-
sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
92-
line = _line pos
93-
cha = _character pos
94-
95-
data FixityTree = FNode
96-
{ fNodeSpan :: Span
97-
, fNodeChildren :: [FixityTree]
98-
, fNodeFixty :: [(T.Text, Fixity)]
99-
} deriving (Generic)
70+
printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`"
10071

101-
instance NFData FixityTree where
102-
rnf = rwhnf
72+
newtype FixityMap = FixityMap (M.Map Name Fixity)
73+
instance Show FixityMap where
74+
show _ = "FixityMap"
10375

104-
instance Show FixityTree where
105-
show _ = "<FixityTree>"
76+
instance NFData FixityMap where
77+
rnf (FixityMap xs) = rnf xs
10678

107-
type FixityTrees = M.Map FastString FixityTree
79+
instance NFData Fixity where
80+
rnf = rwhnf
10881

10982
newtype Log = LogShake Shake.Log
11083

@@ -117,53 +90,33 @@ data GetFixity = GetFixity deriving (Show, Eq, Generic)
11790
instance Hashable GetFixity
11891
instance NFData GetFixity
11992

120-
type instance RuleResult GetFixity = FixityTrees
121-
122-
fakeFixityTrees :: FixityTrees
123-
fakeFixityTrees = M.empty
124-
125-
-- | Convert a HieASTs to FixityTrees with fixity info gathered
126-
hieAstsToFixitTrees :: MonadIO m => HscEnv -> TcGblEnv -> HieASTs a -> m FixityTrees
127-
hieAstsToFixitTrees hscEnv tcGblEnv ast =
128-
-- coerce to avoid compatibility issues.
129-
M.mapKeysWith const coerce <$>
130-
sequence (M.map (hieAstToFixtyTree hscEnv tcGblEnv) (getAsts ast))
93+
type instance RuleResult GetFixity = FixityMap
13194

13295
-- | Convert a HieAST to FixityTree with fixity info gathered
133-
hieAstToFixtyTree :: MonadIO m => HscEnv -> TcGblEnv -> HieAST a -> m FixityTree
134-
hieAstToFixtyTree hscEnv tcGblEnv ast = case ast of
135-
(Node _ span []) -> FNode span [] <$> getFixities
136-
(Node _ span children) -> do
137-
fixities <- getFixities
138-
childrenFixities <- mapM (hieAstToFixtyTree hscEnv tcGblEnv) children
139-
pure $ FNode span childrenFixities fixities
140-
where
141-
-- Names at the current ast node
142-
names :: [Name]
143-
names = mapMaybe eitherToMaybe $ M.keys $ getNodeIds ast
144-
145-
getFixities :: MonadIO m => m [(T.Text, Fixity)]
146-
getFixities = liftIO
147-
$ fmap (filter ((/= defaultFixity) . snd) . mapMaybe pickFixity)
148-
$ forM names $ \name ->
149-
(,) (printOutputable name)
150-
. snd
151-
<$> Util.handleGhcException
152-
(const $ pure (emptyMessages, Nothing))
153-
(initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1) (lookupFixityRn name))
154-
155-
pickFixity :: (T.Text, Maybe Fixity) -> Maybe (T.Text, Fixity)
156-
pickFixity (_, Nothing) = Nothing
157-
pickFixity (name, Just f) = Just (name, f)
96+
lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name Fixity)
97+
lookupFixities hscEnv tcGblEnv names
98+
= liftIO
99+
$ fmap (fromMaybe M.empty . snd)
100+
$ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1)
101+
$ M.traverseMaybeWithKey (\_ v -> v)
102+
$ M.fromSet lookupFixity names
103+
where
104+
lookupFixity name = do
105+
f <- Util.handleGhcException
106+
(const $ pure Nothing)
107+
(Just <$> lookupFixityRn name)
108+
if f == Just defaultFixity
109+
then pure Nothing
110+
else pure f
158111

159112
fixityRule :: Recorder (WithPriority Log) -> Rules ()
160113
fixityRule recorder = do
161114
define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do
162-
HAR{hieAst} <- use_ GetHieAst nfp
163-
env <- hscEnv <$> use_ GhcSession nfp
115+
HAR{refMap} <- use_ GetHieAst nfp
116+
env <- hscEnv <$> use_ GhcSessionDeps nfp -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates
164117
tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp
165-
trees <- hieAstsToFixitTrees env tcGblEnv hieAst
166-
pure ([], Just trees)
118+
fs <- lookupFixities env tcGblEnv (S.mapMonotonic (\(Right n) -> n) $ S.filter isRight $ M.keysSet refMap)
119+
pure ([], Just (FixityMap fs))
167120

168121
-- Ensure that this plugin doesn't block on startup
169-
addPersistentRule GetFixity $ \_ -> pure $ Just (fakeFixityTrees, idDelta, Nothing)
122+
addPersistentRule GetFixity $ \_ -> pure $ Just (FixityMap M.empty, idDelta, Nothing)

0 commit comments

Comments
 (0)