init hls-explicit-fixity-plugin

Author: July541

cabal.project

@@ -29,6 +29,7 @@ packages:
          ./plugins/hls-selection-range-plugin
          ./plugins/hls-change-type-signature-plugin
          ./plugins/hls-gadt-plugin
+         ./plugins/hls-explicit-fixity-plugin
 
 -- Standard location for temporary packages needed for particular environments
 -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script

exe/Plugins.hs

@@ -86,6 +86,11 @@ import           Ide.Plugin.ChangeTypeSignature    as ChangeTypeSignature
 #if gadt
 import           Ide.Plugin.GADT                   as GADT
 #endif
+
+#if explicitFixity
+import          Ide.Plugin.ExplicitFixity          as ExplicitFixity
+#endif
+
 -- formatters
 
 #if floskell
@@ -201,7 +206,11 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
     -- The ghcide descriptors should come last so that the notification handlers
     -- (which restart the Shake build) run after everything else
       GhcIde.descriptors pluginRecorder
+#if explicitFixity
+        ++ [ExplicitFixity.descriptor "explicitFixity"]
+#endif
     examplePlugins =
       [Example.descriptor  pluginRecorder "eg"
       ,Example2.descriptor pluginRecorder "eg2"
       ]
+

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
@@ -551,6 +555,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
@@ -567,7 +572,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
@@ -612,7 +617,7 @@ 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 (..))
@@ -687,6 +692,7 @@ import qualified Panic                        as Plain
 #endif
 import           Parser
 import           PatSyn
+import           RnFixity
 #if MIN_VERSION_ghc(8,8,0)
 import           Plugins
 #endif

haskell-language-server.cabal

@@ -191,6 +191,11 @@ flag gadt
   default:     True
   manual:      True
 
+flag explicitFixity
+  description: Enable explicitFixity plugin
+  default:     True
+  manual:      True
+
 -- formatters
 
 flag floskell
@@ -318,6 +323,11 @@ common gadt
     build-depends: hls-gadt-plugin ^>= 1.0
     cpp-options: -Dgadt
 
+common explicitFixity
+  if flag(explicitFixity)
+    build-depends: hls-explicit-fixity-plugin ^>= 1.0
+    cpp-options: -DexplicitFixity
+
 -- formatters
 
 common floskell
@@ -370,6 +380,7 @@ executable haskell-language-server
                     , qualifyImportedNames
                     , selectionRange
                     , gadt
+                    , explicitFixity
                     , floskell
                     , fourmolu
                     , ormolu

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

