{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Ide.Plugin.ExplicitFixity(descriptor, Log) where
import Control.DeepSeq
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Maybe
import Data.Either.Extra
import Data.Hashable
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Text as T
import Development.IDE hiding (pluginHandlers,
pluginRules)
import Development.IDE.Core.PositionMapping (idDelta)
import Development.IDE.Core.Shake (addPersistentRule)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.GHC.Compat
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,
pluginResponse)
import Ide.Types hiding (pluginId)
import Language.LSP.Types
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
pluginId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
pluginId)
{ pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
fixityRule Recorder (WithPriority Log)
recorder
, pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentHover
STextDocumentHover PluginMethodHandler IdeState 'TextDocumentHover
hover
, pluginPriority :: Natural
pluginPriority = Natural
ghcideNotificationsPluginPriority forall a. Num a => a -> a -> a
- Natural
1
}
hover :: PluginMethodHandler IdeState TextDocumentHover
hover :: PluginMethodHandler IdeState 'TextDocumentHover
hover IdeState
state PluginId
_ (HoverParams (TextDocumentIdentifier Uri
uri) Position
pos Maybe ProgressToken
_) = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
getNormalizedFilePath Uri
uri
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"ExplicitFixity: Unable to get fixity" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"ExplicitFixity" (IdeState -> ShakeExtras
shakeExtras IdeState
state) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
(FixityMap Map Name Fixity
fixmap, PositionMapping
_) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
useE GetFixity
GetFixity NormalizedFilePath
nfp
(HAR{HieASTs a
hieAst :: ()
hieAst :: HieASTs a
hieAst}, PositionMapping
mapping) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
useE GetHieAst
GetHieAst NormalizedFilePath
nfp
let ns :: [Name]
ns = forall a. HieASTs a -> Position -> PositionMapping -> [Name]
getNamesAtPoint HieASTs a
hieAst Position
pos PositionMapping
mapping
fs :: [(Name, Fixity)]
fs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Name
n -> (Name
n,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name Fixity
fixmap) [Name]
ns
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Name, Fixity)] -> Maybe Hover
toHover forall a b. (a -> b) -> a -> b
$ [(Name, Fixity)]
fs
where
toHover :: [(Name, Fixity)] -> Maybe Hover
toHover :: [(Name, Fixity)] -> Maybe Hover
toHover [] = forall a. Maybe a
Nothing
toHover [(Name, Fixity)]
fixities =
let
contents :: Text
contents = Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$ (Name, Fixity) -> Text
fixityText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Fixity)]
fixities
contents' :: Text
contents' = Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
sectionSeparator forall a. Semigroup a => a -> a -> a
<> Text
contents
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HoverContents -> Maybe Range -> Hover
Hover (MarkupContent -> HoverContents
HoverContents forall a b. (a -> b) -> a -> b
$ Text -> MarkupContent
unmarkedUpContent Text
contents') forall a. Maybe a
Nothing
fixityText :: (Name, Fixity) -> T.Text
fixityText :: (Name, Fixity) -> Text
fixityText (Name
name, Fixity SourceText
_ Int
precedence FixityDirection
direction) =
forall a. Outputable a => a -> Text
printOutputable FixityDirection
direction forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
printOutputable Int
precedence forall a. Semigroup a => a -> a -> a
<> Text
" `" forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
printOutputable Name
name forall a. Semigroup a => a -> a -> a
<> Text
"`"
newtype FixityMap = FixityMap (M.Map Name Fixity)
instance Show FixityMap where
show :: FixityMap -> String
show FixityMap
_ = String
"FixityMap"
instance NFData FixityMap where
rnf :: FixityMap -> ()
rnf (FixityMap Map Name Fixity
xs) = forall a. NFData a => a -> ()
rnf Map Name Fixity
xs
instance NFData Fixity where
rnf :: Fixity -> ()
rnf = forall a. a -> ()
rwhnf
newtype Log = LogShake Shake.Log
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
data GetFixity = GetFixity deriving (Int -> GetFixity -> ShowS
[GetFixity] -> ShowS
GetFixity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetFixity] -> ShowS
$cshowList :: [GetFixity] -> ShowS
show :: GetFixity -> String
$cshow :: GetFixity -> String
showsPrec :: Int -> GetFixity -> ShowS
$cshowsPrec :: Int -> GetFixity -> ShowS
Show, GetFixity -> GetFixity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetFixity -> GetFixity -> Bool
$c/= :: GetFixity -> GetFixity -> Bool
== :: GetFixity -> GetFixity -> Bool
$c== :: GetFixity -> GetFixity -> Bool
Eq, forall x. Rep GetFixity x -> GetFixity
forall x. GetFixity -> Rep GetFixity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetFixity x -> GetFixity
$cfrom :: forall x. GetFixity -> Rep GetFixity x
Generic)
instance Hashable GetFixity
instance NFData GetFixity
type instance RuleResult GetFixity = FixityMap
lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name Fixity)
lookupFixities :: forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcGblEnv -> Set Name -> m (Map Name Fixity)
lookupFixities HscEnv
hscEnv TcGblEnv
tcGblEnv Set Name
names
= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
forall a b. (a -> b) -> a -> b
$ forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hscEnv TcGblEnv
tcGblEnv (RealSrcLoc -> RealSrcSpan
realSrcLocSpan forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"<dummy>" Int
1 Int
1)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
M.traverseMaybeWithKey (\Name
_ IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
v -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
v)
forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
M.fromSet Name -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
lookupFixity Set Name
names
where
lookupFixity :: Name -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
lookupFixity Name
name = do
Maybe Fixity
f <- forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
Util.handleGhcException
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
(forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> RnM Fixity
lookupFixityRn Name
name)
if Maybe Fixity
f forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Fixity
defaultFixity
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Fixity
f
fixityRule :: Recorder (WithPriority Log) -> Rules ()
fixityRule :: Recorder (WithPriority Log) -> Rules ()
fixityRule Recorder (WithPriority Log)
recorder = do
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetFixity
GetFixity NormalizedFilePath
nfp -> do
HAR{RefMap a
refMap :: ()
refMap :: RefMap a
refMap} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetHieAst
GetHieAst NormalizedFilePath
nfp
HscEnv
env <- HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
TcGblEnv
tcGblEnv <- TcModuleResult -> TcGblEnv
tmrTypechecked forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ TypeCheck
TypeCheck NormalizedFilePath
nfp
Map Name Fixity
fs <- forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcGblEnv -> Set Name -> m (Map Name Fixity)
lookupFixities HscEnv
env TcGblEnv
tcGblEnv (forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic (\(Right Name
n) -> Name
n) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Set a -> Set a
S.filter forall a b. Either a b -> Bool
isRight forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
M.keysSet RefMap a
refMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just (Map Name Fixity -> FixityMap
FixityMap Map Name Fixity
fs))
forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
-> IdeAction (Maybe (v, PositionDelta, TextDocumentVersion)))
-> Rules ()
addPersistentRule GetFixity
GetFixity forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Map Name Fixity -> FixityMap
FixityMap forall k a. Map k a
M.empty, PositionDelta
idDelta, forall a. Maybe a
Nothing)