hls-explicit-fixity-plugin 1.0.0.0 → 1.1.0.0

raw patch · 3 files changed

+59/−104 lines, 3 filesdep +transformersdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils

API changes (from Hackage documentation)

Files

• hls-explicit-fixity-plugin.cabal +9/−4
• src/Ide/Plugin/ExplicitFixity.hs +47/−97
• test/Main.hs +3/−3

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               hls-explicit-fixity-plugin-version:            1.0.0.0+version:            1.1.0.0 synopsis:           Show fixity explicitly while hovering description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-explicit-fixity-plugin#readme>@@ -15,6 +15,10 @@   LICENSE   test/testdata/*.hs +source-repository head+    type:     git+    location: https://github.com/haskell/haskell-language-server.git+ library   buildable: True   exposed-modules:    Ide.Plugin.ExplicitFixity@@ -26,11 +30,12 @@     , deepseq     , extra     , ghc-    , ghcide               ^>=1.8+    , ghcide               ^>=1.9     , hashable-    , hls-plugin-api       ^>=1.5+    , hls-plugin-api       ^>=1.6     , lsp                   >=1.2.0.1     , text+    , transformers    ghc-options:     -Wall@@ -50,5 +55,5 @@     , base     , filepath     , hls-explicit-fixity-plugin-    , hls-test-utils              ^>=1.4+    , hls-test-utils              ^>=1.5     , text

