Skip to content

Commit dfd92eb

Browse files
wz1000wz1000
committed
Improve hls-fixity-plugin
1 parent 388fd40 commit dfd92eb

File tree

2 files changed

+45
-91
lines changed

2 files changed

+45
-91
lines changed

‎plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ library
3535
, hls-plugin-api ^>=1.5
3636
, lsp >=1.2.0.1
3737
, text
38+
, transformers
3839

3940
ghc-options:
4041
-Wall

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

Lines changed: 44 additions & 91 deletions
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)
@@ -48,14 +46,14 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId)
4846
hover :: PluginMethodHandler IdeState TextDocumentHover
4947
hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do
5048
nfp <- getNormalizedFilePath uri
51-
fixityTrees <- handleMaybeM "Unable to get fixity"
52-
$ liftIO
53-
$ runAction "ExplicitFixity.GetFixity" state
54-
$ use GetFixity nfp
55-
-- We don't have much fixities on one position, so `nubOn` is acceptable.
56-
pure $ toHover $ nubOn snd $ findInTree fixityTrees pos fNodeFixty
49+
handleMaybeM "ExplicitFixity: Unable to get fixity" $ liftIO $ runIdeAction "ExplicitFixity" (shakeExtras state) $ runMaybeT $ do
50+
(FixityMap fixmap, _) <- useE GetFixity nfp
51+
(HAR{hieAst}, mapping) <- useE GetHieAst nfp
52+
let ns = getNamesAtPoint hieAst pos mapping
53+
fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns
54+
pure $ toHover $ fs
5755
where
58-
toHover :: [(T.Text, Fixity)] -> Maybe Hover
56+
toHover :: [(Name, Fixity)] -> Maybe Hover
5957
toHover [] = Nothing
6058
toHover fixities =
6159
let -- Splicing fixity info
@@ -64,44 +62,19 @@ hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse
6462
contents' = "\n" <> sectionSeparator <> contents
6563
in Just $ Hover (HoverContents $ unmarkedUpContent contents') Nothing
6664

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

98-
instance NFData FixityTree where
99-
rnf = rwhnf
69+
newtype FixityMap = FixityMap (M.Map Name Fixity)
70+
instance Show FixityMap where
71+
show _ = "FixityMap"
10072

101-
instance Show FixityTree where
102-
show _ = "<FixityTree>"
73+
instance NFData FixityMap where
74+
rnf (FixityMap xs) = rnf xs
10375

104-
type FixityTrees = M.Map FastString FixityTree
76+
instance NFData Fixity where
77+
rnf = rwhnf
10578

10679
newtype Log = LogShake Shake.Log
10780

@@ -114,53 +87,33 @@ data GetFixity = GetFixity deriving (Show, Eq, Generic)
11487
instance Hashable GetFixity
11588
instance NFData GetFixity
11689

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

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

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

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

0 commit comments

Comments
 (0)