@@ -0,0 +1,60 @@
+cabal-version:      2.4
+name:               hls-explicit-fixity-plugin
+version:            1.0.0.0
+synopsis:           Show fixity explicitly
+description:
+  Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-explicit-fixity-plugin#readme>
+
+license:            Apache-2.0
+license-file:       LICENSE
+author:             Lei Zhu
+maintainer:         [email protected]
+category:           Development
+build-type:         Simple
+extra-source-files:
+  LICENSE
+  test/testdata/*.hs
+
+library
+  exposed-modules:    Ide.Plugin.ExplicitFixity
+
+  hs-source-dirs:     src
+  build-depends:
+    , aeson
+    , base                  >=4.12 && <5
+    , containers
+    , extra
+    , ghc
+    , ghcide                ^>= 1.7
+    , ghc-boot-th
+    , ghc-exactprint
+    , hls-plugin-api        ^>= 1.4
+    , lens
+    , lsp                    >=1.2.0.1
+    , mtl
+    , text
+    , transformers
+    , unordered-containers
+
+  ghc-options:
+    -Wall
+    -Wno-name-shadowing
+    -Wno-unticked-promoted-constructors
+  default-language:   Haskell2010
+  default-extensions: DataKinds
+
+test-suite tests
+  type:             exitcode-stdio-1.0
+  default-language: Haskell2010
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+    , base
+    , filepath
+    , hls-explicit-fixity-plugin
+    , hls-test-utils              ^>=1.3
+    , lens
+    , lsp
+    , lsp-test
+    , text

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

@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Functor law" #-}
+
+module Ide.Plugin.ExplicitFixity where
+import           Control.Monad                 (forM)
+import           Control.Monad.IO.Class        (liftIO)
+import           Data.Bifunctor
+import           Data.List.Extra               (nubOn)
+import qualified Data.Map                      as M
+import           Data.Maybe
+import qualified Data.Text                     as T
+import           Development.IDE               hiding (pluginHandlers)
+import           Development.IDE.GHC.Compat
+import           Development.IDE.Spans.AtPoint (pointCommand)
+import           Ide.PluginUtils               (getNormalizedFilePath,
+                                                handleMaybeM, pluginResponse)
+import           Ide.Types
+import           Language.LSP.Types
+
+descriptor :: PluginId -> PluginDescriptor IdeState
+descriptor plId = (defaultPluginDescriptor plId)
+    { pluginHandlers = mkPluginHandler STextDocumentHover hover
+    }
+
+hover :: PluginMethodHandler IdeState TextDocumentHover
+hover state plId (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do
+    nfp <- getNormalizedFilePath plId uri
+    har <- handleMaybeM "Unable to get HieResult"
+        $ liftIO
+        $ runAction "ExplicitFixity.HieResult" state
+        $ use GetHieAst nfp
+
+    -- Names at the position
+    let names = case har of
+            HAR _ asts _ _ _ -> concat
+                $ pointCommand asts pos
+                $ \ast -> mapMaybe (either (const Nothing) Just) $ M.keys $ getNodeIds ast
+
+    -- Get fixity from HscEnv for local defined operator will crash the plugin,
+    -- we first try to use ModIface to get fixities, and then use
+    -- HscEnv if ModIface doesn't available.
+    fixities <- getFixityFromModIface nfp names
+
+    if isJust fixities then pure fixities else getFixityFromEnv nfp names
+    where
+        -- | For local definition
+        getFixityFromModIface nfp names = do
+            hi <- handleMaybeM "Unable to get ModIface"
+                $ liftIO
+                $ runAction "ExplicitFixity.GetModIface" state
+                $ use GetModIface nfp
+            let iface = hirModIface hi
+                fixities = filter (\(_, fixity) -> fixity /= defaultFixity)
+                    $ map (\name -> (name, mi_fix iface (occName name))) names
+            -- We don't have much fixities on one position,
+            -- so `nubOn` is acceptable.
+            pure $ toHover $ nubOn snd fixities
+
+        -- | Get fixity from HscEnv
+        getFixityFromEnv nfp names = do
+            env <- fmap hscEnv
+                $ handleMaybeM "Unable to get GhcSession"
+                $ liftIO
+                $ runAction "ExplicitFixity.GhcSession" state
+                $ use GhcSession nfp
+            fixities <- liftIO
+                $ fmap (map (second fromJust))
+                -- Ignore all default fixity
+                $ fmap (filter (\(_, fixity) -> isJust fixity && fromJust fixity /= defaultFixity))
+                $ forM names $ \name ->
+                    (\(_, fixity) -> (name, fixity)) <$> runTcInteractive env (lookupFixityRn name)
+            pure $ toHover $ nubOn snd fixities
+
+        toHover [] = Nothing
+        toHover fixities =
+            let contents = T.intercalate "\n\n" $ fixityText <$> fixities
+                contents' = "\n" <> sectionSeparator <> contents
+            in  Just $ Hover (HoverContents $ unmarkedUpContent contents') Nothing
+
+        fixityText (name, Fixity _ precedence direction) =
+            printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`"

plugins/hls-explicit-fixity-plugin/test/Main.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+import Test.Hls
+import Ide.Plugin.ExplicitFixity (descriptor)
+import qualified Data.Text as T
+import System.FilePath
+
+
+plugin :: PluginDescriptor IdeState
+plugin = descriptor "ExplicitFixity"
+
+main :: IO ()
+main = defaultTestRunner test
+
+test = testCase "" $ runSessionWithServer plugin testDataDir $ do
+    doc <- openDoc "B.hs" "haskell"
+    waitForProgressDone
+    d <- getHover doc (Position 6 8)
+    liftIO $ print d
+
+testDataDir :: FilePath
+testDataDir = "test" </> "testdata"

plugins/hls-explicit-fixity-plugin/test/testdata/A.hs

@@ -0,0 +1,14 @@
+module A where
+import Control.Monad
+import Data.Function (on)
+
+f1 = (++)
+f2 = ($)
+f3 = (.)
+f4 = (-)
+f5 = 1 - 2
+f6 = (<>)
+f7 = (>>=)
+f8 = (>=>)
+f9 = elem
+f10 = on

plugins/hls-explicit-fixity-plugin/test/testdata/B.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE RecordWildCards #-}
+module C where
+infixr 7 >>:
+infix 9 >>::
+data F = G
+    { (>>:) :: Int -> Int -> Int
+    , c :: Int
+    , (>>::) :: Char
+    }
+f G{..} = undefined
+
+infixr 9 >>>:
+(>>>:) :: Int -> Int
+(>>>:) x = 3
+
+infixl 3 ~\:
+(~\:) x y = 3

stack-lts16.yaml

@@ -31,6 +31,7 @@ packages:
   - ./plugins/hls-selection-range-plugin
   - ./plugins/hls-change-type-signature-plugin
   - ./plugins/hls-gadt-plugin
+  - ./plugins/hls-explicit-fixity-plugin
 
 ghc-options:
   "$everything": -haddock

stack-lts19.yaml

@@ -31,6 +31,7 @@ packages:
   - ./plugins/hls-selection-range-plugin
   - ./plugins/hls-change-type-signature-plugin
   - ./plugins/hls-gadt-plugin
+  - ./plugins/hls-explicit-fixity-plugin
 
 ghc-options:
   "$everything": -haddock

stack.yaml

@@ -32,6 +32,7 @@ packages:
 - ./plugins/hls-selection-range-plugin
 - ./plugins/hls-change-type-signature-plugin
 - ./plugins/hls-gadt-plugin
+- ./plugins/hls-explicit-fixity-plugin
 
 extra-deps:
 - Chart-1.9.3@sha256:640a38463318b070d80a049577e4f0b3322df98290abb7afcf0cb74a4ad5b512,2948