{-# LANGUAGE CPP             #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE PatternSynonyms #-}

module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where

import           Control.Lens                         (toListOf)
import           Control.Monad.IO.Class               (MonadIO (liftIO))
import qualified Data.ByteString                      as BS
import           Data.Data.Lens                       (biplate)
import           Data.HashSet                         (HashSet)
import qualified Data.HashSet                         as Set
import           Data.IORef
import qualified Data.Map.Strict                      as Map
import           Data.String                          (fromString)
import           Development.IDE                      (GetParsedModuleWithComments (GetParsedModuleWithComments),
                                                       IdeState,
                                                       LinkableType (BCOLinkable),
                                                       NeedsCompilation (NeedsCompilation),
                                                       NormalizedFilePath,
                                                       RuleBody (RuleNoDiagnostics),
                                                       Rules, defineEarlyCutoff,
                                                       encodeLinkableType,
                                                       fromNormalizedFilePath,
                                                       realSrcSpanToRange,
                                                       useWithStale_, use_)
import           Development.IDE.Core.PositionMapping (toCurrentRange)
import           Development.IDE.Core.Rules           (needsCompilationRule)
import           Development.IDE.Core.Shake           (IsIdeGlobal,
                                                       RuleBody (RuleWithCustomNewnessCheck),
                                                       addIdeGlobal,
                                                       getIdeGlobalAction,
                                                       getIdeGlobalState)
import           Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat           as SrcLoc
import qualified Development.IDE.GHC.Compat.Util      as FastString
import           Development.IDE.Graph                (alwaysRerun)
import           GHC.Parser.Annotation
import           Ide.Logger                           (Recorder, WithPriority,
                                                       cmapWithPrio)
import           Ide.Plugin.Eval.Types


rules :: Recorder (WithPriority Log) -> Rules ()
rules :: Recorder (WithPriority Log) -> Rules ()
rules Recorder (WithPriority Log)
recorder = do
    Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
redefinedNeedsCompilation Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
isEvaluatingRule Recorder (WithPriority Log)
recorder
    EvaluatingVar -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal (EvaluatingVar -> Rules ())
-> (IORef (HashSet NormalizedFilePath) -> EvaluatingVar)
-> IORef (HashSet NormalizedFilePath)
-> Rules ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (HashSet NormalizedFilePath) -> EvaluatingVar
EvaluatingVar (IORef (HashSet NormalizedFilePath) -> Rules ())
-> Rules (IORef (HashSet NormalizedFilePath)) -> Rules ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (IORef (HashSet NormalizedFilePath))
-> Rules (IORef (HashSet NormalizedFilePath))
forall a. IO a -> Rules a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(HashSet NormalizedFilePath
-> IO (IORef (HashSet NormalizedFilePath))
forall a. a -> IO (IORef a)
newIORef HashSet NormalizedFilePath
forall a. Monoid a => a
mempty)

newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))
instance IsIdeGlobal EvaluatingVar

queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
queueForEvaluation IdeState
ide NormalizedFilePath
nfp = do
    EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- IdeState -> IO EvaluatingVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
ide
    IORef (HashSet NormalizedFilePath)
