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

-- To avoid warning "Pattern match has inaccessible right hand side"
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where

import           Control.Monad.IO.Class               (MonadIO (liftIO))
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                      (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps),
                                                       GetParsedModuleWithComments (GetParsedModuleWithComments),
                                                       IdeState,
                                                       NeedsCompilation (NeedsCompilation),
                                                       NormalizedFilePath,
                                                       RuleBody (RuleNoDiagnostics),
                                                       Rules, defineEarlyCutoff,
                                                       encodeLinkableType,
                                                       fromNormalizedFilePath,
                                                       msrModSummary,
                                                       realSrcSpanToRange,
                                                       useWithStale_)
import           Development.IDE.Core.PositionMapping (toCurrentRange)
import           Development.IDE.Core.Rules           (computeLinkableTypeForDynFlags,
                                                       needsCompilationRule)
import           Development.IDE.Core.Shake           (IsIdeGlobal,
                                                       RuleBody (RuleWithCustomNewnessCheck),
                                                       addIdeGlobal,
                                                       getIdeGlobalAction,
                                                       getIdeGlobalState)
import qualified Development.IDE.Core.Shake           as Shake
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           Development.IDE.Types.Logger         (Pretty (pretty),
                                                       Recorder, WithPriority,
                                                       cmapWithPrio)
#if MIN_VERSION_ghc(9,2,0)
import           GHC.Parser.Annotation
#endif
import           Ide.Plugin.Eval.Types

newtype Log = LogShake Shake.Log deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

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

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
    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 (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. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (HashSet NormalizedFilePath)
var (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert NormalizedFilePath
nfp)

#if MIN_VERSION_ghc(9,2,0)
getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]
getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) =
    priorComments annComments <> getFollowingComments annComments
     <> concatMap getCommentsForDecl (hsmodImports m)
     <> concatMap getCommentsForDecl (hsmodDecls m)
       where
         annComments = epAnnComments anns'

getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e
                            -> [LEpaComment]
getCommentsForDecl (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs <> getFollowingComments cs
getCommentsForDecl (L (SrcSpanAnn (EpAnnNotUsed) _) _) = []

apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]
apiAnnComments' pm = do
  L span (EpaComment c _) <- getAnnotations $ pm_parsed_source pm
  pure (L (anchor span) c)

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern RealSrcSpanAlready x = x
#elif MIN_VERSION_ghc(9,0,0)
apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated AnnotationComment]
apiAnnComments' = apiAnnRogueComments . pm_annotations

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern RealSrcSpanAlready x = x
#else
apiAnnComments' :: ParsedModule -> [SrcLoc.Located AnnotationComment]
apiAnnComments' :: ParsedModule -> [Located AnnotationComment]
apiAnnComments' = [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Located AnnotationComment]] -> [Located AnnotationComment])
-> (ParsedModule -> [[Located AnnotationComment]])
-> ParsedModule
-> [Located AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
Map.elems (Map SrcSpan [Located AnnotationComment]
 -> [[Located AnnotationComment]])
-> (ParsedModule -> Map SrcSpan [Located AnnotationComment])
-> ParsedModule
-> [[Located AnnotationComment]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ApiAnnKey [SrcSpan], Map SrcSpan [Located AnnotationComment])
-> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd ((Map ApiAnnKey [SrcSpan], Map SrcSpan [Located AnnotationComment])
 -> Map SrcSpan [Located AnnotationComment])
-> (ParsedModule
    -> (Map ApiAnnKey [SrcSpan],
        Map SrcSpan [Located AnnotationComment]))
-> ParsedModule
-> Map SrcSpan [Located AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule
-> (Map ApiAnnKey [SrcSpan],
    Map SrcSpan [Located AnnotationComment])
pm_annotations

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
pattern $bRealSrcSpanAlready :: RealSrcSpan -> SrcSpan
$mRealSrcSpanAlready :: forall r. SrcSpan -> (RealSrcSpan -> r) -> (Void# -> r) -> r
RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
#endif

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 = (Located AnnotationComment -> Comments)
-> [Located AnnotationComment] -> Comments
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\case
                L (RealSrcSpanAlready RealSrcSpan
real) AnnotationComment
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 AnnotationComment
bdy of
                            EpaLineComment String
cmt ->
                                Comments
forall a. Monoid a => a
mempty { lineComments :: Map Range RawLineComment
lineComments = Range -> RawLineComment -> Map Range RawLineComment
forall k a. k -> a -> Map k a
Map.singleton Range
curRan (String -> RawLineComment
RawLineComment String
cmt) }
                            EpaBlockComment String
cmt ->
                                Comments
forall a. Monoid a => a
mempty { blockComments :: Map Range RawBlockComment
blockComments = Range -> RawBlockComment -> Map Range RawBlockComment
forall k a. k -> a -> Map k a
Map.singleton Range
curRan (RawBlockComment -> Map Range RawBlockComment)
-> RawBlockComment -> Map Range RawBlockComment
forall a b. (a -> b) -> a -> b
$ String -> RawBlockComment
RawBlockComment String
cmt }
                            AnnotationComment
_ -> Comments
forall a. Monoid a => a
mempty
                Located AnnotationComment
_ -> Comments
forall a. Monoid a => a
mempty
            )
            ([Located AnnotationComment] -> Comments)
-> [Located AnnotationComment] -> Comments
forall a b. (a -> b) -> a -> b
$ ParsedModule -> [Located AnnotationComment]
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 (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)

-- 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
    Action ()
alwaysRerun

    EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- Action EvaluatingVar
forall a. IsIdeGlobal a => Action a
getIdeGlobalAction
    Bool
isEvaluating <- IO Bool -> Action Bool
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 NormalizedFilePath -> HashSet NormalizedFilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) (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


    if Bool -> Bool
not Bool
isEvaluating then NormalizedFilePath
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
needsCompilationRule NormalizedFilePath
f else do
        ModSummary
ms <- ModSummaryResult -> ModSummary
msrModSummary (ModSummaryResult -> ModSummary)
-> ((ModSummaryResult, PositionMapping) -> ModSummaryResult)
-> (ModSummaryResult, PositionMapping)
-> ModSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModSummaryResult, PositionMapping) -> ModSummaryResult
forall a b. (a, b) -> a
fst ((ModSummaryResult, PositionMapping) -> ModSummary)
-> Action (ModSummaryResult, PositionMapping) -> Action ModSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModSummaryWithoutTimestamps
-> NormalizedFilePath -> Action (ModSummaryResult, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
f
        let df' :: DynFlags
df' = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
            linkableType :: LinkableType
linkableType = DynFlags -> LinkableType
computeLinkableTypeForDynFlags DynFlags
df'
            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

        -- remove the module from the Evaluating state
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef (HashSet NormalizedFilePath)
-> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (HashSet NormalizedFilePath)
var (NormalizedFilePath
-> HashSet NormalizedFilePath -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.delete NormalizedFilePath
f)

        (Maybe ByteString, Maybe (Maybe LinkableType))
-> Action (Maybe ByteString, Maybe (Maybe LinkableType))
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))