{-# 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
    -- 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
    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 -- Splicing fixity info
                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
                -- 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 :: (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

-- | 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
    = 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 -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates
        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))

    -- 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 (Map Name Fixity -> FixityMap
FixityMap forall k a. Map k a
M.empty, PositionDelta
idDelta, forall a. Maybe a
Nothing)