diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 304dfd393e..a2f84c2939 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -61,9 +61,24 @@ getAtPoint file pos = runMaybeT $ do (hf, mapping) <- useE GetHieAst file env <- hscEnv . fst <$> useE GhcSession file dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) + tcGblEnv <- tmrTypechecked . fst <$> useE TypeCheck file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' + + let pointContent = AtPoint.atPoint opts hf dkMap env pos' + fixityContent <- liftIO $ AtPoint.fixityAtPoint hf env tcGblEnv pos' + + MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> mergeContent pointContent fixityContent + where + -- | Respect point content first + mergeContent :: Maybe (Maybe Range, [T.Text]) -> Maybe (Maybe Range, [T.Text]) -> Maybe (Maybe Range, [T.Text]) + mergeContent Nothing Nothing = Nothing + mergeContent x@Just{} Nothing = x + mergeContent Nothing x@Just{} = x + mergeContent (Just (r1, txt1)) (Just (r2, txt2)) = + if r1 == r2 + then Just (r1, txt1 <> filter (not . T.null) txt2) + else Just (r1, txt1) toCurrentLocations :: PositionMapping -> [Location] -> [Location] toCurrentLocations mapping = mapMaybe go diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 625010fd7c..5f7420eb60 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -102,6 +102,10 @@ module Development.IDE.GHC.Compat.Core ( #endif -- * Fixity LexicalFixity(..), + Fixity(..), + mi_fix, + defaultFixity, + lookupFixityRn, -- * ModSummary ModSummary(..), -- * HomeModInfo @@ -378,6 +382,7 @@ module Development.IDE.GHC.Compat.Core ( module GHC.Types.Name.Cache, module GHC.Types.Name.Env, module GHC.Types.Name.Reader, + module GHC.Utils.Error, #if MIN_VERSION_ghc(9,2,0) module GHC.Types.Avail, module GHC.Types.SourceFile, @@ -388,7 +393,6 @@ module Development.IDE.GHC.Compat.Core ( module GHC.Types.Unique.Supply, module GHC.Types.Var, module GHC.Unit.Module, - module GHC.Utils.Error, #else module BasicTypes, module Class, @@ -552,6 +556,7 @@ import GHC.Runtime.Context (InteractiveImport (..)) import GHC.Parser.Lexer import qualified GHC.Runtime.Linker as Linker #endif +import GHC.Rename.Fixity (lookupFixityRn) import GHC.Rename.Names import GHC.Rename.Splice import qualified GHC.Runtime.Interpreter as GHCi @@ -568,7 +573,7 @@ import GHC.Tc.Utils.TcType as TcType import qualified GHC.Types.Avail as Avail #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Avail (greNamePrintableName) -import GHC.Types.Fixity (LexicalFixity (..)) +import GHC.Types.Fixity (LexicalFixity (..), Fixity(..), defaultFixity) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Meta @@ -613,11 +618,11 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..), - ModIface_ (..)) + ModIface_ (..), mi_fix) import GHC.Unit.Module.ModSummary (ModSummary (..)) #endif import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..)) +import GHC.Utils.Error (Severity (..), emptyMessages) import GHC.Utils.Panic hiding (try) import qualified GHC.Utils.Panic.Plain as Plain #else @@ -688,6 +693,7 @@ import qualified Panic as Plain #endif import Parser import PatSyn +import RnFixity #if MIN_VERSION_ghc(8,8,0) import Plugins #endif diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index c729ec8e5d..88634e3a70 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -9,6 +9,7 @@ -- These are all pure functions that should execute quickly. module Development.IDE.Spans.AtPoint ( atPoint + , fixityAtPoint , gotoDefinition , gotoTypeDefinition , documentHighlight @@ -49,8 +50,9 @@ import qualified Data.Text as T import qualified Data.Array as A import Data.Either +import Data.Either.Extra (eitherToMaybe) import Data.List (isSuffixOf) -import Data.List.Extra (dropEnd1, nubOrd) +import Data.List.Extra (dropEnd1, nubOn, nubOrd) import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb) @@ -203,6 +205,50 @@ gotoDefinition gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans +fixityAtPoint + :: HieAstResult + -> HscEnv + -> TcGblEnv + -> Position + -> IO (Maybe (Maybe Range, [T.Text])) +fixityAtPoint (HAR _ hf _ _ _) env tcGblEnv pos = fmap listToMaybe $ sequence $ pointCommand hf pos fixityInfo + where + fixityInfo :: HieAST a -> IO (Maybe Range, [T.Text]) + fixityInfo ast = do + let range = realSrcSpanToRange $ nodeSpan ast + names = mapMaybe eitherToMaybe $ M.keys $ getNodeIds ast + fixities <- getFixity names + pure (Just range, [toHoverContent fixities]) + + -- We use `handleGhcException` here to prevent hover crashed. + -- Because `runTcInteractive` may throw an exception if something + -- is wrong in it. + getFixity :: [Name] -> IO [(Name, Fixity)] + getFixity names = + liftIO + $ fmap (filter ((/= defaultFixity) . snd) . mapMaybe pickFixity) + $ forM names $ \name -> + (\(_, fixity) -> (name, fixity)) + <$> Util.handleGhcException + (const $ pure (emptyMessages, Nothing)) + (initTcWithGbl env tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) (lookupFixityRn name)) + where + pickFixity :: (Name, Maybe Fixity) -> Maybe (Name, Fixity) + pickFixity (_, Nothing) = Nothing + pickFixity (name, Just f) = Just (name, f) + + toHoverContent [] = "" + toHoverContent fixities = + -- We don't have much fixities on one position, + -- so `nubOn` is acceptable. + let contents = T.intercalate "\n\n" $ fixityText <$> nubOn snd fixities + contents' = "\n" <> sectionSeparator <> contents + in contents' + + fixityText (name, Fixity _ precedence direction) = + printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`" + + -- | Synopsis for the name at a given position. atPoint :: IdeOptions diff --git a/ghcide/test/data/fixity/Fixity.hs b/ghcide/test/data/fixity/Fixity.hs new file mode 100644 index 0000000000..48d24e598b --- /dev/null +++ b/ghcide/test/data/fixity/Fixity.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +module Fixity where +import Control.Monad +import Data.Function (on) +import Control.Applicative ((<|>)) +f1 = (++) +f2 = ($) +f3 = (.) +f4 = (+) +f5 = 1 - 2 +f6 = (<>) +f7 = (>>=) +f8 = (>=>) +f9 = elem +f10 = on +f11 = (||) +f12 = mod +f13 = (**) +f14 = (^) +f15 = (<$) +f16 = seq +f17 = (<|>) + +infixr 7 >>: +infix 9 >>:: +data F = G + { (>>:) :: Int -> Int -> Int + , c :: Int + , (>>::) :: Char + } +f G{..} = undefined + +infixl 1 `f` + +infixr 9 >>>: +(>>>:) :: Int -> Int +(>>>:) x = 3 + +infixl 3 ~\: +(~\:) x y = 3 diff --git a/ghcide/test/data/fixity/FixityImport.hs b/ghcide/test/data/fixity/FixityImport.hs new file mode 100644 index 0000000000..7c7a4dc55c --- /dev/null +++ b/ghcide/test/data/fixity/FixityImport.hs @@ -0,0 +1,5 @@ +module FixityImport where + +import Fixity + +g = (>>>:) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 2b0dfd0ddb..60711d6b39 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -202,6 +202,7 @@ main = do , outlineTests , highlightTests , findDefinitionAndHoverTests + , hoverFixityTests , pluginSimpleTests , pluginParsedResultTests , preprocessorTests @@ -6523,6 +6524,58 @@ expectSameLocations actual expected = do return (filePathToUri fp, l, c)) actual' @?= expected' +hoverFixityTests :: TestTree +hoverFixityTests = testGroup "Explicit fixity" + [ hoverTest "(++)" (Position 5 7) "infixr 5 `++`" + , hoverTest "($)" (Position 6 7) "infixr 0 `$`" + , hoverTest "(.)" (Position 7 7) "infixr 9 `.`" + , hoverTest "(+)" (Position 8 7) "infixl 6 `+`" + , hoverTest "(-)" (Position 9 8) "infixl 6 `-`" + , hoverTest "(<>)" (Position 10 7) "infixr 6 `<>`" + , hoverTest "(>>=)" (Position 11 7) "infixl 1 `>>=`" + , hoverTest "(>=>)" (Position 12 7) "infixr 1 `>=>`" + , hoverTest "elem" (Position 13 7) "infix 4 `elem`" + , hoverTest "on" (Position 14 7) "infixl 0 `on`" + , hoverTest "(||)" (Position 15 8) "infixr 2 `||`" + , hoverTest "mod" (Position 16 8) "infixl 7 `mod`" + , hoverTest "(**)" (Position 17 8) "infixr 8 `**`" + , hoverTest "(^)" (Position 18 8) "infixr 8 `^`" + , hoverTest "(<$)" (Position 19 8) "infixl 4 `<$`" + , hoverTest "seq" (Position 20 9) "infixr 0 `seq`" + , hoverTest "(<|>)" (Position 21 8) "infixl 3 `<|>`" + , hoverTest "fixity define" (Position 23 11) "infixr 7 `>>:`" + , hoverTest "record" (Position 28 10) "infix 9 `>>::`" + , hoverTest "wildcards" (Position 30 5) "infixr 7 `>>:`\n\ninfix 9 `>>::`" + , hoverTest "function" (Position 32 11) "infixl 1 `f`" + , hoverTest "signature" (Position 35 2) "infixr 9 `>>>:`" + , hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`" + , hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`" + , expectFail $ hoverTest "import" (Position 2 18) "Control.Monad***" + -- It will cause error like: "Failed to load interface for \8216Fixity\8217\nIt is not a module in the current program, or in any known package." + -- while we look up fixities from imported local defined module, see test below. + , expectFailBecause "Not support yet" + $ hoverTestImport "imported" (Position 4 7) "infixr 9 `>>>:`" + ] + where + hoverTest = hoverTest' "Fixity.hs" + hoverTestImport = hoverTest' "FixityImport.hs" + + hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree + hoverTest' docName title pos expected = testSessionWithExtraFiles "fixity" title $ \dir -> do + doc <- openDoc (dir docName) "haskell" + void $ waitForTypecheck doc + h <- getHover doc pos + let expected' = "\n" <> sectionSeparator <> expected + case h of + Nothing -> liftIO $ assertFailure "No hover" + Just (Hover contents _) -> case contents of + HoverContentsMS _ -> liftIO $ assertFailure "Unexpected content type" + HoverContents (MarkupContent _ txt) -> + liftIO + $ assertBool ("Failed to find " <> T.unpack expected <> " in " <> T.unpack txt) + $ expected' `T.isInfixOf` txt + closeDoc doc + ---------------------------------------------------------------------- -- Utils ----------------------------------------------------------------------