-> (HashSet NormalizedFilePath -> (HashSet NormalizedFilePath, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashSet NormalizedFilePath)
var (\HashSet NormalizedFilePath
fs -> (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert NormalizedFilePath
nfp HashSet NormalizedFilePath
fs, ()))

unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
unqueueForEvaluation IdeState
ide NormalizedFilePath
nfp = do
    EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- IdeState -> IO EvaluatingVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
ide
    -- remove the module from the Evaluating state, so that next time it won't evaluate to True
    IORef (HashSet NormalizedFilePath)
-> (HashSet NormalizedFilePath -> (HashSet NormalizedFilePath, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashSet NormalizedFilePath)
var ((HashSet NormalizedFilePath -> (HashSet NormalizedFilePath, ()))
 -> IO ())
-> (HashSet NormalizedFilePath -> (HashSet NormalizedFilePath, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashSet NormalizedFilePath
fs -> (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.delete NormalizedFilePath
nfp HashSet NormalizedFilePath
fs, ())

apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]
apiAnnComments' :: ParsedModule -> [RealLocated EpaCommentTok]
apiAnnComments' ParsedModule
pm = do
  L Anchor
span (EpaComment EpaCommentTok
c RealSrcSpan
_) <- Located (HsModule GhcPs) -> [LEpaComment]
getEpaComments (Located (HsModule GhcPs) -> [LEpaComment])
-> Located (HsModule GhcPs) -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ ParsedModule -> Located (HsModule GhcPs)
pm_parsed_source ParsedModule
pm
  RealLocated EpaCommentTok -> [RealLocated EpaCommentTok]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealSrcSpan -> EpaCommentTok -> RealLocated EpaCommentTok
forall l e. l -> e -> GenLocated l e
L (Anchor -> RealSrcSpan
anchor Anchor
span) EpaCommentTok
c)
  where
#if MIN_VERSION_ghc(9,5,0)
    getEpaComments :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment]
#else
    getEpaComments :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]
#endif
    getEpaComments :: Located (HsModule GhcPs) -> [LEpaComment]
