-- 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,
    getFilesOfInterestUntracked,
    addFileOfInterest,
    deleteFileOfInterest,
    setFilesOfInterest,
    kick, FileOfInterestStatus(..),
    OfInterestVar(..)
    ) 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 qualified Data.ByteString                        as BS
import           Data.Maybe                             (catMaybes)
import           Development.IDE.Core.ProgressReporting
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake
import           Development.IDE.Types.Exports
import           Development.IDE.Types.Location
import           Development.IDE.Types.Logger

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

-- | The rule that initialises the files of interest state.
ofInterestRules :: Rules ()
ofInterestRules :: Rules ()
ofInterestRules = do
    OfInterestVar -> Rules ()
forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal (OfInterestVar -> Rules ())
-> (Var (HashMap NormalizedFilePath FileOfInterestStatus)
    -> OfInterestVar)
-> Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> Rules ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> OfInterestVar
OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus) -> Rules ())
-> Rules (Var (HashMap NormalizedFilePath FileOfInterestStatus))
-> Rules ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Var (HashMap NormalizedFilePath FileOfInterestStatus))
-> Rules (Var (HashMap NormalizedFilePath FileOfInterestStatus))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HashMap NormalizedFilePath FileOfInterestStatus
-> IO (Var (HashMap NormalizedFilePath FileOfInterestStatus))
forall a. a -> IO (Var a)
newVar HashMap NormalizedFilePath FileOfInterestStatus
forall k v. HashMap k v
HashMap.empty)
    RuleBody IsFileOfInterest IsFileOfInterestResult -> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody IsFileOfInterest IsFileOfInterestResult -> Rules ())
-> RuleBody IsFileOfInterest IsFileOfInterestResult -> Rules ()
forall a b. (a -> b) -> a -> b
$ (IsFileOfInterest
 -> NormalizedFilePath
 -> Action (Maybe ByteString, Maybe IsFileOfInterestResult))
-> RuleBody IsFileOfInterest IsFileOfInterestResult
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((IsFileOfInterest
  -> NormalizedFilePath
  -> Action (Maybe ByteString, Maybe IsFileOfInterestResult))
 -> RuleBody IsFileOfInterest IsFileOfInterestResult)
-> (IsFileOfInterest
    -> NormalizedFilePath
    -> Action (Maybe ByteString, Maybe IsFileOfInterestResult))
-> RuleBody IsFileOfInterest IsFileOfInterestResult
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 = IsFileOfInterestResult
-> (FileOfInterestStatus -> IsFileOfInterestResult)
-> Maybe FileOfInterestStatus
-> IsFileOfInterestResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IsFileOfInterestResult
NotFOI FileOfInterestStatus -> IsFileOfInterestResult
IsFOI (Maybe FileOfInterestStatus -> IsFileOfInterestResult)
-> Maybe FileOfInterestStatus -> IsFileOfInterestResult
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
f NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> Maybe FileOfInterestStatus
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 = (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
fp, IsFileOfInterestResult -> Maybe IsFileOfInterestResult
forall a. a -> Maybe a
Just IsFileOfInterestResult
foi)
        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


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

-- | 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 <- IdeState -> IO OfInterestVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
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 <- Action OfInterestVar
forall a. IsIdeGlobal a => Action a
getIdeGlobalAction
    IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap NormalizedFilePath FileOfInterestStatus)
 -> Action (HashMap NormalizedFilePath FileOfInterestStatus))
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
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 <- IdeState -> IO OfInterestVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
files) <- Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> IO
         (HashMap NormalizedFilePath FileOfInterestStatus,
          (Maybe FileOfInterestStatus,
           HashMap NormalizedFilePath FileOfInterestStatus)))
-> IO
     (Maybe FileOfInterestStatus,
      HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap NormalizedFilePath FileOfInterestStatus)
var ((HashMap NormalizedFilePath FileOfInterestStatus
  -> IO
       (HashMap NormalizedFilePath FileOfInterestStatus,
        (Maybe FileOfInterestStatus,
         HashMap NormalizedFilePath FileOfInterestStatus)))
 -> IO
      (Maybe FileOfInterestStatus,
       HashMap NormalizedFilePath FileOfInterestStatus))
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> IO
         (HashMap NormalizedFilePath FileOfInterestStatus,
          (Maybe FileOfInterestStatus,
           HashMap NormalizedFilePath FileOfInterestStatus)))
