{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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           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.PluginUtils
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.Plugin.Error
import           Ide.Types                            hiding (pluginId)
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
pluginId = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
pluginId Text
"Provides fixity information in hovers")
    { pluginRules = fixityRule recorder
    , pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover
    -- Make this plugin has a lower priority than ghcide's plugin to ensure
    -- type info display first.
    , pluginPriority = ghcideNotificationsPluginPriority - 1
    }

hover :: PluginMethodHandler IdeState Method_TextDocumentHover
hover :: PluginMethodHandler IdeState 'Method_TextDocumentHover
hover IdeState
state PluginId
_ (HoverParams (TextDocumentIdentifier Uri
uri) Position
pos Maybe ProgressToken
_) = do
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (HandlerM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    String
-> ShakeExtras
-> ExceptT PluginError IdeAction (Hover |? Null)
-> ExceptT PluginError (HandlerM Config) (Hover |? Null)
forall (m :: * -> *) e a.
MonadIO m =>
String -> ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a
runIdeActionE String
"ExplicitFixity" (IdeState -> ShakeExtras
shakeExtras IdeState
state) (ExceptT PluginError IdeAction (Hover |? Null)
 -> ExceptT PluginError (HandlerM Config) (Hover |? Null))
-> ExceptT PluginError IdeAction (Hover |? Null)
-> ExceptT PluginError (HandlerM Config) (Hover |? Null)
forall a b. (a -> b) -> a -> b
$ do
      (FixityMap Map Name Fixity
fixmap, PositionMapping
_) <-  GetFixity
-> NormalizedFilePath
-> ExceptT PluginError IdeAction (FixityMap, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError IdeAction (v, PositionMapping)
useWithStaleFastE GetFixity
GetFixity NormalizedFilePath
nfp
      (HAR{HieASTs a
hieAst :: HieASTs a
hieAst :: ()
hieAst}, PositionMapping
mapping) <- GetHieAst
-> NormalizedFilePath
-> ExceptT PluginError IdeAction (HieAstResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError IdeAction (v, PositionMapping)
useWithStaleFastE GetHieAst
GetHieAst NormalizedFilePath
nfp
      let ns :: [Name]
ns = HieASTs a -> Position -> PositionMapping -> [Name]
forall a. HieASTs a -> Position -> PositionMapping -> [Name]
getNamesAtPoint HieASTs a
hieAst Position
pos PositionMapping
mapping
          fs :: [(Name, Fixity)]
fs = (Name -> Maybe (Name, Fixity)) -> [Name] -> [(Name, Fixity)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Name
n -> (Name
n,) (Fixity -> (Name, Fixity)) -> Maybe Fixity -> Maybe (Name, Fixity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Map Name Fixity -> Maybe Fixity
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name Fixity
fixmap) [Name]
ns
      (Hover |? Null) -> ExceptT PluginError IdeAction (Hover |? Null)
forall a. a -> ExceptT PluginError IdeAction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Hover |? Null) -> ExceptT PluginError IdeAction (Hover |? Null))
-> (Hover |? Null) -> ExceptT PluginError IdeAction (Hover |? Null)
forall a b. (a -> b) -> a -> b
$ Maybe Hover -> Hover |? Null
forall a. Maybe a -> a |? Null
maybeToNull (Maybe Hover -> Hover |? Null) -> Maybe Hover -> Hover |? Null
forall a b. (a -> b) -> a -> b
$ [(Name, Fixity)] -> Maybe Hover
toHover [(Name, Fixity)]
fs
    where
        toHover :: [(Name, Fixity)] -> Maybe Hover
        toHover :: [(Name, Fixity)] -> Maybe Hover
toHover [] = Maybe Hover
forall a. Maybe a
Nothing
        toHover [(Name, Fixity)]
fixities =
            let -- Splicing fixity info
                contents :: Text
contents = Text -> [Text] -> Text
T.intercalate Text
"\n\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Name, Fixity) -> Text
fixityText ((Name, Fixity) -> Text) -> [(Name, Fixity)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Fixity)]
fixities
                -- Append to the previous hover content
                contents' :: Text
contents' = Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sectionSeparator Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contents
            in  Hover -> Maybe Hover
forall a. a -> Maybe a
Just (Hover -> Maybe Hover) -> Hover -> Maybe Hover
forall a b. (a -> b) -> a -> b
$ (MarkupContent |? (MarkedString |? [MarkedString]))
-> Maybe Range -> Hover
Hover (MarkupContent -> MarkupContent |? (MarkedString |? [MarkedString])
forall a b. a -> a |? b
InL (Text -> MarkupContent
mkPlainText Text
contents')) Maybe Range
forall a. Maybe a
Nothing

        fixityText :: (Name, Fixity) -> T.Text
        fixityText :: (Name, Fixity) -> Text
fixityText (Name
name, Fixity SourceText
_ Int
precedence FixityDirection
direction) =
            FixityDirection -> Text
forall a. Outputable a => a -> Text
printOutputable FixityDirection
direction Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Outputable a => a -> Text
printOutputable Int
precedence Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
forall a. Outputable a => a -> Text
printOutputable Name
name Text -> Text -> Text
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) = Map Name Fixity -> ()
forall a. NFData a => a -> ()
rnf Map Name Fixity
xs

instance NFData Fixity where
  rnf :: Fixity -> ()
rnf = Fixity -> ()
forall a. a -> ()
rwhnf

newtype Log = LogShake Shake.Log

instance Pretty Log where
    pretty :: forall ann. Log -> Doc ann
pretty = \case
        LogShake Log
log -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
log

data GetFixity = GetFixity deriving (Int -> GetFixity -> ShowS
[GetFixity] -> ShowS
GetFixity -> String
(Int -> GetFixity -> ShowS)
-> (GetFixity -> String)
-> ([GetFixity] -> ShowS)
-> Show GetFixity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetFixity -> ShowS
showsPrec :: Int -> GetFixity -> ShowS
$cshow :: GetFixity -> String
show :: GetFixity -> String
$cshowList :: [GetFixity] -> ShowS
showList :: [GetFixity] -> ShowS
Show, GetFixity -> GetFixity -> Bool
(GetFixity -> GetFixity -> Bool)
-> (GetFixity -> GetFixity -> Bool) -> Eq GetFixity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetFixity -> GetFixity -> Bool
== :: GetFixity -> GetFixity -> Bool
$c/= :: GetFixity -> GetFixity -> Bool
/= :: GetFixity -> GetFixity -> Bool
Eq, (forall x. GetFixity -> Rep GetFixity x)
-> (forall x. Rep GetFixity x -> GetFixity) -> Generic GetFixity
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
$cfrom :: forall x. GetFixity -> Rep GetFixity x
from :: forall x. GetFixity -> Rep GetFixity x
$cto :: forall x. Rep GetFixity x -> GetFixity
to :: forall x. Rep GetFixity x -> GetFixity
Generic)

instance Hashable GetFixity
instance NFData GetFixity

type instance RuleResult GetFixity = FixityMap

-- | Convert a HieAST to FixityTree with fixity info gathered
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
    = IO (Map Name Fixity) -> m (Map Name Fixity)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO (Map Name Fixity) -> m (Map Name Fixity))
-> IO (Map Name Fixity) -> m (Map Name Fixity)
forall a b. (a -> b) -> a -> b
$ ((Messages TcRnMessage, Maybe (Map Name Fixity))
 -> Map Name Fixity)
-> IO (Messages TcRnMessage, Maybe (Map Name Fixity))
-> IO (Map Name Fixity)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Name Fixity -> Maybe (Map Name Fixity) -> Map Name Fixity
forall a. a -> Maybe a -> a
fromMaybe Map Name Fixity
forall k a. Map k a
M.empty (Maybe (Map Name Fixity) -> Map Name Fixity)
-> ((Messages TcRnMessage, Maybe (Map Name Fixity))
    -> Maybe (Map Name Fixity))
-> (Messages TcRnMessage, Maybe (Map Name Fixity))
-> Map Name Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Messages TcRnMessage, Maybe (Map Name Fixity))
-> Maybe (Map Name Fixity)
forall a b. (a, b) -> b
snd)
    (IO (Messages TcRnMessage, Maybe (Map Name Fixity))
 -> IO (Map Name Fixity))
