{-# 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
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 :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
shakeLog -> 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
    forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (HashSet NormalizedFilePath) -> EvaluatingVar
EvaluatingVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(forall a. a -> IO (IORef a)
newIORef 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 <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
ide
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (HashSet NormalizedFilePath)
var (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 :: Located HsModule -> [LEpaComment]
getAnnotations (L SrcSpan
_ m :: HsModule
m@(HsModule { hsmodAnn :: HsModule -> EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
anns'})) =
    EpAnnComments -> [LEpaComment]
priorComments EpAnnComments
annComments forall a. Semigroup a => a -> a -> a
<> EpAnnComments -> [LEpaComment]
getFollowingComments EpAnnComments
annComments
     forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall ann e.
GenLocated (SrcSpanAnn' (EpAnn ann)) e -> [LEpaComment]
getCommentsForDecl (HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
m)
     forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall ann e.
GenLocated (SrcSpanAnn' (EpAnn ann)) e -> [LEpaComment]
getCommentsForDecl (HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
m)
       where
         annComments :: EpAnnComments
annComments = forall an. EpAnn an -> EpAnnComments
epAnnComments EpAnn AnnsModule
anns'

getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e
                            -> [LEpaComment]
getCommentsForDecl :: forall ann e.
GenLocated (SrcSpanAnn' (EpAnn ann)) e -> [LEpaComment]
getCommentsForDecl (L (SrcSpanAnn (EpAnn Anchor
_ ann
_ EpAnnComments
cs) SrcSpan
_) e
_) = EpAnnComments -> [LEpaComment]
priorComments EpAnnComments
cs forall a. Semigroup a => a -> a -> a
<> EpAnnComments -> [LEpaComment]
getFollowingComments EpAnnComments
cs
getCommentsForDecl (L (SrcSpanAnn (EpAnn ann
EpAnnNotUsed) SrcSpan
_) e
_) = []

apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]
apiAnnComments' :: ParsedModule -> [RealLocated EpaCommentTok]
apiAnnComments' ParsedModule
pm = do
  L Anchor
span (EpaComment EpaCommentTok
c RealSrcSpan
_) <- Located HsModule -> [LEpaComment]
getAnnotations forall a b. (a -> b) -> a -> b
$ ParsedModule -> Located HsModule
pm_parsed_source ParsedModule
pm
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l e. l -> e -> GenLocated l e
L (Anchor -> RealSrcSpan
anchor Anchor
span) EpaCommentTok
c)

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
pattern $bRealSrcSpanAlready :: RealSrcSpan -> RealSrcSpan
$mRealSrcSpanAlready :: forall {r}. RealSrcSpan -> (RealSrcSpan -> r) -> ((# #) -> r) -> r
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' = concat . Map.elems . snd . pm_annotations

pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
#endif

evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
evalParsedModuleRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (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
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics forall a b. (a -> b) -> a -> b
$ \GetEvalComments
GetEvalComments NormalizedFilePath
nfp -> do
    (ParsedModule
pm, PositionMapping
posMap) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
    let comments :: Comments
comments = 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) 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 ->
                                forall a. Monoid a => a
mempty { lineComments :: Map Range RawLineComment
lineComments = forall k a. k -> a -> Map k a
Map.singleton Range
curRan (String -> RawLineComment
RawLineComment String
cmt) }
                            EpaBlockComment String
cmt ->
                                forall a. Monoid a => a
mempty { blockComments :: Map Range RawBlockComment
blockComments = forall k a. k -> a -> Map k a
Map.singleton Range
curRan forall a b. (a -> b) -> a -> b
$ String -> RawBlockComment
RawBlockComment String
cmt }
                            EpaCommentTok
_ -> forall a. Monoid a => a
mempty
                RealLocated EpaCommentTok
_ -> forall a. Monoid a => a
mempty
            )
            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 = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ if Comments -> Bool
nullComments Comments
comments then String
"" else String
"1"
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ByteString
fingerPrint, 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 = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (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
$ forall k v.
(ByteString -> ByteString -> Bool)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleWithCustomNewnessCheck forall a. Ord a => a -> a -> Bool
(<=) forall a b. (a -> b) -> a -> b
$ \NeedsCompilation
NeedsCompilation NormalizedFilePath
f -> do
    Action ()
alwaysRerun

    EvaluatingVar IORef (HashSet NormalizedFilePath)
var <- forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
    Bool
isEvaluating <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just LinkableType
linkableType

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ByteString
fp, forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just LinkableType
linkableType))