@@ -2,23 +2,21 @@ {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-} {-# LANGUAGE TypeFamilies      #-}-{-# OPTIONS_GHC -Wno-deprecations #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Use nubOrdOn" #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Ide.Plugin.ExplicitFixity(descriptor) where+module Ide.Plugin.ExplicitFixity(descriptor, Log) where  import           Control.DeepSeq-import           Control.Monad                        (forM) import           Control.Monad.IO.Class               (MonadIO, liftIO)-import           Data.Coerce                          (coerce)+import           Control.Monad.Trans.Maybe import           Data.Either.Extra import           Data.Hashable-import           Data.List.Extra                      (nubOn)-import qualified Data.Map                             as M+import qualified Data.Map.Strict                      as M import           Data.Maybe-import           Data.Monoid+import qualified Data.Set                             as S import qualified Data.Text                            as T import           Development.IDE                      hiding (pluginHandlers,                                                        pluginRules)@@ -26,9 +24,9 @@ import           Development.IDE.Core.Shake           (addPersistentRule) import qualified Development.IDE.Core.Shake           as Shake import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.Util      (FastString) import qualified Development.IDE.GHC.Compat.Util      as Util import           Development.IDE.LSP.Notifications    (ghcideNotificationsPluginPriority)+import           Development.IDE.Spans.AtPoint import           GHC.Generics                         (Generic) import           Ide.PluginUtils                      (getNormalizedFilePath,                                                        handleMaybeM,@@ -36,11 +34,8 @@ import           Ide.Types                            hiding (pluginId) import           Language.LSP.Types -pluginId :: PluginId-pluginId = "explicitFixity"--descriptor :: Recorder (WithPriority Log) -> PluginDescriptor IdeState-descriptor recorder = (defaultPluginDescriptor pluginId)+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder pluginId = (defaultPluginDescriptor pluginId)     { pluginRules = fixityRule recorder     , pluginHandlers = mkPluginHandler STextDocumentHover hover     -- Make this plugin has a lower priority than ghcide's plugin to ensure@@ -51,14 +46,14 @@ hover :: PluginMethodHandler IdeState TextDocumentHover hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do     nfp <- getNormalizedFilePath uri-    fixityTrees <- handleMaybeM "ExplicitFixity: Unable to get fixity"-        $ liftIO-        $ runAction "ExplicitFixity.GetFixity" state-        $ use GetFixity nfp-    -- We don't have much fixities on one position, so `nubOn` is acceptable.-    pure $ toHover $ nubOn snd $ findInTree fixityTrees pos fNodeFixty+    handleMaybeM "ExplicitFixity: Unable to get fixity" $ liftIO $ runIdeAction "ExplicitFixity" (shakeExtras state) $ runMaybeT $ do+      (FixityMap fixmap, _) <- useE GetFixity nfp+      (HAR{hieAst}, mapping) <- useE GetHieAst nfp+      let ns = getNamesAtPoint hieAst pos mapping+          fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns+      pure $ toHover $ fs     where-        toHover :: [(T.Text, Fixity)] -> Maybe Hover+        toHover :: [(Name, Fixity)] -> Maybe Hover         toHover [] = Nothing         toHover fixities =             let -- Splicing fixity info@@ -67,44 +62,19 @@                 contents' = "\n" <> sectionSeparator <> contents             in  Just $ Hover (HoverContents $ unmarkedUpContent contents') Nothing -        fixityText :: (T.Text, Fixity) -> T.Text+        fixityText :: (Name, Fixity) -> T.Text         fixityText (name, Fixity _ precedence direction) =-            printOutputable direction <> " " <> printOutputable precedence <> " `" <> name <> "`"---- | Transferred from ghc `selectSmallestContaining`-selectSmallestContainingForFixityTree :: Span -> FixityTree -> Maybe FixityTree-selectSmallestContainingForFixityTree sp node-    | sp `containsSpan` fNodeSpan node = Just node-    | fNodeSpan node `containsSpan` sp = getFirst $ mconcat-        [ foldMap (First . selectSmallestContainingForFixityTree sp) $ fNodeChildren node-        , First (Just node)-        ]-    | otherwise = Nothing---- | Transferred from ghcide `pointCommand`-findInTree :: FixityTrees -> Position -> (FixityTree -> [a]) -> [a]-findInTree tree pos k =-    concat $ M.elems $ flip M.mapWithKey tree $ \fs ast ->-        maybe [] k (selectSmallestContainingForFixityTree (sp fs) ast)-    where-        sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1)-        sp fs = mkRealSrcSpan (sloc fs) (sloc fs)-        line = _line pos-        cha = _character pos--data FixityTree = FNode-    { fNodeSpan     :: Span-    , fNodeChildren :: [FixityTree]-    , fNodeFixty    :: [(T.Text, Fixity)]-    } deriving (Generic)+            printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`" -instance NFData FixityTree where-    rnf = rwhnf+newtype FixityMap = FixityMap (M.Map Name Fixity)+instance Show FixityMap where+  show _ = "FixityMap" -instance Show FixityTree where-    show _ = "<FixityTree>"+instance NFData FixityMap where+  rnf (FixityMap xs) = rnf xs -type FixityTrees = M.Map FastString FixityTree+instance NFData Fixity where+  rnf = rwhnf  newtype Log = LogShake Shake.Log @@ -117,53 +87,33 @@ instance Hashable GetFixity instance NFData GetFixity -type instance RuleResult GetFixity = FixityTrees--fakeFixityTrees :: FixityTrees-fakeFixityTrees = M.empty---- | Convert a HieASTs to FixityTrees with fixity info gathered-hieAstsToFixitTrees :: MonadIO m => HscEnv -> TcGblEnv -> HieASTs a -> m FixityTrees-hieAstsToFixitTrees hscEnv tcGblEnv ast =-    -- coerce to avoid compatibility issues.-    M.mapKeysWith const coerce <$>-        sequence (M.map (hieAstToFixtyTree hscEnv tcGblEnv) (getAsts ast))+type instance RuleResult GetFixity = FixityMap  -- | Convert a HieAST to FixityTree with fixity info gathered-hieAstToFixtyTree :: MonadIO m => HscEnv -> TcGblEnv -> HieAST a -> m FixityTree-hieAstToFixtyTree hscEnv tcGblEnv ast = case ast of-    (Node _ span []) -> FNode span [] <$> getFixities-    (Node _ span children) -> do-        fixities <- getFixities-        childrenFixities <- mapM (hieAstToFixtyTree hscEnv tcGblEnv) children-        pure $ FNode span childrenFixities fixities-    where-        -- Names at the current ast node-        names :: [Name]-        names = mapMaybe eitherToMaybe $ M.keys $ getNodeIds ast--        getFixities :: MonadIO m => m [(T.Text, Fixity)]-        getFixities = liftIO-            $ fmap (filter ((/= defaultFixity) . snd) . mapMaybe pickFixity)-            $ forM names $ \name ->-                (,) (printOutputable name)-                . snd-                <$> Util.handleGhcException-                    (const $ pure (emptyMessages, Nothing))-                    (initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1) (lookupFixityRn name))--        pickFixity :: (T.Text, Maybe Fixity) -> Maybe (T.Text, Fixity)-        pickFixity (_, Nothing)   = Nothing-        pickFixity (name, Just f) = Just (name, f)+lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name Fixity)+lookupFixities hscEnv tcGblEnv names+    = liftIO+    $ fmap (fromMaybe M.empty . snd)+    $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1)+    $ M.traverseMaybeWithKey (\_ v -> v)+    $ M.fromSet lookupFixity names+  where+    lookupFixity name = do+      f <- Util.handleGhcException+        (const $ pure Nothing)+        (Just <$> lookupFixityRn name)+      if f == Just defaultFixity+      then pure Nothing+      else pure f  fixityRule :: Recorder (WithPriority Log) -> Rules () fixityRule recorder = do     define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do-        HAR{hieAst} <- use_ GetHieAst nfp-        env <- hscEnv <$> use_ GhcSession nfp+        HAR{refMap} <- use_ GetHieAst nfp+        env <- hscEnv <$> use_ GhcSessionDeps nfp -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates         tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp-        trees <- hieAstsToFixitTrees env tcGblEnv hieAst-        pure ([], Just trees)+        fs <- lookupFixities env tcGblEnv (S.mapMonotonic (\(Right n) -> n) $ S.filter isRight $ M.keysSet refMap)+        pure ([], Just (FixityMap fs))      -- Ensure that this plugin doesn't block on startup-    addPersistentRule GetFixity $ \_ -> pure $ Just (fakeFixityTrees, idDelta, Nothing)+    addPersistentRule GetFixity $ \_ -> pure $ Just (FixityMap M.empty, idDelta, Nothing)

@@ -3,12 +3,12 @@ module Main where  import qualified Data.Text                 as T-import           Ide.Plugin.ExplicitFixity (descriptor)+import           Ide.Plugin.ExplicitFixity (Log, descriptor) import           System.FilePath import           Test.Hls -plugin :: PluginDescriptor IdeState-plugin = descriptor mempty+plugin :: PluginTestDescriptor Log+plugin = mkPluginTestDescriptor descriptor "explicit-fixity"  main :: IO () main = defaultTestRunner tests