{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use nubOrdOn" #-}

module Ide.Plugin.ExplicitFixity(descriptor) where

import           Control.DeepSeq
import           Control.Monad                        (forM)
import           Control.Monad.IO.Class               (MonadIO, liftIO)
import           Data.Coerce                          (coerce)
import           Data.Either.Extra
import           Data.Hashable
import           Data.List.Extra                      (nubOn)
import qualified Data.Map                             as M
import           Data.Maybe
import           Data.Monoid
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           Development.IDE.GHC.Compat.Util      (FastString)
import qualified Development.IDE.GHC.Compat.Util      as Util
import           Development.IDE.LSP.Notifications    (ghcideNotificationsPluginPriority)
import           GHC.Generics                         (Generic)
import           Ide.PluginUtils                      (getNormalizedFilePath,
                                                       handleMaybeM,
                                                       pluginResponse)
import           Ide.Types                            hiding (pluginId)
import           Language.LSP.Types

pluginId :: PluginId
pluginId :: PluginId
pluginId = PluginId
"explicitFixity"

descriptor :: Recorder (WithPriority Log) -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log) -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder = (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
    -- Make this plugin has a lower priority than ghcide's plugin to ensure
    -- type info display first.
    , 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
    FixityTrees
fixityTrees <- 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 -> IdeState -> Action a -> IO a
runAction String
"ExplicitFixity.GetFixity" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetFixity
GetFixity NormalizedFilePath
nfp
    -- We don't have much fixities on one position, so `nubOn` is acceptable.
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Text, Fixity)] -> Maybe Hover
toHover forall a b. (a -> b) -> a -> b
$ forall b a. Eq b => (a -> b) -> [a] -> [a]
nubOn forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. FixityTrees -> Position -> (FixityTree -> [a]) -> [a]
findInTree FixityTrees
fixityTrees Position
pos FixityTree -> [(Text, Fixity)]
fNodeFixty
    where
        toHover :: [(T.Text, Fixity)] -> Maybe Hover
        toHover :: [(Text, Fixity)] -> Maybe Hover
toHover [] = forall a. Maybe a
Nothing
        toHover [(Text, Fixity)]
fixities =
            let -- Splicing fixity info
                contents :: Text
contents = Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$ (Text, Fixity) -> Text
fixityText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Fixity)]
fixities
                -- Append to the previous hover content
                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 :: (T.Text, Fixity) -> T.Text
        fixityText :: (Text, Fixity) -> Text
fixityText (Text
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
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"`"

-- | Transferred from ghc `selectSmallestContaining`
selectSmallestContainingForFixityTree :: Span -> FixityTree -> Maybe FixityTree
selectSmallestContainingForFixityTree :: Span -> FixityTree -> Maybe FixityTree
selectSmallestContainingForFixityTree Span
sp FixityTree
node
    | Span
sp Span -> Span -> Bool
`containsSpan` FixityTree -> Span
fNodeSpan FixityTree
node = forall a. a -> Maybe a
Just FixityTree
node
    | FixityTree -> Span
fNodeSpan FixityTree
node Span -> Span -> Bool
`containsSpan` Span
sp = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> FixityTree -> Maybe FixityTree
selectSmallestContainingForFixityTree Span
sp) forall a b. (a -> b) -> a -> b
$ FixityTree -> [FixityTree]
fNodeChildren FixityTree
node
        , forall a. Maybe a -> First a
First (forall a. a -> Maybe a
Just FixityTree
node)
        ]
    | Bool
otherwise = forall a. Maybe a
Nothing

-- | Transferred from ghcide `pointCommand`
findInTree :: FixityTrees -> Position -> (FixityTree -> [a]) -> [a]
findInTree :: forall a. FixityTrees -> Position -> (FixityTree -> [a]) -> [a]
findInTree FixityTrees
tree Position
pos FixityTree -> [a]
k =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey FixityTrees
tree forall a b. (a -> b) -> a -> b
$ \FastString
fs FixityTree
ast ->
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] FixityTree -> [a]
k (Span -> FixityTree -> Maybe FixityTree
selectSmallestContainingForFixityTree (FastString -> Span
sp FastString
fs) FixityTree
ast)
    where
        sloc :: FastString -> RealSrcLoc
sloc FastString
fs = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fs (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
lineforall a. Num a => a -> a -> a
+UInt
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
chaforall a. Num a => a -> a -> a
+UInt
1)
        sp :: FastString -> Span
sp FastString
fs = RealSrcLoc -> RealSrcLoc -> Span
mkRealSrcSpan (FastString -> RealSrcLoc
sloc FastString
fs) (FastString -> RealSrcLoc
sloc FastString
fs)
        line :: UInt
line = Position -> UInt
_line Position
pos
        cha :: UInt
cha = Position -> UInt
_character Position
pos

