-- 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 useful function is 'getFilesOfInterest'.
module Development.IDE.Core.OfInterest(
    ofInterestRules,
    getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
    kick, FileOfInterestStatus(..),
    OfInterestVar(..)
    ) where

import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Data.Binary
import           Data.HashMap.Strict                          (HashMap)
import qualified Data.HashMap.Strict                          as HashMap
import           Data.Hashable
import qualified Data.Text                                    as T
import           Data.Typeable
import           Development.Shake
import           GHC.Generics

import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import qualified Data.ByteString.Lazy                         as LBS
import           Data.List.Extra                              (nubOrd)
import           Data.Maybe                                   (catMaybes)
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake
import           Development.IDE.Import.DependencyInformation
import           Development.IDE.Types.Exports
import           Development.IDE.Types.Location
import           Development.IDE.Types.Logger
import           Development.IDE.Types.Options

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

type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus

data GetFilesOfInterest = GetFilesOfInterest
    deriving (GetFilesOfInterest -> GetFilesOfInterest -> Bool
(GetFilesOfInterest -> GetFilesOfInterest -> Bool)
-> (GetFilesOfInterest -> GetFilesOfInterest -> Bool)
-> Eq GetFilesOfInterest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetFilesOfInterest -> GetFilesOfInterest -> Bool
$c/= :: GetFilesOfInterest -> GetFilesOfInterest -> Bool
== :: GetFilesOfInterest -> GetFilesOfInterest -> Bool
$c== :: GetFilesOfInterest -> GetFilesOfInterest -> Bool
Eq, Int -> GetFilesOfInterest -> ShowS
[GetFilesOfInterest] -> ShowS
GetFilesOfInterest -> String
(Int -> GetFilesOfInterest -> ShowS)
-> (GetFilesOfInterest -> String)
-> ([GetFilesOfInterest] -> ShowS)
-> Show GetFilesOfInterest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetFilesOfInterest] -> ShowS
$cshowList :: [GetFilesOfInterest] -> ShowS
show :: GetFilesOfInterest -> String
$cshow :: GetFilesOfInterest -> String
showsPrec :: Int -> GetFilesOfInterest -> ShowS
$cshowsPrec :: Int -> GetFilesOfInterest -> ShowS
Show, Typeable, (forall x. GetFilesOfInterest -> Rep GetFilesOfInterest x)
-> (forall x. Rep GetFilesOfInterest x -> GetFilesOfInterest)
-> Generic GetFilesOfInterest
forall x. Rep GetFilesOfInterest x -> GetFilesOfInterest
forall x. GetFilesOfInterest -> Rep GetFilesOfInterest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetFilesOfInterest x -> GetFilesOfInterest
$cfrom :: forall x. GetFilesOfInterest -> Rep GetFilesOfInterest x
Generic)
instance Hashable GetFilesOfInterest
instance NFData   GetFilesOfInterest
instance Binary   GetFilesOfInterest


-- | 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
  GetFilesOfInterest
  (HashMap NormalizedFilePath FileOfInterestStatus)
-> Rules ()
forall k v. IdeRule k v => RuleBody k v -> Rules ()
defineEarlyCutoff (RuleBody
   GetFilesOfInterest
   (HashMap NormalizedFilePath FileOfInterestStatus)
 -> Rules ())
-> RuleBody
     GetFilesOfInterest
     (HashMap NormalizedFilePath FileOfInterestStatus)
-> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetFilesOfInterest
 -> NormalizedFilePath
 -> Action
      (Maybe ByteString,
       Maybe (HashMap NormalizedFilePath FileOfInterestStatus)))
-> RuleBody
     GetFilesOfInterest
     (HashMap NormalizedFilePath FileOfInterestStatus)
forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics ((GetFilesOfInterest
  -> NormalizedFilePath
  -> Action
       (Maybe ByteString,
        Maybe (HashMap NormalizedFilePath FileOfInterestStatus)))
 -> RuleBody
      GetFilesOfInterest
      (HashMap NormalizedFilePath FileOfInterestStatus))
