Implement explicit fixity in ghcide

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

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

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 "<dummy>" 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

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

ghcide/test/data/fixity/FixityImport.hs

@@ -0,0 +1,5 @@
+module FixityImport where
+
+import Fixity
+
+g = (>>>:)

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
 ----------------------------------------------------------------------