-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies      #-}

-- | Utilities and state for the files of interest - those which are currently
--   open in the editor. The rule is 'IsFileOfInterest'
module Development.IDE.Core.OfInterest(
    ofInterestRules,
    getFilesOfInterest,
    getFilesOfInterestUntracked,
    addFileOfInterest,
    deleteFileOfInterest,
    setFilesOfInterest,
    kick, FileOfInterestStatus(..),
    OfInterestVar(..),
    scheduleGarbageCollection,
    Log(..)
    ) where

import           Control.Concurrent.Strict
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.HashMap.Strict                      (HashMap)
import qualified Data.HashMap.Strict                      as HashMap
import qualified Data.Text                                as T
import           Development.IDE.Graph

import           Control.Concurrent.STM.Stats             (atomically,
                                                           modifyTVar')
import           Data.Aeson                               (toJSON)
import qualified Data.ByteString                          as BS
import           Data.Maybe                               (catMaybes)
import           Development.IDE.Core.ProgressReporting
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake               hiding (Log)
import qualified Development.IDE.Core.Shake               as Shake
import           Development.IDE.Plugin.Completions.Types
import           Development.IDE.Types.Exports
import           Development.IDE.Types.Location
import           Development.IDE.Types.Logger             (Pretty (pretty),
                                                           Recorder,
                                                           WithPriority,
                                                           cmapWithPrio,
                                                           logDebug)
import           Development.IDE.Types.Options            (IdeTesting (..))
import qualified Language.LSP.Server                      as LSP
import qualified Language.LSP.Types                       as LSP

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

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

newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))

instance IsIdeGlobal OfInterestVar

-- | The rule that initialises the files of interest state.
ofInterestRules :: Recorder (WithPriority Log) -> Rules ()
ofInterestRules :: Recorder (WithPriority Log) -> Rules ()
ofInterestRules Recorder (WithPriority Log)
recorder = do
    forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> OfInterestVar
OfInterestVar 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 (Var a)
newVar forall k v. HashMap k v
HashMap.empty)
    forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var Bool -> GarbageCollectVar
GarbageCollectVar 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 (Var a)
newVar Bool
False)
    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
$ \IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f -> do
        Action ()
alwaysRerun
        HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
        let foi :: IsFileOfInterestResult
foi = forall b a. b -> (a -> b) -> Maybe a -> b
maybe IsFileOfInterestResult
NotFOI FileOfInterestStatus -> IsFileOfInterestResult
IsFOI forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
f forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest
            fp :: ByteString
fp  = IsFileOfInterestResult -> ByteString
summarize IsFileOfInterestResult
foi
            res :: (Maybe ByteString, Maybe IsFileOfInterestResult)
res = (forall a. a -> Maybe a
Just ByteString
fp, forall a. a -> Maybe a
Just IsFileOfInterestResult
foi)
        forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString, Maybe IsFileOfInterestResult)
res
    where
    summarize :: IsFileOfInterestResult -> ByteString
summarize IsFileOfInterestResult
NotFOI                   = Word8 -> ByteString
BS.singleton Word8
0
    summarize (IsFOI FileOfInterestStatus
OnDisk)           = Word8 -> ByteString
BS.singleton Word8
1
    summarize (IsFOI (Modified Bool
False)) = Word8 -> ByteString
BS.singleton Word8
2
    summarize (IsFOI (Modified Bool
True))  = Word8 -> ByteString
BS.singleton Word8
3

------------------------------------------------------------
newtype GarbageCollectVar = GarbageCollectVar (Var Bool)
instance IsIdeGlobal GarbageCollectVar

------------------------------------------------------------
-- Exposed API

getFilesOfInterest :: IdeState -> IO( HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest :: IdeState -> IO (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest IdeState
state = do
    OfInterestVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    forall a. Var a -> IO a
readVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var

-- | Set the files-of-interest - not usually necessary or advisable.
--   The LSP client will keep this information up to date.
setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
setFilesOfInterest :: IdeState
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
setFilesOfInterest IdeState
state HashMap NormalizedFilePath FileOfInterestStatus
files = do
    OfInterestVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    forall a. Var a -> a -> IO ()
writeVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var HashMap NormalizedFilePath FileOfInterestStatus
files

getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked = do
    OfInterestVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Var a -> IO a
readVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var

addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
state NormalizedFilePath
f FileOfInterestStatus
v = do
    OfInterestVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
files) <- forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedFilePath FileOfInterestStatus
dict -> do
        let (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new) = forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
HashMap.alterF (, forall a. a -> Maybe a
Just FileOfInterestStatus
v) NormalizedFilePath
f HashMap NormalizedFilePath FileOfInterestStatus
dict
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap NormalizedFilePath FileOfInterestStatus
new, (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FileOfInterestStatus
prev forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just FileOfInterestStatus
v) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) IsFileOfInterest
IsFileOfInterest [NormalizedFilePath
f]
        Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