-> (GetFilesOfInterest
    -> NormalizedFilePath
    -> Action
         (Maybe ByteString,
          Maybe (HashMap NormalizedFilePath FileOfInterestStatus)))
-> RuleBody
     GetFilesOfInterest
     (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ \GetFilesOfInterest
GetFilesOfInterest NormalizedFilePath
_file -> Bool
-> Action
     (Maybe ByteString,
      Maybe (HashMap NormalizedFilePath FileOfInterestStatus))
-> Action
     (Maybe ByteString,
      Maybe (HashMap NormalizedFilePath FileOfInterestStatus))
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
_file) (Action
   (Maybe ByteString,
    Maybe (HashMap NormalizedFilePath FileOfInterestStatus))
 -> Action
      (Maybe ByteString,
       Maybe (HashMap NormalizedFilePath FileOfInterestStatus)))
-> Action
     (Maybe ByteString,
      Maybe (HashMap NormalizedFilePath FileOfInterestStatus))
-> Action
     (Maybe ByteString,
      Maybe (HashMap NormalizedFilePath FileOfInterestStatus))
forall a b. (a -> b) -> a -> b
$ do
        Action ()
alwaysRerun
        HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
        let !cutoff :: ByteString
cutoff = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [(NormalizedFilePath, FileOfInterestStatus)] -> ByteString
forall a. Binary a => a -> ByteString
encode ([(NormalizedFilePath, FileOfInterestStatus)] -> ByteString)
-> [(NormalizedFilePath, FileOfInterestStatus)] -> ByteString
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [(NormalizedFilePath, FileOfInterestStatus)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest
        pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
cutoff, HashMap NormalizedFilePath FileOfInterestStatus
-> Maybe (HashMap NormalizedFilePath FileOfInterestStatus)
forall a. a -> Maybe a
Just HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest)

-- | Get the files that are open in the IDE.
getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest = GetFilesOfInterest
-> Action (HashMap NormalizedFilePath FileOfInterestStatus)
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetFilesOfInterest
GetFilesOfInterest

------------------------------------------------------------
-- 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 = IdeState
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO ()
modifyFilesOfInterest IdeState
state (HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall a b. a -> b -> a
const 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

-- | Modify the files-of-interest - not usually necessary or advisable.
--   The LSP client will keep this information up to date.
modifyFilesOfInterest
  :: IdeState
  -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus)
  -> IO ()
modifyFilesOfInterest :: IdeState
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO ()
modifyFilesOfInterest IdeState
state HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
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
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 ([(NormalizedFilePath, FileOfInterestStatus)] -> String
forall a. Show a => a -> String
show ([(NormalizedFilePath, FileOfInterestStatus)] -> String)
-> [(NormalizedFilePath, FileOfInterestStatus)] -> String
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [(NormalizedFilePath, FileOfInterestStatus)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList 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)
getFilesOfInterest
    ShakeExtras{ProgressEvent -> IO ()
progressUpdate :: ShakeExtras -> ProgressEvent -> IO ()
progressUpdate :: ProgressEvent -> IO ()
progressUpdate} <- 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
$ ProgressEvent -> IO ()
progressUpdate ProgressEvent
KickStarted

    -- Update the exports map for FOIs
    [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

    -- Update the exports map for non FOIs
    -- We can skip this if checkProject is True, assuming they never change under our feet.
    IdeOptions{ optCheckProject :: IdeOptions -> IO Bool
optCheckProject = IO Bool
doCheckProject } <- Action IdeOptions
getIdeOptions
    Bool
checkProject <- IO Bool -> Action Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
doCheckProject
    Maybe [ModIface]
ifaces <- if Bool
checkProject then Maybe [ModIface] -> Action (Maybe [ModIface])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [ModIface]
forall a. Maybe a
Nothing else MaybeT Action [ModIface] -> Action (Maybe [ModIface])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Action [ModIface] -> Action (Maybe [ModIface]))
-> MaybeT Action [ModIface] -> Action (Maybe [ModIface])
forall a b. (a -> b) -> a -> b
$ do
        [TransitiveDependencies]
deps <- Action (Maybe [TransitiveDependencies])
-> MaybeT Action [TransitiveDependencies]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Action (Maybe [TransitiveDependencies])
 -> MaybeT Action [TransitiveDependencies])