getEpaComments = Getting (Endo [LEpaComment]) (Located (HsModule GhcPs)) LEpaComment
-> Located (HsModule GhcPs) -> [LEpaComment]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [LEpaComment]) (Located (HsModule GhcPs)) LEpaComment
forall s a. (Data s, Typeable a) => Traversal' s a
Traversal' (Located (HsModule GhcPs)) LEpaComment
biplate

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern $mRealSrcSpanAlready :: forall {r}. RealSrcSpan -> (RealSrcSpan -> r) -> ((# #) -> r) -> r
$bRealSrcSpanAlready :: RealSrcSpan -> RealSrcSpan
RealSrcSpanAlready x = x

evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody GetEvalComments Comments -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((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) (RuleBody GetEvalComments Comments -> Rules ())
-> RuleBody GetEvalComments Comments -> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetEvalComments
 -> NormalizedFilePath -> Action (Maybe ByteString, Maybe Comments))
-> RuleBody GetEvalComments Comments
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((GetEvalComments
  -> NormalizedFilePath -> Action (Maybe ByteString, Maybe Comments))
 -> RuleBody GetEvalComments Comments)
-> (GetEvalComments
    -> NormalizedFilePath -> Action (Maybe ByteString, Maybe Comments))
-> RuleBody GetEvalComments Comments
forall a b. (a -> b) -> a -> b
$ \GetEvalComments
GetEvalComments NormalizedFilePath
nfp -> do
    (ParsedModule
pm, PositionMapping
posMap) <- GetParsedModuleWithComments
-> NormalizedFilePath -> Action (ParsedModule, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
    let comments :: Comments
comments = (RealLocated EpaCommentTok -> Comments)
-> [RealLocated EpaCommentTok] -> Comments
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\case
                L (RealSrcSpanAlready RealSrcSpan
real) EpaCommentTok
bdy
                    | FastString -> String
FastString.unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==
                        NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
                    , let ran0 :: Range
ran0 = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
real
                    , Just Range
curRan <- PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
posMap Range
ran0
                    ->

                        -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
                        -- we can concentrate on these two
                        case EpaCommentTok
bdy of
                            EpaLineComment String
cmt ->
                                Comments
forall a. Monoid a => a
mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
                            EpaBlockComment String
cmt ->
                                Comments
forall a. Monoid a => a
mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
                            EpaCommentTok
_ -> Comments
forall a. Monoid a => a
mempty
                RealLocated EpaCommentTok
_ -> Comments
forall a. Monoid a => a
mempty
            )
            ([RealLocated EpaCommentTok] -> Comments)
-> [RealLocated EpaCommentTok] -> Comments
forall a b. (a -> b) -> a -> b
$ ParsedModule -> [RealLocated EpaCommentTok]
apiAnnComments' ParsedModule
pm
        -- we only care about whether the comments are null
        -- this is valid because the only dependent is NeedsCompilation
        fingerPrint :: ByteString
fingerPrint = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ if Comments -> Bool
nullComments Comments
comments then String
"" else String
"1"
    (Maybe ByteString, Maybe Comments)
-> Action (Maybe ByteString, Maybe Comments)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fingerPrint, Comments -> Maybe Comments
forall a. a -> Maybe a
Just Comments
comments)

isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
isEvaluatingRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody IsEvaluating Bool -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((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) (RuleBody IsEvaluating Bool -> Rules ())
-> RuleBody IsEvaluating Bool -> Rules ()
forall a b. (a -> b) -> a -> b
$ (IsEvaluating
 -> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody IsEvaluating Bool
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((IsEvaluating
  -> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
 -> RuleBody IsEvaluating Bool)
-> (IsEvaluating
    -> NormalizedFilePath -> Action (Maybe ByteString, Maybe Bool))
-> RuleBody IsEvaluating Bool
forall a b. (a -> b) -> a -> b
$ \IsEvaluating
IsEvaluating NormalizedFilePath
f -> do
    Action ()
alwaysRerun
    EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- Action EvaluatingVar
forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
    Bool
b <- IO Bool -> Action Bool
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath
f `Set.member`) (HashSet NormalizedFilePath -> Bool)
-> IO (HashSet NormalizedFilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashSet NormalizedFilePath)
-> IO (HashSet NormalizedFilePath)
forall a. IORef a -> IO a
readIORef IORef (HashSet NormalizedFilePath)
var
    (Maybe ByteString, Maybe Bool)
-> Action (Maybe ByteString, Maybe Bool)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (if Bool
b then Word8 -> ByteString
BS.singleton Word8
1 else ByteString
BS.empty), Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b)

-- Redefine the NeedsCompilation rule to set the linkable type to Just _
-- whenever the module is being evaluated
-- This will ensure that the modules are loaded with linkables
-- and the interactive session won't try to compile them on the fly,
-- leading to much better performance of the evaluate code lens
redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
redefinedNeedsCompilation Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff ((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) (RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ())
-> RuleBody NeedsCompilation (Maybe LinkableType) -> Rules ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString -> Bool)
-> (NeedsCompilation
    -> NormalizedFilePath
    -> Action (Maybe ByteString, Maybe (Maybe LinkableType)))
-> RuleBody NeedsCompilation (Maybe LinkableType)
forall k v.
(ByteString -> ByteString -> Bool)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleWithCustomNewnessCheck ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
(<=) ((NeedsCompilation
  -> NormalizedFilePath
  -> Action (Maybe ByteString, Maybe (Maybe LinkableType)))
 -> RuleBody NeedsCompilation (Maybe LinkableType))
-> (NeedsCompilation
    -> NormalizedFilePath
    -> Action (Maybe ByteString, Maybe (Maybe LinkableType)))
-> RuleBody NeedsCompilation (Maybe LinkableType)
forall a b. (a -> b) -> a -> b
$ \NeedsCompilation
NeedsCompilation NormalizedFilePath
f -> do
    Bool
isEvaluating <- IsEvaluating -> NormalizedFilePath -> Action Bool
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsEvaluating
IsEvaluating NormalizedFilePath
f
    if Bool
isEvaluating then do
        let linkableType :: LinkableType
linkableType = LinkableType
BCOLinkable
            fp :: ByteString
fp = Maybe LinkableType -> ByteString
encodeLinkableType (Maybe LinkableType -> ByteString)
-> Maybe LinkableType -> ByteString
forall a b. (a -> b) -> a -> b
$ LinkableType -> Maybe LinkableType
forall a. a -> Maybe a
Just LinkableType
linkableType
        (Maybe ByteString, Maybe (Maybe LinkableType))
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fp, Maybe LinkableType -> Maybe (Maybe LinkableType)
forall a. a -> Maybe a
Just (LinkableType -> Maybe LinkableType
forall a. a -> Maybe a
Just LinkableType
linkableType))
    else
        NormalizedFilePath
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
needsCompilationRule NormalizedFilePath
f