data FixityTree = FNode
    { FixityTree -> Span
fNodeSpan     :: Span
    , FixityTree -> [FixityTree]
fNodeChildren :: [FixityTree]
    , FixityTree -> [(Text, Fixity)]
fNodeFixty    :: [(T.Text, Fixity)]
    } deriving (forall x. Rep FixityTree x -> FixityTree
forall x. FixityTree -> Rep FixityTree x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FixityTree x -> FixityTree
$cfrom :: forall x. FixityTree -> Rep FixityTree x
Generic)

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

instance Show FixityTree where
    show :: FixityTree -> String
show FixityTree
_ = String
"<FixityTree>"

type FixityTrees = M.Map FastString FixityTree

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

fakeFixityTrees :: FixityTrees
fakeFixityTrees :: FixityTrees
fakeFixityTrees = forall k a. Map k a
M.empty

-- | Convert a HieASTs to FixityTrees with fixity info gathered
hieAstsToFixitTrees :: MonadIO m => HscEnv -> TcGblEnv -> HieASTs a -> m FixityTrees
hieAstsToFixitTrees :: forall (m :: * -> *) a.
MonadIO m =>
HscEnv -> TcGblEnv -> HieASTs a -> m FixityTrees
hieAstsToFixitTrees HscEnv
hscEnv TcGblEnv
tcGblEnv HieASTs a
ast =
    -- coerce to avoid compatibility issues.
    forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysWith forall a b. a -> b -> a
const coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall (m :: * -> *) a.
MonadIO m =>
HscEnv -> TcGblEnv -> HieAST a -> m FixityTree
hieAstToFixtyTree HscEnv
hscEnv TcGblEnv
tcGblEnv) (forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
ast))

-- | Convert a HieAST to FixityTree with fixity info gathered
hieAstToFixtyTree :: MonadIO m => HscEnv -> TcGblEnv -> HieAST a -> m FixityTree
hieAstToFixtyTree :: forall (m :: * -> *) a.
MonadIO m =>
HscEnv -> TcGblEnv -> HieAST a -> m FixityTree
hieAstToFixtyTree HscEnv
hscEnv TcGblEnv
tcGblEnv HieAST a
ast = case HieAST a
ast of
    (Node SourcedNodeInfo a
_ Span
span []) -> Span -> [FixityTree] -> [(Text, Fixity)] -> FixityTree
FNode Span
span [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m [(Text, Fixity)]
getFixities
    (Node SourcedNodeInfo a
_ Span
span [HieAST a]
children) -> do
        [(Text, Fixity)]
fixities <- forall (m :: * -> *). MonadIO m => m [(Text, Fixity)]
getFixities
        [FixityTree]
childrenFixities <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
MonadIO m =>
HscEnv -> TcGblEnv -> HieAST a -> m FixityTree
hieAstToFixtyTree HscEnv
hscEnv TcGblEnv
tcGblEnv) [HieAST a]
children
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Span -> [FixityTree] -> [(Text, Fixity)] -> FixityTree
FNode Span
span [FixityTree]
childrenFixities [(Text, Fixity)]
fixities
    where
        -- Names at the current ast node
        names :: [Name]
        names :: [Name]
names = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. Either a b -> Maybe b
eitherToMaybe forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ forall a.
HieAST a -> Map (Either ModuleName Name) (IdentifierDetails a)
getNodeIds HieAST a
ast

        getFixities :: MonadIO m => m [(T.Text, Fixity)]
        getFixities :: forall (m :: * -> *). MonadIO m => m [(Text, Fixity)]
getFixities = 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 -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Fixity
defaultFixity) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Maybe Fixity) -> Maybe (Text, Fixity)
pickFixity)
            forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names forall a b. (a -> b) -> a -> b
$ \Name
name ->
                (,) (forall a. Outputable a => a -> Text
printOutputable Name
name)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 e. Messages e
emptyMessages, forall a. Maybe a
Nothing))
                    (forall r.
HscEnv
-> TcGblEnv
-> Span
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hscEnv TcGblEnv
tcGblEnv (RealSrcLoc -> Span
realSrcLocSpan forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"<dummy>" Int
1 Int
1) (Name -> RnM Fixity
lookupFixityRn Name
name))

        pickFixity :: (T.Text, Maybe Fixity) -> Maybe (T.Text, Fixity)
        pickFixity :: (Text, Maybe Fixity) -> Maybe (Text, Fixity)
pickFixity (Text
_, Maybe Fixity
Nothing)   = forall a. Maybe a
Nothing
        pickFixity (Text
name, Just Fixity
f) = forall a. a -> Maybe a
Just (Text
name, 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{HieASTs a
hieAst :: ()
hieAst :: HieASTs a
hieAst} <- 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_ GhcSession
GhcSession 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
        FixityTrees
trees <- forall (m :: * -> *) a.
MonadIO m =>
HscEnv -> TcGblEnv -> HieASTs a -> m FixityTrees
hieAstsToFixitTrees HscEnv
env TcGblEnv
tcGblEnv HieASTs a
hieAst
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just FixityTrees
trees)

    -- Ensure that this plugin doesn't block on startup
    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 (FixityTrees
fakeFixityTrees, PositionDelta
idDelta, forall a. Maybe a
Nothing)