state) forall a b. (a -> b) -> a -> b
$
            Text
"Set files of interest to: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show HashMap NormalizedFilePath FileOfInterestStatus
files)

deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest IdeState
state NormalizedFilePath
f = do
    OfInterestVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    HashMap NormalizedFilePath FileOfInterestStatus
files <- forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (HashMap NormalizedFilePath FileOfInterestStatus)
var forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete NormalizedFilePath
f
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> STM (IO ())
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) IsFileOfInterest
IsFileOfInterest [NormalizedFilePath
f]
    Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
state) forall a b. (a -> b) -> a -> b
$ Text
"Set files of interest to: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show HashMap NormalizedFilePath FileOfInterestStatus
files)

scheduleGarbageCollection :: IdeState -> IO ()
scheduleGarbageCollection :: IdeState -> IO ()
scheduleGarbageCollection IdeState
state = do
    GarbageCollectVar Var Bool
var <- forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    forall a. Var a -> a -> IO ()
writeVar Var Bool
var Bool
True

-- | Typecheck all the files of interest.
--   Could be improved
kick :: Action ()
kick :: Action ()
kick = do
    [NormalizedFilePath]
files <- forall k v. HashMap k v -> [k]
HashMap.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    ShakeExtras{TVar ExportsMap
$sel:exportsMap:ShakeExtras :: ShakeExtras -> TVar ExportsMap
exportsMap :: TVar ExportsMap
exportsMap, $sel:ideTesting:ShakeExtras :: ShakeExtras -> IdeTesting
ideTesting = IdeTesting Bool
testing, Maybe (LanguageContextEnv Config)
$sel:lspEnv:ShakeExtras :: ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv :: Maybe (LanguageContextEnv Config)
lspEnv, ProgressReporting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
progress :: ProgressReporting
progress} <- Action ShakeExtras
getShakeExtras
    let signal :: Text -> Action ()
signal Text
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
testing 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 (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT Maybe (LanguageContextEnv Config)
lspEnv forall a b. (a -> b) -> a -> b
$
                forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
LSP.SCustomMethod Text
msg) forall a b. (a -> b) -> a -> b
$
                forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> FilePath
fromNormalizedFilePath [NormalizedFilePath]
files

    Text -> Action ()
signal Text
"kick/start"
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProgressReporting -> ProgressEvent -> IO ()
progressUpdate ProgressReporting
progress ProgressEvent
KickStarted

    -- Update the exports map
    [Maybe ModGuts]
results <- forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GenerateCore
GenerateCore [NormalizedFilePath]
files
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetHieAst
GetHieAst [NormalizedFilePath]
files
            -- needed to have non local completions on the first edit
            -- when the first edit breaks the module header
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses NonLocalCompletions
NonLocalCompletions [NormalizedFilePath]
files
    let mguts :: [ModGuts]
mguts = forall a. [Maybe a] -> [a]
catMaybes [Maybe ModGuts]
results
    forall (f :: * -> *) a. Functor f => f a -> f ()
void 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. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar ExportsMap
exportsMap ([ModGuts] -> ExportsMap -> ExportsMap
updateExportsMapMg [ModGuts]
mguts)

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProgressReporting -> ProgressEvent -> IO ()
progressUpdate ProgressReporting
progress ProgressEvent
KickCompleted

    GarbageCollectVar Var Bool
var <- forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
    Bool
garbageCollectionScheduled <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Var a -> IO a
readVar Var Bool
var
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
garbageCollectionScheduled forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void Action [Key]
garbageCollectDirtyKeys
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Var a -> a -> IO ()
writeVar Var Bool
var Bool
False

    Text -> Action ()
signal Text
"kick/done"