-> IO (Messages TcRnMessage, Maybe (Map Name Fixity))
-> IO (Map Name Fixity)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM (Map Name Fixity)
-> IO (Messages TcRnMessage, Maybe (Map Name Fixity))
forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl HscEnv
hscEnv TcGblEnv
tcGblEnv (RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"<dummy>" Int
1 Int
1)
    (TcM (Map Name Fixity)
 -> IO (Messages TcRnMessage, Maybe (Map Name Fixity)))
-> TcM (Map Name Fixity)
-> IO (Messages TcRnMessage, Maybe (Map Name Fixity))
forall a b. (a -> b) -> a -> b
$ (Name
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
-> Map Name (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
-> TcM (Map Name Fixity)
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)
    (Map Name (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
 -> TcM (Map Name Fixity))
-> Map Name (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
-> TcM (Map Name Fixity)
forall a b. (a -> b) -> a -> b
$ (Name -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
-> Set Name
-> Map Name (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
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 <- (GhcException -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
Util.handleGhcException
        (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
-> GhcException -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall a b. a -> b -> a
const (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
 -> GhcException -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
-> GhcException
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall a b. (a -> b) -> a -> b
$ Maybe Fixity -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Fixity
forall a. Maybe a
Nothing)
        (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just (Fixity -> Maybe Fixity)
-> IOEnv (Env TcGblEnv TcLclEnv) Fixity
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFixityRn Name
name)
      if Maybe Fixity
f Maybe Fixity -> Maybe Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
defaultFixity
      then Maybe Fixity -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Fixity
forall a. Maybe a
Nothing
      else Maybe Fixity -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
    Recorder (WithPriority Log)
-> (GetFixity
    -> NormalizedFilePath -> Action (IdeResult FixityMap))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((GetFixity -> NormalizedFilePath -> Action (IdeResult FixityMap))
 -> Rules ())
-> (GetFixity
    -> NormalizedFilePath -> Action (IdeResult FixityMap))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetFixity
GetFixity NormalizedFilePath
nfp -> do
        HAR{RefMap a
refMap :: RefMap a
refMap :: ()
refMap} <- GetHieAst -> NormalizedFilePath -> Action HieAstResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetHieAst
GetHieAst NormalizedFilePath
nfp
        HscEnv
env <- HscEnvEq -> HscEnv
hscEnv (HscEnvEq -> HscEnv) -> Action HscEnvEq -> Action HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSessionDeps -> NormalizedFilePath -> Action HscEnvEq
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates
        TcGblEnv
tcGblEnv <- TcModuleResult -> TcGblEnv
tmrTypechecked (TcModuleResult -> TcGblEnv)
-> Action TcModuleResult -> Action TcGblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeCheck -> NormalizedFilePath -> Action TcModuleResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ TypeCheck
TypeCheck NormalizedFilePath
nfp
        Map Name Fixity
fs <- HscEnv -> TcGblEnv -> Set Name -> Action (Map Name Fixity)
forall (m :: * -> *).
MonadIO m =>
HscEnv -> TcGblEnv -> Set Name -> m (Map Name Fixity)
lookupFixities HscEnv
env TcGblEnv
tcGblEnv ((Either ModuleName Name -> Name)
-> Set (Either ModuleName Name) -> Set Name
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic (\(Right Name
n) -> Name
n) (Set (Either ModuleName Name) -> Set Name)
-> Set (Either ModuleName Name) -> Set Name
forall a b. (a -> b) -> a -> b
$ (Either ModuleName Name -> Bool)
-> Set (Either ModuleName Name) -> Set (Either ModuleName Name)
forall a. (a -> Bool) -> Set a -> Set a
S.filter Either ModuleName Name -> Bool
forall a b. Either a b -> Bool
isRight (Set (Either ModuleName Name) -> Set (Either ModuleName Name))
-> Set (Either ModuleName Name) -> Set (Either ModuleName Name)
forall a b. (a -> b) -> a -> b
$ RefMap a -> Set (Either ModuleName Name)
forall k a. Map k a -> Set k
M.keysSet RefMap a
refMap)
        IdeResult FixityMap -> Action (IdeResult FixityMap)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], FixityMap -> Maybe FixityMap
forall a. a -> Maybe a
Just (Map Name Fixity -> FixityMap
FixityMap Map Name Fixity
fs))

    -- Ensure that this plugin doesn't block on startup
    GetFixity
-> (NormalizedFilePath
    -> IdeAction (Maybe (FixityMap, PositionDelta, Maybe Int32)))
-> Rules ()
forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> Rules ()
addPersistentRule GetFixity
GetFixity ((NormalizedFilePath
  -> IdeAction (Maybe (FixityMap, PositionDelta, Maybe Int32)))
 -> Rules ())
-> (NormalizedFilePath
    -> IdeAction (Maybe (FixityMap, PositionDelta, Maybe Int32)))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
_ -> Maybe (FixityMap, PositionDelta, Maybe Int32)
-> IdeAction (Maybe (FixityMap, PositionDelta, Maybe Int32))
forall a. a -> IdeAction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FixityMap, PositionDelta, Maybe Int32)
 -> IdeAction (Maybe (FixityMap, PositionDelta, Maybe Int32)))
-> Maybe (FixityMap, PositionDelta, Maybe Int32)
-> IdeAction (Maybe (FixityMap, PositionDelta, Maybe Int32))
forall a b. (a -> b) -> a -> b
$ (FixityMap, PositionDelta, Maybe Int32)
-> Maybe (FixityMap, PositionDelta, Maybe Int32)
forall a. a -> Maybe a
Just (Map Name Fixity -> FixityMap
FixityMap Map Name Fixity
forall k a. Map k a
M.empty, PositionDelta
idDelta, Maybe Int32
forall a. Maybe a
Nothing)