-> IO
     (Maybe FileOfInterestStatus,
      HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedFilePath FileOfInterestStatus
dict -> do
        let (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
new) = (Maybe FileOfInterestStatus
 -> (Maybe FileOfInterestStatus, Maybe FileOfInterestStatus))
-> NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> (Maybe FileOfInterestStatus,
    HashMap NormalizedFilePath FileOfInterestStatus)
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 (, FileOfInterestStatus -> Maybe FileOfInterestStatus
forall a. a -> Maybe a
Just FileOfInterestStatus
v) NormalizedFilePath
f HashMap NormalizedFilePath FileOfInterestStatus
dict
        (HashMap NormalizedFilePath FileOfInterestStatus,
 (Maybe FileOfInterestStatus,
  HashMap NormalizedFilePath FileOfInterestStatus))
-> IO
     (HashMap NormalizedFilePath FileOfInterestStatus,
      (Maybe FileOfInterestStatus,
       HashMap NormalizedFilePath FileOfInterestStatus))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap NormalizedFilePath FileOfInterestStatus
new, (Maybe FileOfInterestStatus
prev, HashMap NormalizedFilePath FileOfInterestStatus
dict))
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FileOfInterestStatus
prev Maybe FileOfInterestStatus -> Maybe FileOfInterestStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= FileOfInterestStatus -> Maybe FileOfInterestStatus
forall a. a -> Maybe a
Just FileOfInterestStatus
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ShakeExtras -> IsFileOfInterest -> [NormalizedFilePath] -> IO ()
forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> IO ()
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) IsFileOfInterest
IsFileOfInterest [NormalizedFilePath
f]
    Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
state) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"Set files of interest to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (HashMap NormalizedFilePath FileOfInterestStatus -> String
forall a. Show a => a -> String
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 <- IdeState -> IO OfInterestVar
forall a. IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState IdeState
state
    HashMap NormalizedFilePath FileOfInterestStatus
files <- Var (HashMap NormalizedFilePath FileOfInterestStatus)
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var (HashMap NormalizedFilePath FileOfInterestStatus)
var ((HashMap NormalizedFilePath FileOfInterestStatus
  -> HashMap NormalizedFilePath FileOfInterestStatus)
 -> IO (HashMap NormalizedFilePath FileOfInterestStatus))
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete NormalizedFilePath
f
    ShakeExtras -> IsFileOfInterest -> [NormalizedFilePath] -> IO ()
forall k.
ShakeValue k =>
ShakeExtras -> k -> [NormalizedFilePath] -> IO ()
recordDirtyKeys (IdeState -> ShakeExtras
shakeExtras IdeState
state) IsFileOfInterest
IsFileOfInterest [NormalizedFilePath
f]
    Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
state) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Set files of interest to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (HashMap NormalizedFilePath FileOfInterestStatus -> String
forall a. Show a => a -> String
show HashMap NormalizedFilePath FileOfInterestStatus
files)


-- | Typecheck all the files of interest.
--   Could be improved
kick :: Action ()
kick :: Action ()
kick = do
    [NormalizedFilePath]
files <- HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
HashMap.keys (HashMap NormalizedFilePath FileOfInterestStatus
 -> [NormalizedFilePath])
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
-> Action [NormalizedFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    ShakeExtras{Var ExportsMap
$sel:exportsMap:ShakeExtras :: ShakeExtras -> Var ExportsMap
exportsMap :: Var ExportsMap
exportsMap, ProgressReporting
$sel:progress:ShakeExtras :: ShakeExtras -> ProgressReporting
progress :: ProgressReporting
progress} <- Action ShakeExtras
getShakeExtras
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ ProgressReporting -> ProgressEvent -> IO ()
progressUpdate ProgressReporting
progress ProgressEvent
KickStarted

    -- Update the exports map
    [Maybe ModGuts]
results <- GenerateCore -> [NormalizedFilePath] -> Action [Maybe ModGuts]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GenerateCore
GenerateCore [NormalizedFilePath]
files Action [Maybe ModGuts]
-> Action [Maybe HieAstResult] -> Action [Maybe ModGuts]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* GetHieAst -> [NormalizedFilePath] -> Action [Maybe HieAstResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetHieAst
GetHieAst [NormalizedFilePath]
files
    let mguts :: [ModGuts]
mguts = [Maybe ModGuts] -> [ModGuts]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModGuts]
results
        !exportsMap' :: ExportsMap
exportsMap' = [ModGuts] -> ExportsMap
createExportsMapMg [ModGuts]
mguts
    Action ExportsMap -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action ExportsMap -> Action ()) -> Action ExportsMap -> Action ()
forall a b. (a -> b) -> a -> b
$ IO ExportsMap -> Action ExportsMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExportsMap -> Action ExportsMap)
-> IO ExportsMap -> Action ExportsMap
forall a b. (a -> b) -> a -> b
$ Var ExportsMap -> (ExportsMap -> ExportsMap) -> IO ExportsMap
forall a. Var a -> (a -> a) -> IO a
modifyVar' Var ExportsMap
exportsMap (ExportsMap
exportsMap' ExportsMap -> ExportsMap -> ExportsMap
forall a. Semigroup a => a -> a -> a
<>)

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