-> Action (Maybe [TransitiveDependencies])
-> MaybeT Action [TransitiveDependencies]
forall a b. (a -> b) -> a -> b
$ [Maybe TransitiveDependencies] -> Maybe [TransitiveDependencies]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe TransitiveDependencies] -> Maybe [TransitiveDependencies])
-> Action [Maybe TransitiveDependencies]
-> Action (Maybe [TransitiveDependencies])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetDependencies
-> [NormalizedFilePath] -> Action [Maybe TransitiveDependencies]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetDependencies
GetDependencies [NormalizedFilePath]
files
        [Maybe HiFileResult]
hiResults <- Action [Maybe HiFileResult] -> MaybeT Action [Maybe HiFileResult]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action [Maybe HiFileResult] -> MaybeT Action [Maybe HiFileResult])
-> Action [Maybe HiFileResult]
-> MaybeT Action [Maybe HiFileResult]
forall a b. (a -> b) -> a -> b
$ GetModIface -> [NormalizedFilePath] -> Action [Maybe HiFileResult]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetModIface
GetModIface ([NormalizedFilePath] -> [NormalizedFilePath]
forall a. Ord a => [a] -> [a]
nubOrd ([NormalizedFilePath] -> [NormalizedFilePath])
-> [NormalizedFilePath] -> [NormalizedFilePath]
forall a b. (a -> b) -> a -> b
$ (TransitiveDependencies -> [NormalizedFilePath])
-> [TransitiveDependencies] -> [NormalizedFilePath]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TransitiveDependencies -> [NormalizedFilePath]
transitiveModuleDeps [TransitiveDependencies]
deps)
        return $ (HiFileResult -> ModIface) -> [HiFileResult] -> [ModIface]
forall a b. (a -> b) -> [a] -> [b]
map HiFileResult -> ModIface
hirModIface ([HiFileResult] -> [ModIface]) -> [HiFileResult] -> [ModIface]
forall a b. (a -> b) -> a -> b
$ [Maybe HiFileResult] -> [HiFileResult]
forall a. [Maybe a] -> [a]
catMaybes [Maybe HiFileResult]
hiResults

    ShakeExtras{Var ExportsMap
exportsMap :: ShakeExtras -> Var ExportsMap
exportsMap :: Var ExportsMap
exportsMap} <- Action ShakeExtras
getShakeExtras
    let mguts :: [ModGuts]
mguts = [Maybe ModGuts] -> [ModGuts]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModGuts]
results
        !exportsMap' :: ExportsMap
exportsMap' = [ModGuts] -> ExportsMap
createExportsMapMg [ModGuts]
mguts
        !exportsMap'' :: ExportsMap
exportsMap'' = ExportsMap
-> ([ModIface] -> ExportsMap) -> Maybe [ModIface] -> ExportsMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExportsMap
forall a. Monoid a => a
mempty [ModIface] -> ExportsMap
createExportsMap Maybe [ModIface]
ifaces
    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) -> IO ExportsMap)
-> (ExportsMap -> ExportsMap) -> IO ExportsMap
forall a b. (a -> b) -> a -> b
$ (ExportsMap
exportsMap'' ExportsMap -> ExportsMap -> ExportsMap
forall a. Semigroup a => a -> a -> a
<>) (ExportsMap -> ExportsMap)
-> (ExportsMap -> ExportsMap) -> ExportsMap -> ExportsMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
$ ProgressEvent -> IO ()
progressUpdate ProgressEvent
KickCompleted