{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE PatternSynonyms            #-}

-- | A Shake implementation of the compiler service.
--
--   There are two primary locations where data lives, and both of
--   these contain much the same data:
--
-- * The Shake database (inside 'shakeDb') stores a map of shake keys
--   to shake values. In our case, these are all of type 'Q' to 'A'.
--   During a single run all the values in the Shake database are consistent
--   so are used in conjunction with each other, e.g. in 'uses'.
--
-- * The 'Values' type stores a map of keys to values. These values are
--   always stored as real Haskell values, whereas Shake serialises all 'A' values
--   between runs. To deserialise a Shake value, we just consult Values.
module Development.IDE.Core.Shake(
    IdeState, shakeExtras,
    ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
    KnownTargets, Target(..), toKnownFiles,
    IdeRule, IdeResult,
    GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
    shakeOpen, shakeShut,
    shakeRestart,
    shakeEnqueue,
    shakeProfile,
    use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
    FastResult(..),
    use_, useNoFile_, uses_,
    useWithStale, usesWithStale,
    useWithStale_, usesWithStale_,
    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
    getDiagnostics, unsafeClearDiagnostics,
    getHiddenDiagnostics,
    IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
    getIdeGlobalExtras,
    getIdeOptions,
    getIdeOptionsIO,
    GlobalIdeOptions(..),
    garbageCollect,
    knownTargets,
    setPriority,
    sendEvent,
    ideLogger,
    actionLogger,
    FileVersion(..),
    Priority(..),
    updatePositionMapping,
    deleteValue,
    OnDiskRule(..),
    WithProgressFunc, WithIndefiniteProgressFunc,
    ProgressEvent(..),
    DelayedAction, mkDelayedAction,
    IdeAction(..), runIdeAction,
    mkUpdater,
    -- Exposed for testing.
    Q(..),
    ) where

import           Development.Shake hiding (ShakeValue, doesFileExist, Info)
import           Development.Shake.Database
import           Development.Shake.Classes
import           Development.Shake.Rule
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HMap
import qualified Data.Map.Strict as Map
import qualified Data.ByteString.Char8 as BS
import           Data.Dynamic
import           Data.Maybe
import           Data.Map.Strict (Map)
import           Data.List.Extra (partition, takeEnd)
import           Data.HashSet (HashSet)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Tuple.Extra
import Data.Unique
import Development.IDE.Core.Debouncer
import Development.IDE.GHC.Compat (ModuleName, NameCacheUpdater(..), upNameCache )
import Development.IDE.GHC.Orphans ()
import Development.IDE.Core.PositionMapping
import Development.IDE.Types.Action
import Development.IDE.Types.Logger hiding (Priority)
import qualified Development.IDE.Types.Logger as Logger
import Language.Haskell.LSP.Diagnostics
import qualified Data.SortedList as SL
import           Development.IDE.Types.Diagnostics
import Development.IDE.Types.Exports
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import           Control.Concurrent.Async
import           Control.Concurrent.Extra
import           Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, atomically)
import           Control.DeepSeq
import           Control.Exception.Extra
import           System.Time.Extra
import           Data.Typeable
import qualified Language.Haskell.LSP.Core as LSP
import qualified Language.Haskell.LSP.Messages as LSP
import qualified Language.Haskell.LSP.Types as LSP
import           System.FilePath hiding (makeRelative)
import qualified Development.Shake as Shake
import           Control.Monad.Extra
import           Data.Time
import           GHC.Generics
import           System.IO.Unsafe
import Language.Haskell.LSP.Types
import qualified Control.Monad.STM as STM
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Data.Traversable
import Data.Hashable

import Data.IORef
import NameCache
import UniqSupply
import PrelInfo
import Data.Int (Int64)
import qualified Data.HashSet as HSet

-- information we stash inside the shakeExtra field
data ShakeExtras = ShakeExtras
    {ShakeExtras -> FromServerMessage -> IO ()
eventer :: LSP.FromServerMessage -> IO ()
    ,ShakeExtras -> Debouncer NormalizedUri
debouncer :: Debouncer NormalizedUri
    ,ShakeExtras -> Logger
logger :: Logger
    ,ShakeExtras -> Var (HashMap TypeRep Dynamic)
globals :: Var (HMap.HashMap TypeRep Dynamic)
    ,ShakeExtras -> Var Values
state :: Var Values
    ,ShakeExtras -> Var DiagnosticStore
diagnostics :: Var DiagnosticStore
    ,ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
    ,ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
    -- ^ This represents the set of diagnostics that we have published.
    -- Due to debouncing not every change might get published.
    ,ShakeExtras
-> Var
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
    -- ^ Map from a text document version to a PositionMapping that describes how to map
    -- positions in a version of that document to positions in the latest version
    -- First mapping is delta from previous version and second one is an
    -- accumlation of all previous mappings.
    ,ShakeExtras -> Var (HashMap NormalizedFilePath Int)
inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
    -- ^ How many rules are running for each file
    ,ShakeExtras -> ProgressEvent -> IO ()
progressUpdate :: ProgressEvent -> IO ()
    -- ^ The generator for unique Lsp identifiers
    ,ShakeExtras -> IdeTesting
ideTesting :: IdeTesting
    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
    ,ShakeExtras -> MVar ShakeSession
session :: MVar ShakeSession
    -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
    ,ShakeExtras
-> forall a.
   Text
   -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
withProgress           :: WithProgressFunc
    -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')
    ,ShakeExtras
-> forall a. Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress :: WithIndefiniteProgressFunc
    -- ^ Same as 'withProgress', but for processes that do not report the percentage complete
    ,ShakeExtras -> [DelayedAction ()] -> IO ()
restartShakeSession :: [DelayedAction ()] -> IO ()
    ,ShakeExtras -> IORef NameCache
ideNc :: IORef NameCache
    -- | A mapping of module name to known target (or candidate targets, if missing)
    ,ShakeExtras -> Var (Hashed KnownTargets)
knownTargetsVar :: Var (Hashed KnownTargets)
    -- | A mapping of exported identifiers for local modules. Updated on kick
    ,ShakeExtras -> Var ExportsMap
exportsMap :: Var ExportsMap
    -- | A work queue for actions added via 'runInShakeSession'
    ,ShakeExtras -> ActionQueue
actionQueue :: ActionQueue
    }

-- | A mapping of module name to known files
type KnownTargets = HashMap Target [NormalizedFilePath]

data Target = TargetModule ModuleName | TargetFile NormalizedFilePath
  deriving ( Target -> Target -> Bool
(Target -> Target -> Bool)
-> (Target -> Target -> Bool) -> Eq Target
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Target -> Target -> Bool
$c/= :: Target -> Target -> Bool
== :: Target -> Target -> Bool
$c== :: Target -> Target -> Bool
Eq, (forall x. Target -> Rep Target x)
-> (forall x. Rep Target x -> Target) -> Generic Target
forall x. Rep Target x -> Target
forall x. Target -> Rep Target x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Target x -> Target
$cfrom :: forall x. Target -> Rep Target x
Generic, Int -> Target -> ShowS
[Target] -> ShowS
Target -> String
(Int -> Target -> ShowS)
-> (Target -> String) -> ([Target] -> ShowS) -> Show Target
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Target] -> ShowS
$cshowList :: [Target] -> ShowS
show :: Target -> String
$cshow :: Target -> String
showsPrec :: Int -> Target -> ShowS
$cshowsPrec :: Int -> Target -> ShowS
Show )
  deriving anyclass (Int -> Target -> Int
Target -> Int
(Int -> Target -> Int) -> (Target -> Int) -> Hashable Target
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Target -> Int
$chash :: Target -> Int
hashWithSalt :: Int -> Target -> Int
$chashWithSalt :: Int -> Target -> Int
Hashable, Target -> ()
(Target -> ()) -> NFData Target
forall a. (a -> ()) -> NFData a
rnf :: Target -> ()
$crnf :: Target -> ()
NFData)

toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath
toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath
toKnownFiles = [NormalizedFilePath] -> HashSet NormalizedFilePath
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HSet.fromList ([NormalizedFilePath] -> HashSet NormalizedFilePath)
-> (KnownTargets -> [NormalizedFilePath])
-> KnownTargets
-> HashSet NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[NormalizedFilePath]] -> [NormalizedFilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[NormalizedFilePath]] -> [NormalizedFilePath])
-> (KnownTargets -> [[NormalizedFilePath]])
-> KnownTargets
-> [NormalizedFilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KnownTargets -> [[NormalizedFilePath]]
forall k v. HashMap k v -> [v]
HMap.elems

type WithProgressFunc = forall a.
    T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a
type WithIndefiniteProgressFunc = forall a.
    T.Text -> LSP.ProgressCancellable -> IO a -> IO a

data ProgressEvent
    = KickStarted
    | KickCompleted

getShakeExtras :: Action ShakeExtras
getShakeExtras :: Action ShakeExtras
getShakeExtras = do
    Just ShakeExtras
x <- Typeable ShakeExtras => Action (Maybe ShakeExtras)
forall a. Typeable a => Action (Maybe a)
getShakeExtra @ShakeExtras
    ShakeExtras -> Action ShakeExtras
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x

getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules = do
    Just ShakeExtras
x <- Typeable ShakeExtras => Rules (Maybe ShakeExtras)
forall a. Typeable a => Rules (Maybe a)
getShakeExtraRules @ShakeExtras
    ShakeExtras -> Rules ShakeExtras
forall (m :: * -> *) a. Monad m => a -> m a
return ShakeExtras
x

class Typeable a => IsIdeGlobal a where

addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
addIdeGlobal :: a -> Rules ()
addIdeGlobal a
x = do
    ShakeExtras
extras <- Rules ShakeExtras
getShakeExtrasRules
    IO () -> Rules ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rules ()) -> IO () -> Rules ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> a -> IO ()
forall a. IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras
extras a
x

addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
addIdeGlobalExtras :: ShakeExtras -> a -> IO ()
addIdeGlobalExtras ShakeExtras{Var (HashMap TypeRep Dynamic)
globals :: Var (HashMap TypeRep Dynamic)
globals :: ShakeExtras -> Var (HashMap TypeRep Dynamic)
globals} x :: a
x@(a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf -> TypeRep
ty) =
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (HashMap TypeRep Dynamic)
-> (HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap TypeRep Dynamic)
globals ((HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
 -> IO ())
-> (HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap TypeRep Dynamic
mp -> case TypeRep -> HashMap TypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup TypeRep
ty HashMap TypeRep Dynamic
mp of
        Just Dynamic
_ -> String -> IO (HashMap TypeRep Dynamic)
forall a. Partial => String -> IO a
errorIO (String -> IO (HashMap TypeRep Dynamic))
-> String -> IO (HashMap TypeRep Dynamic)
forall a b. (a -> b) -> a -> b
$ String
"Internal error, addIdeGlobalExtras, got the same type twice for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
ty
        Maybe Dynamic
Nothing -> HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic))
-> HashMap TypeRep Dynamic -> IO (HashMap TypeRep Dynamic)
forall a b. (a -> b) -> a -> b
$! TypeRep
-> Dynamic -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert TypeRep
ty (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x) HashMap TypeRep Dynamic
mp


getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras :: ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras{Var (HashMap TypeRep Dynamic)
globals :: Var (HashMap TypeRep Dynamic)
globals :: ShakeExtras -> Var (HashMap TypeRep Dynamic)
globals} = do
    let typ :: TypeRep
typ = Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    Maybe Dynamic
x <- TypeRep -> HashMap TypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (HashMap TypeRep Dynamic -> Maybe Dynamic)
-> IO (HashMap TypeRep Dynamic) -> IO (Maybe Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var (HashMap TypeRep Dynamic) -> IO (HashMap TypeRep Dynamic)
forall a. Var a -> IO a
readVar Var (HashMap TypeRep Dynamic)
globals
    case Maybe Dynamic
x of
        Just Dynamic
x
            | Just a
x <- Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
x -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
            | Bool
otherwise -> String -> IO a
forall a. Partial => String -> IO a
errorIO (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Internal error, getIdeGlobalExtras, wrong type for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
typ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Dynamic -> TypeRep
dynTypeRep Dynamic
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Maybe Dynamic
Nothing -> String -> IO a
forall a. Partial => String -> IO a
errorIO (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Internal error, getIdeGlobalExtras, no entry for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
typ

getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
getIdeGlobalAction :: Action a
getIdeGlobalAction = IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Action a)
-> (ShakeExtras -> IO a) -> ShakeExtras -> Action a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeExtras -> IO a
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras (ShakeExtras -> Action a) -> Action ShakeExtras -> Action a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action ShakeExtras
getShakeExtras

getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState :: IdeState -> IO a
getIdeGlobalState = ShakeExtras -> IO a
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras (ShakeExtras -> IO a)
-> (IdeState -> ShakeExtras) -> IdeState -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeState -> ShakeExtras
shakeExtras


-- | The state of the all values.
type Values = HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)

-- | Key type
data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k

instance Show Key where
  show :: Key -> String
show (Key k
k) = k -> String
forall a. Show a => a -> String
show k
k

instance Eq Key where
    Key k
k1 == :: Key -> Key -> Bool
== Key k
k2 | Just k
k2' <- k -> Maybe k
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast k
k2 = k
k1 k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k2'
                     | Bool
otherwise = Bool
False

instance Hashable Key where
    hashWithSalt :: Int -> Key -> Int
hashWithSalt Int
salt (Key k
key) = Int -> (TypeRep, k) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (k -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf k
key, k
key)

newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
instance IsIdeGlobal GlobalIdeOptions

getIdeOptions :: Action IdeOptions
getIdeOptions :: Action IdeOptions
getIdeOptions = do
    GlobalIdeOptions IdeOptions
x <- Action GlobalIdeOptions
forall a. IsIdeGlobal a => Action a
getIdeGlobalAction
    IdeOptions -> Action IdeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x

getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
ide = do
    GlobalIdeOptions IdeOptions
x <- ShakeExtras -> IO GlobalIdeOptions
forall a. IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras
ide
    IdeOptions -> IO IdeOptions
forall (m :: * -> *) a. Monad m => a -> m a
return IdeOptions
x

data Value v
    = Succeeded TextDocumentVersion v
    | Stale TextDocumentVersion v
    | Failed
    deriving (a -> Value b -> Value a
(a -> b) -> Value a -> Value b
(forall a b. (a -> b) -> Value a -> Value b)
-> (forall a b. a -> Value b -> Value a) -> Functor Value
forall a b. a -> Value b -> Value a
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Value b -> Value a
$c<$ :: forall a b. a -> Value b -> Value a
fmap :: (a -> b) -> Value a -> Value b
$cfmap :: forall a b. (a -> b) -> Value a -> Value b
Functor, (forall x. Value v -> Rep (Value v) x)
-> (forall x. Rep (Value v) x -> Value v) -> Generic (Value v)
forall x. Rep (Value v) x -> Value v
forall x. Value v -> Rep (Value v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v x. Rep (Value v) x -> Value v
forall v x. Value v -> Rep (Value v) x
$cto :: forall v x. Rep (Value v) x -> Value v
$cfrom :: forall v x. Value v -> Rep (Value v) x
Generic, Int -> Value v -> ShowS
[Value v] -> ShowS
Value v -> String
(Int -> Value v -> ShowS)
-> (Value v -> String) -> ([Value v] -> ShowS) -> Show (Value v)
forall v. Show v => Int -> Value v -> ShowS
forall v. Show v => [Value v] -> ShowS
forall v. Show v => Value v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value v] -> ShowS
$cshowList :: forall v. Show v => [Value v] -> ShowS
show :: Value v -> String
$cshow :: forall v. Show v => Value v -> String
showsPrec :: Int -> Value v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> Value v -> ShowS
Show)

instance NFData v => NFData (Value v)

-- | Convert a Value to a Maybe. This will only return `Just` for
-- up2date results not for stale values.
currentValue :: Value v -> Maybe v
currentValue :: Value v -> Maybe v
currentValue (Succeeded TextDocumentVersion
_ v
v) = v -> Maybe v
forall a. a -> Maybe a
Just v
v
currentValue (Stale TextDocumentVersion
_ v
_) = Maybe v
forall a. Maybe a
Nothing
currentValue Value v
Failed = Maybe v
forall a. Maybe a
Nothing

-- | Return the most recent, potentially stale, value and a PositionMapping
-- for the version of that value.
lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
lastValueIO :: ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras{Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: ShakeExtras
-> Var
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping} NormalizedFilePath
file Value v
v = do
    HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings <- IO
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (HashMap
      NormalizedUri
      (Map TextDocumentVersion (PositionDelta, PositionMapping)))
 -> IO
      (HashMap
         NormalizedUri
         (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a b. (a -> b) -> a -> b
$ Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a. Var a -> IO a
readVar Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping
    Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping)))
-> Maybe (v, PositionMapping) -> IO (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ case Value v
v of
        Succeeded TextDocumentVersion
ver v
v -> (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just (v
v, HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
forall a.
HashMap
  NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver)
        Stale TextDocumentVersion
ver v
v -> (v, PositionMapping) -> Maybe (v, PositionMapping)
forall a. a -> Maybe a
Just (v
v, HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
forall a.
HashMap
  NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver)
        Value v
Failed -> Maybe (v, PositionMapping)
forall a. Maybe a
Nothing

-- | Return the most recent, potentially stale, value and a PositionMapping
-- for the version of that value.
lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
lastValue :: NormalizedFilePath
-> Value v -> Action (Maybe (v, PositionMapping))
lastValue NormalizedFilePath
file Value v
v = do
    ShakeExtras
s <- Action ShakeExtras
getShakeExtras
    IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (v, PositionMapping))
 -> Action (Maybe (v, PositionMapping)))
-> IO (Maybe (v, PositionMapping))
-> Action (Maybe (v, PositionMapping))
forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
forall v.
ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s NormalizedFilePath
file Value v
v

valueVersion :: Value v -> Maybe TextDocumentVersion
valueVersion :: Value v -> Maybe TextDocumentVersion
valueVersion = \case
    Succeeded TextDocumentVersion
ver v
_ -> TextDocumentVersion -> Maybe TextDocumentVersion
forall a. a -> Maybe a
Just TextDocumentVersion
ver
    Stale TextDocumentVersion
ver v
_ -> TextDocumentVersion -> Maybe TextDocumentVersion
forall a. a -> Maybe a
Just TextDocumentVersion
ver
    Value v
Failed -> Maybe TextDocumentVersion
forall a. Maybe a
Nothing

mappingForVersion
    :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
    -> NormalizedFilePath
    -> TextDocumentVersion
    -> PositionMapping
mappingForVersion :: HashMap
  NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> NormalizedFilePath -> TextDocumentVersion -> PositionMapping
mappingForVersion HashMap
  NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
allMappings NormalizedFilePath
file TextDocumentVersion
ver =
    PositionMapping
-> ((a, PositionMapping) -> PositionMapping)
-> Maybe (a, PositionMapping)
-> PositionMapping
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PositionMapping
zeroMapping (a, PositionMapping) -> PositionMapping
forall a b. (a, b) -> b
snd (Maybe (a, PositionMapping) -> PositionMapping)
-> Maybe (a, PositionMapping) -> PositionMapping
forall a b. (a -> b) -> a -> b
$
    TextDocumentVersion
-> Map TextDocumentVersion (a, PositionMapping)
-> Maybe (a, PositionMapping)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TextDocumentVersion
ver (Map TextDocumentVersion (a, PositionMapping)
 -> Maybe (a, PositionMapping))
-> Maybe (Map TextDocumentVersion (a, PositionMapping))
-> Maybe (a, PositionMapping)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    NormalizedUri
-> HashMap
     NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-> Maybe (Map TextDocumentVersion (a, PositionMapping))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file) HashMap
  NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
allMappings

type IdeRule k v =
  ( Shake.RuleResult k ~ v
  , Shake.ShakeValue k
  , Show v
  , Typeable v
  , NFData v
  )

-- | A live Shake session with the ability to enqueue Actions for running.
--   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.
newtype ShakeSession = ShakeSession
  { ShakeSession -> IO ()
cancelShakeSession :: IO ()
    -- ^ Closes the Shake session
  }

-- | A Shake database plus persistent store. Can be thought of as storing
--   mappings from @(FilePath, k)@ to @RuleResult k@.
data IdeState = IdeState
    {IdeState -> ShakeDatabase
shakeDb         :: ShakeDatabase
    ,IdeState -> MVar ShakeSession
shakeSession    :: MVar ShakeSession
    ,IdeState -> IO ()
shakeClose      :: IO ()
    ,IdeState -> ShakeExtras
shakeExtras     :: ShakeExtras
    ,IdeState -> Maybe String
shakeProfileDir :: Maybe FilePath
    ,IdeState -> IO ()
stopProgressReporting :: IO ()
    }



-- This is debugging code that generates a series of profiles, if the Boolean is true
shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath)
shakeDatabaseProfile :: Maybe String -> ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile Maybe String
mbProfileDir ShakeDatabase
shakeDb =
        Maybe String -> (String -> IO String) -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe String
mbProfileDir ((String -> IO String) -> IO (Maybe String))
-> (String -> IO String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
                Int
count <- Var Int -> (Int -> IO (Int, Int)) -> IO Int
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Int
profileCounter ((Int -> IO (Int, Int)) -> IO Int)
-> (Int -> IO (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
x -> let !y :: Int
y = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y,Int
y)
                let file :: String
file = String
"ide-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
profileStartTime String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
takeEnd Int
5 (String
"0000" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count) String -> ShowS
<.> String
"html"
                ShakeDatabase -> String -> IO ()
shakeProfileDatabase ShakeDatabase
shakeDb (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
file
                String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dir String -> ShowS
</> String
file)

{-# NOINLINE profileStartTime #-}
profileStartTime :: String
profileStartTime :: String
profileStartTime = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%d-%H%M%S" (UTCTime -> String) -> IO UTCTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime

{-# NOINLINE profileCounter #-}
profileCounter :: Var Int
profileCounter :: Var Int
profileCounter = IO (Var Int) -> Var Int
forall a. IO a -> a
unsafePerformIO (IO (Var Int) -> Var Int) -> IO (Var Int) -> Var Int
forall a b. (a -> b) -> a -> b
$ Int -> IO (Var Int)
forall a. a -> IO (Var a)
newVar Int
0

setValues :: IdeRule k v
          => Var Values
          -> k
          -> NormalizedFilePath
          -> Value v
          -> IO ()
setValues :: Var Values -> k -> NormalizedFilePath -> Value v -> IO ()
setValues Var Values
state k
key NormalizedFilePath
file Value v
val = Var Values -> (Values -> IO Values) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var Values
state ((Values -> IO Values) -> IO ()) -> (Values -> IO Values) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Values
vals -> do
    -- Force to make sure the old HashMap is not retained
    Values -> IO Values
forall a. a -> IO a
evaluate (Values -> IO Values) -> Values -> IO Values
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath, Key) -> Value Dynamic -> Values -> Values
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert (NormalizedFilePath
file, k -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key k
key) ((v -> Dynamic) -> Value v -> Value Dynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Value v
val) Values
vals

-- | Delete the value stored for a given ide build key
deleteValue
  :: (Typeable k, Hashable k, Eq k, Show k)
  => IdeState
  -> k
  -> NormalizedFilePath
  -> IO ()
deleteValue :: IdeState -> k -> NormalizedFilePath -> IO ()
deleteValue IdeState{shakeExtras :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var Values
state :: Var Values
state :: ShakeExtras -> Var Values
state}} k
key NormalizedFilePath
file = Var Values -> (Values -> IO Values) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var Values
state ((Values -> IO Values) -> IO ()) -> (Values -> IO Values) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Values
vals ->
    Values -> IO Values
forall a. a -> IO a
evaluate (Values -> IO Values) -> Values -> IO Values
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath, Key) -> Values -> Values
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HMap.delete (NormalizedFilePath
file, k -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key k
key) Values
vals

-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues :: Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state k
key NormalizedFilePath
file = do
    Values
vs <- Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
state
    case (NormalizedFilePath, Key) -> Values -> Maybe (Value Dynamic)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (NormalizedFilePath
file, k -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key k
key) Values
vs of
        Maybe (Value Dynamic)
Nothing -> Maybe (Value v) -> IO (Maybe (Value v))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Value v)
forall a. Maybe a
Nothing
        Just Value Dynamic
v -> do
            let r :: Value v
r = (Dynamic -> v) -> Value Dynamic -> Value v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe v -> v
forall a. Partial => Maybe a -> a
fromJust (Maybe v -> v) -> (Dynamic -> Maybe v) -> Dynamic -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typeable v => Dynamic -> Maybe v
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @v) Value Dynamic
v
            -- Force to make sure we do not retain a reference to the HashMap
            -- and we blow up immediately if the fromJust should fail
            -- (which would be an internal error).
            Maybe (Value v) -> IO (Maybe (Value v))
forall a. a -> IO a
evaluate (Value v
r Value v -> Maybe (Value v) -> Maybe (Value v)
forall v b. Value v -> b -> b
`seqValue` Value v -> Maybe (Value v)
forall a. a -> Maybe a
Just Value v
r)

-- | Get all the files in the project
knownTargets :: Action (Hashed KnownTargets)
knownTargets :: Action (Hashed KnownTargets)
knownTargets = do
  ShakeExtras{Var (Hashed KnownTargets)
knownTargetsVar :: Var (Hashed KnownTargets)
knownTargetsVar :: ShakeExtras -> Var (Hashed KnownTargets)
knownTargetsVar} <- Action ShakeExtras
getShakeExtras
  IO (Hashed KnownTargets) -> Action (Hashed KnownTargets)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Hashed KnownTargets) -> Action (Hashed KnownTargets))
-> IO (Hashed KnownTargets) -> Action (Hashed KnownTargets)
forall a b. (a -> b) -> a -> b
$ Var (Hashed KnownTargets) -> IO (Hashed KnownTargets)
forall a. Var a -> IO a
readVar Var (Hashed KnownTargets)
knownTargetsVar

-- | Seq the result stored in the Shake value. This only
-- evaluates the value to WHNF not NF. We take care of the latter
-- elsewhere and doing it twice is expensive.
seqValue :: Value v -> b -> b
seqValue :: Value v -> b -> b
seqValue Value v
v b
b = case Value v
v of
    Succeeded TextDocumentVersion
ver v
v -> TextDocumentVersion -> ()
forall a. NFData a => a -> ()
rnf TextDocumentVersion
ver () -> b -> b
`seq` v
v v -> b -> b
`seq` b
b
    Stale TextDocumentVersion
ver v
v -> TextDocumentVersion -> ()
forall a. NFData a => a -> ()
rnf TextDocumentVersion
ver () -> b -> b
`seq` v
v v -> b -> b
`seq` b
b
    Value v
Failed -> b
b

-- | Open a 'IdeState', should be shut using 'shakeShut'.
shakeOpen :: IO LSP.LspId
          -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
          -> WithProgressFunc
          -> WithIndefiniteProgressFunc
          -> Logger
          -> Debouncer NormalizedUri
          -> Maybe FilePath
          -> IdeReportProgress
          -> IdeTesting
          -> ShakeOptions
          -> Rules ()
          -> IO IdeState
shakeOpen :: IO LspId
-> (FromServerMessage -> IO ())
-> (forall a.
    Text
    -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a)
-> (forall a. Text -> ProgressCancellable -> IO a -> IO a)
-> Logger
-> Debouncer NormalizedUri
-> Maybe String
-> IdeReportProgress
-> IdeTesting
-> ShakeOptions
-> Rules ()
-> IO IdeState
shakeOpen IO LspId
getLspId FromServerMessage -> IO ()
eventer forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
withProgress forall a. Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress Logger
logger Debouncer NormalizedUri
debouncer
  Maybe String
shakeProfileDir (IdeReportProgress Bool
reportProgress) ideTesting :: IdeTesting
ideTesting@(IdeTesting Bool
testing) ShakeOptions
opts Rules ()
rules = mdo

    Var (HashMap NormalizedFilePath Int)
inProgress <- HashMap NormalizedFilePath Int
-> IO (Var (HashMap NormalizedFilePath Int))
forall a. a -> IO (Var a)
newVar HashMap NormalizedFilePath Int
forall k v. HashMap k v
HMap.empty
    UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'r'
    IORef NameCache
ideNc <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
us [Name]
knownKeyNames)
    (ShakeExtras
shakeExtras, IO ()
stopProgressReporting) <- do
        Var (HashMap TypeRep Dynamic)
globals <- HashMap TypeRep Dynamic -> IO (Var (HashMap TypeRep Dynamic))
forall a. a -> IO (Var a)
newVar HashMap TypeRep Dynamic
forall k v. HashMap k v
HMap.empty
        Var Values
state <- Values -> IO (Var Values)
forall a. a -> IO (Var a)
newVar Values
forall k v. HashMap k v
HMap.empty
        Var DiagnosticStore
diagnostics <- DiagnosticStore -> IO (Var DiagnosticStore)
forall a. a -> IO (Var a)
newVar DiagnosticStore
forall a. Monoid a => a
mempty
        Var DiagnosticStore
hiddenDiagnostics <- DiagnosticStore -> IO (Var DiagnosticStore)
forall a. a -> IO (Var a)
newVar DiagnosticStore
forall a. Monoid a => a
mempty
        Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics <- HashMap NormalizedUri [Diagnostic]
-> IO (Var (HashMap NormalizedUri [Diagnostic]))
forall a. a -> IO (Var a)
newVar HashMap NormalizedUri [Diagnostic]
forall a. Monoid a => a
mempty
        Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping <- HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
     (Var
        (HashMap
           NormalizedUri
           (Map TextDocumentVersion (PositionDelta, PositionMapping))))
forall a. a -> IO (Var a)
newVar HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
forall k v. HashMap k v
HMap.empty
        Var (Hashed KnownTargets)
knownTargetsVar <- Hashed KnownTargets -> IO (Var (Hashed KnownTargets))
forall a. a -> IO (Var a)
newVar (Hashed KnownTargets -> IO (Var (Hashed KnownTargets)))
-> Hashed KnownTargets -> IO (Var (Hashed KnownTargets))
forall a b. (a -> b) -> a -> b
$ KnownTargets -> Hashed KnownTargets
forall a. Hashable a => a -> Hashed a
hashed KnownTargets
forall k v. HashMap k v
HMap.empty
        let restartShakeSession :: [DelayedAction ()] -> IO ()
restartShakeSession = IdeState -> [DelayedAction ()] -> IO ()
shakeRestart IdeState
ideState
        let session :: MVar ShakeSession
session = MVar ShakeSession
shakeSession
        TVar ProgressEvent
mostRecentProgressEvent <- ProgressEvent -> IO (TVar ProgressEvent)
forall a. a -> IO (TVar a)
newTVarIO ProgressEvent
KickCompleted
        let progressUpdate :: ProgressEvent -> IO ()
progressUpdate = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (ProgressEvent -> STM ()) -> ProgressEvent -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ProgressEvent -> ProgressEvent -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ProgressEvent
mostRecentProgressEvent
        Async ()
progressAsync <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
reportProgress (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TVar ProgressEvent -> Var (HashMap NormalizedFilePath Int) -> IO ()
progressThread TVar ProgressEvent
mostRecentProgressEvent Var (HashMap NormalizedFilePath Int)
inProgress
        Var ExportsMap
exportsMap <- ExportsMap -> IO (Var ExportsMap)
forall a. a -> IO (Var a)
newVar ExportsMap
forall a. Monoid a => a
mempty

        ActionQueue
actionQueue <- IO ActionQueue
newQueue

        (ShakeExtras, IO ()) -> IO (ShakeExtras, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeExtras :: (FromServerMessage -> IO ())
-> Debouncer NormalizedUri
-> Logger
-> Var (HashMap TypeRep Dynamic)
-> Var Values
-> Var DiagnosticStore
-> Var DiagnosticStore
-> Var (HashMap NormalizedUri [Diagnostic])
-> Var
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> Var (HashMap NormalizedFilePath Int)
-> (ProgressEvent -> IO ())
-> IdeTesting
-> MVar ShakeSession
-> (forall a.
    Text
    -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a)
-> (forall a. Text -> ProgressCancellable -> IO a -> IO a)
-> ([DelayedAction ()] -> IO ())
-> IORef NameCache
-> Var (Hashed KnownTargets)
-> Var ExportsMap
-> ActionQueue
-> ShakeExtras
ShakeExtras{IORef NameCache
MVar ShakeSession
Var (HashMap TypeRep Dynamic)
Var Values
Var (HashMap NormalizedUri [Diagnostic])
Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
Var DiagnosticStore
Var (HashMap NormalizedFilePath Int)
Var (Hashed KnownTargets)
Var ExportsMap
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
[DelayedAction ()] -> IO ()
FromServerMessage -> IO ()
ProgressEvent -> IO ()
forall a. Text -> ProgressCancellable -> IO a -> IO a
forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
actionQueue :: ActionQueue
exportsMap :: Var ExportsMap
progressUpdate :: ProgressEvent -> IO ()
session :: MVar ShakeSession
restartShakeSession :: [DelayedAction ()] -> IO ()
knownTargetsVar :: Var (Hashed KnownTargets)
positionMapping :: Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
hiddenDiagnostics :: Var DiagnosticStore
diagnostics :: Var DiagnosticStore
state :: Var Values
globals :: Var (HashMap TypeRep Dynamic)
ideNc :: IORef NameCache
inProgress :: Var (HashMap NormalizedFilePath Int)
ideTesting :: IdeTesting
debouncer :: Debouncer NormalizedUri
logger :: Logger
withIndefiniteProgress :: forall a. Text -> ProgressCancellable -> IO a -> IO a
withProgress :: forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
eventer :: FromServerMessage -> IO ()
actionQueue :: ActionQueue
exportsMap :: Var ExportsMap
knownTargetsVar :: Var (Hashed KnownTargets)
ideNc :: IORef NameCache
restartShakeSession :: [DelayedAction ()] -> IO ()
withIndefiniteProgress :: forall a. Text -> ProgressCancellable -> IO a -> IO a
withProgress :: forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
session :: MVar ShakeSession
ideTesting :: IdeTesting
progressUpdate :: ProgressEvent -> IO ()
inProgress :: Var (HashMap NormalizedFilePath Int)
positionMapping :: Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
hiddenDiagnostics :: Var DiagnosticStore
diagnostics :: Var DiagnosticStore
state :: Var Values
globals :: Var (HashMap TypeRep Dynamic)
logger :: Logger
debouncer :: Debouncer NormalizedUri
eventer :: FromServerMessage -> IO ()
..}, Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
progressAsync)
    (IO ShakeDatabase
shakeDbM, IO ()
shakeClose) <-
        ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
shakeOpenDatabase
            ShakeOptions
opts { shakeExtra :: HashMap TypeRep Dynamic
shakeExtra = ShakeExtras -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
forall a.
Typeable a =>
a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
addShakeExtra ShakeExtras
shakeExtras (HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic)
-> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> HashMap TypeRep Dynamic
shakeExtra ShakeOptions
opts }
            Rules ()
rules
    ShakeDatabase
shakeDb <- IO ShakeDatabase
shakeDbM
    ShakeSession
initSession <- ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> IO ShakeSession
newSession ShakeExtras
shakeExtras ShakeDatabase
shakeDb []
    MVar ShakeSession
shakeSession <- ShakeSession -> IO (MVar ShakeSession)
forall a. a -> IO (MVar a)
newMVar ShakeSession
initSession
    let ideState :: IdeState
ideState = IdeState :: ShakeDatabase
-> MVar ShakeSession
-> IO ()
-> ShakeExtras
-> Maybe String
-> IO ()
-> IdeState
IdeState{Maybe String
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
shakeDb :: ShakeDatabase
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
stopProgressReporting :: IO ()
shakeExtras :: ShakeExtras
shakeProfileDir :: Maybe String
stopProgressReporting :: IO ()
shakeProfileDir :: Maybe String
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
shakeExtras :: ShakeExtras
..}
    IdeState -> IO IdeState
forall (m :: * -> *) a. Monad m => a -> m a
return IdeState
ideState
    where
        -- The progress thread is a state machine with two states:
        --   1. Idle
        --   2. Reporting a kick event
        -- And two transitions, modelled by 'ProgressEvent':
        --   1. KickCompleted - transitions from Reporting into Idle
        --   2. KickStarted - transitions from Idle into Reporting
        progressThread :: TVar ProgressEvent -> Var (HashMap NormalizedFilePath Int) -> IO ()
progressThread TVar ProgressEvent
mostRecentProgressEvent Var (HashMap NormalizedFilePath Int)
inProgress = IO ()
progressLoopIdle
          where
            progressLoopIdle :: IO ()
progressLoopIdle = do
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    ProgressEvent
v <- TVar ProgressEvent -> STM ProgressEvent
forall a. TVar a -> STM a
readTVar TVar ProgressEvent
mostRecentProgressEvent
                    case ProgressEvent
v of
                        ProgressEvent
KickCompleted -> STM ()
forall a. STM a
STM.retry
                        ProgressEvent
KickStarted -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Async Any
asyncReporter <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async IO Any
lspShakeProgress
                Async Any -> IO ()
progressLoopReporting Async Any
asyncReporter
            progressLoopReporting :: Async Any -> IO ()
progressLoopReporting Async Any
asyncReporter = do
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    ProgressEvent
v <- TVar ProgressEvent -> STM ProgressEvent
forall a. TVar a -> STM a
readTVar TVar ProgressEvent
mostRecentProgressEvent
                    case ProgressEvent
v of
                        ProgressEvent
KickStarted -> STM ()
forall a. STM a
STM.retry
                        ProgressEvent
KickCompleted -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Async Any -> IO ()
forall a. Async a -> IO ()
cancel Async Any
asyncReporter
                IO ()
progressLoopIdle

            lspShakeProgress :: IO Any
lspShakeProgress = do
                -- first sleep a bit, so we only show progress messages if it's going to take
                -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
testing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
0.1
                LspId
lspId <- IO LspId
getLspId
                ProgressToken
u <- Text -> ProgressToken
ProgressTextToken (Text -> ProgressToken)
-> (Unique -> Text) -> Unique -> ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Unique -> String) -> Unique -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Unique -> Int) -> Unique -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique (Unique -> ProgressToken) -> IO Unique -> IO ProgressToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
                FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressCreateRequest -> FromServerMessage
LSP.ReqWorkDoneProgressCreate (WorkDoneProgressCreateRequest -> FromServerMessage)
-> WorkDoneProgressCreateRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
                  LspId
-> WorkDoneProgressCreateParams -> WorkDoneProgressCreateRequest
LSP.fmServerWorkDoneProgressCreateRequest LspId
lspId (WorkDoneProgressCreateParams -> WorkDoneProgressCreateRequest)
-> WorkDoneProgressCreateParams -> WorkDoneProgressCreateRequest
forall a b. (a -> b) -> a -> b
$
                    WorkDoneProgressCreateParams :: ProgressToken -> WorkDoneProgressCreateParams
LSP.WorkDoneProgressCreateParams { $sel:_token:WorkDoneProgressCreateParams :: ProgressToken
_token = ProgressToken
u }
                IO () -> IO () -> IO Any -> IO Any
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (ProgressToken -> IO ()
start ProgressToken
u) (ProgressToken -> IO ()
stop ProgressToken
u) (ProgressToken -> Maybe Text -> IO Any
loop ProgressToken
u Maybe Text
forall a. Maybe a
Nothing)
                where
                    start :: ProgressToken -> IO ()
start ProgressToken
id = FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressBeginNotification -> FromServerMessage
LSP.NotWorkDoneProgressBegin (WorkDoneProgressBeginNotification -> FromServerMessage)
-> WorkDoneProgressBeginNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
                      ProgressParams WorkDoneProgressBeginParams
-> WorkDoneProgressBeginNotification
LSP.fmServerWorkDoneProgressBeginNotification
                        ProgressParams :: forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams
                            { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                            , $sel:_value:ProgressParams :: WorkDoneProgressBeginParams
_value = WorkDoneProgressBeginParams :: Text
-> Maybe Bool
-> Maybe Text
-> Maybe Seconds
-> WorkDoneProgressBeginParams
WorkDoneProgressBeginParams
                              { $sel:_title:WorkDoneProgressBeginParams :: Text
_title = Text
"Processing"
                              , $sel:_cancellable:WorkDoneProgressBeginParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                              , $sel:_message:WorkDoneProgressBeginParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                              , $sel:_percentage:WorkDoneProgressBeginParams :: Maybe Seconds
_percentage = Maybe Seconds
forall a. Maybe a
Nothing
                              }
                            }
                    stop :: ProgressToken -> IO ()
stop ProgressToken
id = FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressEndNotification -> FromServerMessage
LSP.NotWorkDoneProgressEnd (WorkDoneProgressEndNotification -> FromServerMessage)
-> WorkDoneProgressEndNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
                      ProgressParams WorkDoneProgressEndParams
-> WorkDoneProgressEndNotification
LSP.fmServerWorkDoneProgressEndNotification
                        ProgressParams :: forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams
                            { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                            , $sel:_value:ProgressParams :: WorkDoneProgressEndParams
_value = WorkDoneProgressEndParams :: Maybe Text -> WorkDoneProgressEndParams
WorkDoneProgressEndParams
                              { $sel:_message:WorkDoneProgressEndParams :: Maybe Text
_message = Maybe Text
forall a. Maybe a
Nothing
                              }
                            }
                    sample :: Seconds
sample = Seconds
0.1
                    loop :: ProgressToken -> Maybe Text -> IO Any
loop ProgressToken
id Maybe Text
prev = do
                        Seconds -> IO ()
sleep Seconds
sample
                        HashMap NormalizedFilePath Int
current <- Var (HashMap NormalizedFilePath Int)
-> IO (HashMap NormalizedFilePath Int)
forall a. Var a -> IO a
readVar Var (HashMap NormalizedFilePath Int)
inProgress
                        let done :: Int
done = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath Int -> [Int]
forall k v. HashMap k v -> [v]
HMap.elems HashMap NormalizedFilePath Int
current
                        let todo :: Int
todo = HashMap NormalizedFilePath Int -> Int
forall k v. HashMap k v -> Int
HMap.size HashMap NormalizedFilePath Int
current
                        let next :: Maybe Text
next = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
done String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
todo
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text
next Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
prev) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressReportNotification -> FromServerMessage
LSP.NotWorkDoneProgressReport (WorkDoneProgressReportNotification -> FromServerMessage)
-> WorkDoneProgressReportNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
                              ProgressParams WorkDoneProgressReportParams
-> WorkDoneProgressReportNotification
LSP.fmServerWorkDoneProgressReportNotification
                                ProgressParams :: forall t. ProgressToken -> t -> ProgressParams t
LSP.ProgressParams
                                    { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                                    , $sel:_value:ProgressParams :: WorkDoneProgressReportParams
_value = WorkDoneProgressReportParams :: Maybe Bool
-> Maybe Text -> Maybe Seconds -> WorkDoneProgressReportParams
LSP.WorkDoneProgressReportParams
                                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = Maybe Bool
forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReportParams :: Maybe Text
_message = Maybe Text
next
                                    , $sel:_percentage:WorkDoneProgressReportParams :: Maybe Seconds
_percentage = Maybe Seconds
forall a. Maybe a
Nothing
                                    }
                                    }
                        ProgressToken -> Maybe Text -> IO Any
loop ProgressToken
id Maybe Text
next

shakeProfile :: IdeState -> FilePath -> IO ()
shakeProfile :: IdeState -> String -> IO ()
shakeProfile IdeState{Maybe String
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
stopProgressReporting :: IO ()
shakeProfileDir :: Maybe String
shakeExtras :: ShakeExtras
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
stopProgressReporting :: IdeState -> IO ()
shakeProfileDir :: IdeState -> Maybe String
shakeClose :: IdeState -> IO ()
shakeSession :: IdeState -> MVar ShakeSession
shakeDb :: IdeState -> ShakeDatabase
shakeExtras :: IdeState -> ShakeExtras
..} = ShakeDatabase -> String -> IO ()
shakeProfileDatabase ShakeDatabase
shakeDb

shakeShut :: IdeState -> IO ()
shakeShut :: IdeState -> IO ()
shakeShut IdeState{Maybe String
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
stopProgressReporting :: IO ()
shakeProfileDir :: Maybe String
shakeExtras :: ShakeExtras
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
stopProgressReporting :: IdeState -> IO ()
shakeProfileDir :: IdeState -> Maybe String
shakeClose :: IdeState -> IO ()
shakeSession :: IdeState -> MVar ShakeSession
shakeDb :: IdeState -> ShakeDatabase
shakeExtras :: IdeState -> ShakeExtras
..} = MVar ShakeSession -> (ShakeSession -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ShakeSession
shakeSession ((ShakeSession -> IO ()) -> IO ())
-> (ShakeSession -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ShakeSession
runner -> do
    -- Shake gets unhappy if you try to close when there is a running
    -- request so we first abort that.
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeSession -> IO ()
cancelShakeSession ShakeSession
runner
    IO ()
shakeClose
    IO ()
stopProgressReporting


-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
-- an exception, the previous value is restored while the second argument is executed masked.
withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' MVar a
var a -> IO b
unmasked b -> IO (a, c)
masked = ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
var
    b
b <- IO b -> IO b
forall a. IO a -> IO a
restore (a -> IO b
unmasked a
a) IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`onException` MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a
    (a
a', c
c) <- b -> IO (a, c)
masked b
b
    MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var a
a'
    c -> IO c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c


mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a
mkDelayedAction :: String -> Priority -> Action a -> DelayedAction a
mkDelayedAction = Maybe Unique -> String -> Priority -> Action a -> DelayedAction a
forall a.
Maybe Unique -> String -> Priority -> Action a -> DelayedAction a
DelayedAction Maybe Unique
forall a. Maybe a
Nothing

-- | These actions are run asynchronously after the current action is
-- finished running. For example, to trigger a key build after a rule
-- has already finished as is the case with useWithStaleFast
delayedAction :: DelayedAction a -> IdeAction (IO a)
delayedAction :: DelayedAction a -> IdeAction (IO a)
delayedAction DelayedAction a
a = do
  ShakeExtras
extras <- IdeAction ShakeExtras
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (IO a) -> IdeAction (IO a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO a) -> IdeAction (IO a)) -> IO (IO a) -> IdeAction (IO a)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> DelayedAction a -> IO (IO a)
forall a. ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras
extras DelayedAction a
a

-- | Restart the current 'ShakeSession' with the given system actions.
--   Any actions running in the current session will be aborted,
--   but actions added via 'shakeEnqueue' will be requeued.
shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()
shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()
shakeRestart IdeState{Maybe String
IO ()
MVar ShakeSession
ShakeDatabase
ShakeExtras
stopProgressReporting :: IO ()
shakeProfileDir :: Maybe String
shakeExtras :: ShakeExtras
shakeClose :: IO ()
shakeSession :: MVar ShakeSession
shakeDb :: ShakeDatabase
stopProgressReporting :: IdeState -> IO ()
shakeProfileDir :: IdeState -> Maybe String
shakeClose :: IdeState -> IO ()
shakeSession :: IdeState -> MVar ShakeSession
shakeDb :: IdeState -> ShakeDatabase
shakeExtras :: IdeState -> ShakeExtras
..} [DelayedAction ()]
acts =
    MVar ShakeSession
-> (ShakeSession -> IO ())
-> (() -> IO (ShakeSession, ()))
-> IO ()
forall a b c. MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar'
        MVar ShakeSession
shakeSession
        (\ShakeSession
runner -> do
              (Seconds
stopTime,()) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (ShakeSession -> IO ()
cancelShakeSession ShakeSession
runner)
              Maybe String
res <- Maybe String -> ShakeDatabase -> IO (Maybe String)
shakeDatabaseProfile Maybe String
shakeProfileDir ShakeDatabase
shakeDb
              let profile :: String
profile = case Maybe String
res of
                      Just String
fp -> String
", profile saved at " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fp
                      Maybe String
_ -> String
""
              let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Restarting build session (aborting the previous one took "
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
stopTime String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
profile String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              Logger -> Text -> IO ()
logDebug (ShakeExtras -> Logger
logger ShakeExtras
shakeExtras) Text
msg
              ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
shakeExtras Text
msg
        )
        -- It is crucial to be masked here, otherwise we can get killed
        -- between spawning the new thread and updating shakeSession.
        -- See https://github.com/digital-asset/ghcide/issues/79
        (\() -> do
          (,()) (ShakeSession -> (ShakeSession, ()))
-> IO ShakeSession -> IO (ShakeSession, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> IO ShakeSession
newSession ShakeExtras
shakeExtras ShakeDatabase
shakeDb [DelayedAction ()]
acts)

notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()
notifyTestingLogMessage :: ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg = do
    (IdeTesting Bool
isTestMode) <- IdeOptions -> IdeTesting
optTesting (IdeOptions -> IdeTesting) -> IO IdeOptions -> IO IdeTesting
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShakeExtras -> IO IdeOptions
getIdeOptionsIO ShakeExtras
extras
    let notif :: FromServerMessage
notif = LogMessageNotification -> FromServerMessage
LSP.NotLogMessage (LogMessageNotification -> FromServerMessage)
-> LogMessageNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text -> ServerMethod -> LogMessageParams -> LogMessageNotification
forall m a. Text -> m -> a -> NotificationMessage m a
LSP.NotificationMessage Text
"2.0" ServerMethod
LSP.WindowLogMessage
                                  (LogMessageParams -> LogMessageNotification)
-> LogMessageParams -> LogMessageNotification
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> LogMessageParams
LSP.LogMessageParams MessageType
LSP.MtLog Text
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTestMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> FromServerMessage -> IO ()
eventer ShakeExtras
extras FromServerMessage
notif


-- | Enqueue an action in the existing 'ShakeSession'.
--   Returns a computation to block until the action is run, propagating exceptions.
--   Assumes a 'ShakeSession' is available.
--
--   Appropriate for user actions other than edits.
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
shakeEnqueue ShakeExtras{ActionQueue
actionQueue :: ActionQueue
actionQueue :: ShakeExtras -> ActionQueue
actionQueue, Logger
logger :: Logger
logger :: ShakeExtras -> Logger
logger} DelayedAction a
act = do
    (Barrier (Either SomeException a)
b, DelayedAction ()
dai) <- DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedAction ())
forall a.
DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedAction ())
instantiateDelayedAction DelayedAction a
act
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedAction () -> ActionQueue -> STM ()
pushQueue DelayedAction ()
dai ActionQueue
actionQueue
    let wait' :: Barrier (Either SomeException a) -> IO (Either SomeException a)
wait' Barrier (Either SomeException a)
b =
            Barrier (Either SomeException a) -> IO (Either SomeException a)
forall a. Barrier a -> IO a
waitBarrier Barrier (Either SomeException a)
b IO (Either SomeException a)
-> [Handler (Either SomeException a)]
-> IO (Either SomeException a)
forall a. IO a -> [Handler a] -> IO a
`catches`
              [ (BlockedIndefinitelyOnMVar -> IO (Either SomeException a))
-> Handler (Either SomeException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler(\BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
                    String -> IO (Either SomeException a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Either SomeException a))
-> String -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ String
"internal bug: forever blocked on MVar for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                            DelayedAction a -> String
forall a. DelayedAction a -> String
actionName DelayedAction a
act)
              , (AsyncCancelled -> IO (Either SomeException a))
-> Handler (Either SomeException a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\e :: AsyncCancelled
e@AsyncCancelled
AsyncCancelled -> do
                  Logger -> Priority -> Text -> IO ()
logPriority Logger
logger Priority
Debug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DelayedAction a -> String
forall a. DelayedAction a -> String
actionName DelayedAction a
act String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" was cancelled"

                  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedAction () -> ActionQueue -> STM ()
abortQueue DelayedAction ()
dai ActionQueue
actionQueue
                  AsyncCancelled -> IO (Either SomeException a)
forall a e. Exception e => e -> a
throw AsyncCancelled
e)
              ]
    IO a -> IO (IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Barrier (Either SomeException a) -> IO (Either SomeException a)
wait' Barrier (Either SomeException a)
b IO (Either SomeException a)
-> (Either SomeException a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO a)
-> (a -> IO a) -> Either SomeException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return)

-- | Set up a new 'ShakeSession' with a set of initial actions
--   Will crash if there is an existing 'ShakeSession' running.
newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession
newSession :: ShakeExtras
-> ShakeDatabase -> [DelayedAction ()] -> IO ShakeSession
newSession extras :: ShakeExtras
extras@ShakeExtras{IORef NameCache
MVar ShakeSession
Var (HashMap TypeRep Dynamic)
Var Values
Var (HashMap NormalizedUri [Diagnostic])
Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
Var DiagnosticStore
Var (HashMap NormalizedFilePath Int)
Var (Hashed KnownTargets)
Var ExportsMap
Debouncer NormalizedUri
Logger
ActionQueue
IdeTesting
[DelayedAction ()] -> IO ()
FromServerMessage -> IO ()
ProgressEvent -> IO ()
forall a. Text -> ProgressCancellable -> IO a -> IO a
forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
actionQueue :: ActionQueue
exportsMap :: Var ExportsMap
knownTargetsVar :: Var (Hashed KnownTargets)
ideNc :: IORef NameCache
restartShakeSession :: [DelayedAction ()] -> IO ()
withIndefiniteProgress :: forall a. Text -> ProgressCancellable -> IO a -> IO a
withProgress :: forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
session :: MVar ShakeSession
ideTesting :: IdeTesting
progressUpdate :: ProgressEvent -> IO ()
inProgress :: Var (HashMap NormalizedFilePath Int)
positionMapping :: Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
hiddenDiagnostics :: Var DiagnosticStore
diagnostics :: Var DiagnosticStore
state :: Var Values
globals :: Var (HashMap TypeRep Dynamic)
logger :: Logger
debouncer :: Debouncer NormalizedUri
eventer :: FromServerMessage -> IO ()
actionQueue :: ShakeExtras -> ActionQueue
exportsMap :: ShakeExtras -> Var ExportsMap
knownTargetsVar :: ShakeExtras -> Var (Hashed KnownTargets)
ideNc :: ShakeExtras -> IORef NameCache
restartShakeSession :: ShakeExtras -> [DelayedAction ()] -> IO ()
withIndefiniteProgress :: ShakeExtras
-> forall a. Text -> ProgressCancellable -> IO a -> IO a
withProgress :: ShakeExtras
-> forall a.
   Text
   -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
session :: ShakeExtras -> MVar ShakeSession
ideTesting :: ShakeExtras -> IdeTesting
progressUpdate :: ShakeExtras -> ProgressEvent -> IO ()
inProgress :: ShakeExtras -> Var (HashMap NormalizedFilePath Int)
positionMapping :: ShakeExtras
-> Var
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
publishedDiagnostics :: ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
hiddenDiagnostics :: ShakeExtras -> Var DiagnosticStore
diagnostics :: ShakeExtras -> Var DiagnosticStore
state :: ShakeExtras -> Var Values
globals :: ShakeExtras -> Var (HashMap TypeRep Dynamic)
logger :: ShakeExtras -> Logger
debouncer :: ShakeExtras -> Debouncer NormalizedUri
eventer :: ShakeExtras -> FromServerMessage -> IO ()
..} ShakeDatabase
shakeDb [DelayedAction ()]
acts = do
    [DelayedAction ()]
reenqueued <- STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a. STM a -> IO a
atomically (STM [DelayedAction ()] -> IO [DelayedAction ()])
-> STM [DelayedAction ()] -> IO [DelayedAction ()]
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM [DelayedAction ()]
peekInProgress ActionQueue
actionQueue
    let
        -- A daemon-like action used to inject additional work
        -- Runs actions from the work queue sequentially
        pumpActionThread :: Action ()
pumpActionThread = do
            DelayedAction ()
d <- IO (DelayedAction ()) -> Action (DelayedAction ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DelayedAction ()) -> Action (DelayedAction ()))
-> IO (DelayedAction ()) -> Action (DelayedAction ())
forall a b. (a -> b) -> a -> b
$ STM (DelayedAction ()) -> IO (DelayedAction ())
forall a. STM a -> IO a
atomically (STM (DelayedAction ()) -> IO (DelayedAction ()))
-> STM (DelayedAction ()) -> IO (DelayedAction ())
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM (DelayedAction ())
popQueue ActionQueue
actionQueue
            Action [()] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [()] -> Action ()) -> Action [()] -> Action ()
forall a b. (a -> b) -> a -> b
$ [Action ()] -> Action [()]
forall a. [Action a] -> Action [a]
parallel [DelayedAction () -> Action ()
run DelayedAction ()
d, Action ()
pumpActionThread]

        run :: DelayedAction () -> Action ()
run DelayedAction ()
d  = do
            IO Seconds
start <- IO (IO Seconds) -> Action (IO Seconds)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
            DelayedAction () -> Action ()
forall a. DelayedAction a -> Action a
getAction DelayedAction ()
d
            IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DelayedAction () -> ActionQueue -> STM ()
doneQueue DelayedAction ()
d ActionQueue
actionQueue
            Seconds
runTime <- IO Seconds -> Action Seconds
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
start
            let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"finish: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DelayedAction () -> String
forall a. DelayedAction a -> String
actionName DelayedAction ()
d
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (took " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
runTime String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
            IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
                Logger -> Priority -> Text -> IO ()
logPriority Logger
logger (DelayedAction () -> Priority
forall a. DelayedAction a -> Priority
actionPriority DelayedAction ()
d) Text
msg
                ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg

        workRun :: (IO ([()], [IO ()]) -> IO ([()], [IO ()])) -> IO (IO ())
workRun IO ([()], [IO ()]) -> IO ([()], [IO ()])
restore = do
          let acts' :: [Action ()]
acts' = Action ()
pumpActionThread Action () -> [Action ()] -> [Action ()]
forall a. a -> [a] -> [a]
: (DelayedAction () -> Action ())
-> [DelayedAction ()] -> [Action ()]
forall a b. (a -> b) -> [a] -> [b]
map DelayedAction () -> Action ()
run ([DelayedAction ()]
reenqueued [DelayedAction ()] -> [DelayedAction ()] -> [DelayedAction ()]
forall a. [a] -> [a] -> [a]
++ [DelayedAction ()]
acts)
          Either SomeException ([()], [IO ()])
res <- IO ([()], [IO ()]) -> IO (Either SomeException ([()], [IO ()]))
forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO ([()], [IO ()]) -> IO ([()], [IO ()])
restore (IO ([()], [IO ()]) -> IO ([()], [IO ()]))
-> IO ([()], [IO ()]) -> IO ([()], [IO ()])
forall a b. (a -> b) -> a -> b
$ ShakeDatabase -> [Action ()] -> IO ([()], [IO ()])
forall a. ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
shakeRunDatabase ShakeDatabase
shakeDb [Action ()]
acts')
          let res' :: String
res' = case Either SomeException ([()], [IO ()])
res of
                      Left SomeException
e -> String
"exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
                      Right ([()], [IO ()])
_ -> String
"completed"
          let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Finishing build session(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
res' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
          IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
              Logger -> Text -> IO ()
logDebug Logger
logger Text
msg
              ShakeExtras -> Text -> IO ()
notifyTestingLogMessage ShakeExtras
extras Text
msg

    -- Do the work in a background thread
    Async (IO ())
workThread <- ((forall a. IO a -> IO a) -> IO (IO ())) -> IO (Async (IO ()))
forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (IO ([()], [IO ()]) -> IO ([()], [IO ()])) -> IO (IO ())
(forall a. IO a -> IO a) -> IO (IO ())
workRun

    -- run the wrap up in a separate thread since it contains interruptible
    -- commands (and we are not using uninterruptible mask)
    Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async (IO ()) -> IO (IO ())
forall a. Async a -> IO a
wait Async (IO ())
workThread

    --  Cancelling is required to flush the Shake database when either
    --  the filesystem or the Ghc configuration have changed
    let cancelShakeSession :: IO ()
        cancelShakeSession :: IO ()
cancelShakeSession = Async (IO ()) -> IO ()
forall a. Async a -> IO ()
cancel Async (IO ())
workThread

    ShakeSession -> IO ShakeSession
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeSession :: IO () -> ShakeSession
ShakeSession{IO ()
cancelShakeSession :: IO ()
cancelShakeSession :: IO ()
..})

instantiateDelayedAction
    :: DelayedAction a
    -> IO (Barrier (Either SomeException a), DelayedActionInternal)
instantiateDelayedAction :: DelayedAction a
-> IO (Barrier (Either SomeException a), DelayedAction ())
instantiateDelayedAction (DelayedAction Maybe Unique
_ String
s Priority
p Action a
a) = do
  Unique
u <- IO Unique
newUnique
  Barrier (Either SomeException a)
b <- IO (Barrier (Either SomeException a))
forall a. IO (Barrier a)
newBarrier
  let a' :: Action ()
a' = do
        -- work gets reenqueued when the Shake session is restarted
        -- it can happen that a work item finished just as it was reenqueud
        -- in that case, skipping the work is fine
        Bool
alreadyDone <- 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
$ Maybe (Either SomeException a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Either SomeException a) -> Bool)
-> IO (Maybe (Either SomeException a)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Barrier (Either SomeException a)
-> IO (Maybe (Either SomeException a))
forall a. Barrier a -> IO (Maybe a)
waitBarrierMaybe Barrier (Either SomeException a)
b
        Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyDone (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
          Either SomeException a
x <- Action (Either SomeException a)
-> (SomeException -> Action (Either SomeException a))
-> Action (Either SomeException a)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch @SomeException (a -> Either SomeException a
forall a b. b -> Either a b
Right (a -> Either SomeException a)
-> Action a -> Action (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action a
a) (Either SomeException a -> Action (Either SomeException a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException a -> Action (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> Action (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left)
          -- ignore exceptions if the barrier has been filled concurrently
          IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall a.
Exception SomeException =>
IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Barrier (Either SomeException a) -> Either SomeException a -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier (Either SomeException a)
b Either SomeException a
x
      d' :: DelayedAction ()
d' = Maybe Unique -> String -> Priority -> Action () -> DelayedAction ()
forall a.
Maybe Unique -> String -> Priority -> Action a -> DelayedAction a
DelayedAction (Unique -> Maybe Unique
forall a. a -> Maybe a
Just Unique
u) String
s Priority
p Action ()
a'
  (Barrier (Either SomeException a), DelayedAction ())
-> IO (Barrier (Either SomeException a), DelayedAction ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Barrier (Either SomeException a)
b, DelayedAction ()
d')

getDiagnostics :: IdeState -> IO [FileDiagnostic]
getDiagnostics :: IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState{shakeExtras :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var DiagnosticStore
diagnostics :: Var DiagnosticStore
diagnostics :: ShakeExtras -> Var DiagnosticStore
diagnostics}} = do
    DiagnosticStore
val <- Var DiagnosticStore -> IO DiagnosticStore
forall a. Var a -> IO a
readVar Var DiagnosticStore
diagnostics
    [FileDiagnostic] -> IO [FileDiagnostic]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic] -> IO [FileDiagnostic])
-> [FileDiagnostic] -> IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ DiagnosticStore -> [FileDiagnostic]
getAllDiagnostics DiagnosticStore
val

getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
getHiddenDiagnostics IdeState{shakeExtras :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
hiddenDiagnostics :: ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics}} = do
    DiagnosticStore
val <- Var DiagnosticStore -> IO DiagnosticStore
forall a. Var a -> IO a
readVar Var DiagnosticStore
hiddenDiagnostics
    [FileDiagnostic] -> IO [FileDiagnostic]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic] -> IO [FileDiagnostic])
-> [FileDiagnostic] -> IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ DiagnosticStore -> [FileDiagnostic]
getAllDiagnostics DiagnosticStore
val

-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
unsafeClearDiagnostics :: IdeState -> IO ()
unsafeClearDiagnostics :: IdeState -> IO ()
unsafeClearDiagnostics IdeState{shakeExtras :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var DiagnosticStore
diagnostics :: Var DiagnosticStore
diagnostics :: ShakeExtras -> Var DiagnosticStore
diagnostics}} =
    Var DiagnosticStore -> DiagnosticStore -> IO ()
forall a. Var a -> a -> IO ()
writeVar Var DiagnosticStore
diagnostics DiagnosticStore
forall a. Monoid a => a
mempty

-- | Clear the results for all files that do not match the given predicate.
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
garbageCollect NormalizedFilePath -> Bool
keep = do
    ShakeExtras{Var Values
state :: Var Values
state :: ShakeExtras -> Var Values
state, Var DiagnosticStore
diagnostics :: Var DiagnosticStore
diagnostics :: ShakeExtras -> Var DiagnosticStore
diagnostics,Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
hiddenDiagnostics :: ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics,Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics,Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: ShakeExtras
-> Var
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping} <- 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
$
        do Values
newState <- Var Values -> (Values -> IO (Values, Values)) -> IO Values
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Values
state ((Values -> IO (Values, Values)) -> IO Values)
-> (Values -> IO (Values, Values)) -> IO Values
forall a b. (a -> b) -> a -> b
$ \Values
values -> do
               Values
values <- Values -> IO Values
forall a. a -> IO a
evaluate (Values -> IO Values) -> Values -> IO Values
forall a b. (a -> b) -> a -> b
$ ((NormalizedFilePath, Key) -> Value Dynamic -> Bool)
-> Values -> Values
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\(NormalizedFilePath
file, Key
_) Value Dynamic
_ -> NormalizedFilePath -> Bool
keep NormalizedFilePath
file) Values
values
               (Values, Values) -> IO (Values, Values)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Values, Values) -> IO (Values, Values))
-> (Values, Values) -> IO (Values, Values)
forall a b. (a -> b) -> a -> b
$! Values -> (Values, Values)
forall a. a -> (a, a)
dupe Values
values
           Var DiagnosticStore
-> (DiagnosticStore -> IO DiagnosticStore) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var DiagnosticStore
diagnostics ((DiagnosticStore -> IO DiagnosticStore) -> IO ())
-> (DiagnosticStore -> IO DiagnosticStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DiagnosticStore
diags -> DiagnosticStore -> IO DiagnosticStore
forall (m :: * -> *) a. Monad m => a -> m a
return (DiagnosticStore -> IO DiagnosticStore)
-> DiagnosticStore -> IO DiagnosticStore
forall a b. (a -> b) -> a -> b
$! (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore
filterDiagnostics NormalizedFilePath -> Bool
keep DiagnosticStore
diags
           Var DiagnosticStore
-> (DiagnosticStore -> IO DiagnosticStore) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var DiagnosticStore
hiddenDiagnostics ((DiagnosticStore -> IO DiagnosticStore) -> IO ())
-> (DiagnosticStore -> IO DiagnosticStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DiagnosticStore
hdiags -> DiagnosticStore -> IO DiagnosticStore
forall (m :: * -> *) a. Monad m => a -> m a
return (DiagnosticStore -> IO DiagnosticStore)
-> DiagnosticStore -> IO DiagnosticStore
forall a b. (a -> b) -> a -> b
$! (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore
filterDiagnostics NormalizedFilePath -> Bool
keep DiagnosticStore
hdiags
           Var (HashMap NormalizedUri [Diagnostic])
-> (HashMap NormalizedUri [Diagnostic]
    -> IO (HashMap NormalizedUri [Diagnostic]))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics ((HashMap NormalizedUri [Diagnostic]
  -> IO (HashMap NormalizedUri [Diagnostic]))
 -> IO ())
-> (HashMap NormalizedUri [Diagnostic]
    -> IO (HashMap NormalizedUri [Diagnostic]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedUri [Diagnostic]
diags -> HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic])
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap NormalizedUri [Diagnostic]
 -> IO (HashMap NormalizedUri [Diagnostic]))
-> HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic])
forall a b. (a -> b) -> a -> b
$! (NormalizedUri -> [Diagnostic] -> Bool)
-> HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic]
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\NormalizedUri
uri [Diagnostic]
_ -> NormalizedFilePath -> Bool
keep (NormalizedUri -> NormalizedFilePath
fromUri NormalizedUri
uri)) HashMap NormalizedUri [Diagnostic]
diags
           let versionsForFile :: HashMap NormalizedUri (Set TextDocumentVersion)
versionsForFile =
                   (Set TextDocumentVersion
 -> Set TextDocumentVersion -> Set TextDocumentVersion)
-> [(NormalizedUri, Set TextDocumentVersion)]
-> HashMap NormalizedUri (Set TextDocumentVersion)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HMap.fromListWith Set TextDocumentVersion
-> Set TextDocumentVersion -> Set TextDocumentVersion
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(NormalizedUri, Set TextDocumentVersion)]
 -> HashMap NormalizedUri (Set TextDocumentVersion))
-> [(NormalizedUri, Set TextDocumentVersion)]
-> HashMap NormalizedUri (Set TextDocumentVersion)
forall a b. (a -> b) -> a -> b
$
                   (((NormalizedFilePath, Key), Value Dynamic)
 -> Maybe (NormalizedUri, Set TextDocumentVersion))
-> [((NormalizedFilePath, Key), Value Dynamic)]
-> [(NormalizedUri, Set TextDocumentVersion)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\((NormalizedFilePath
file, Key
_key), Value Dynamic
v) -> (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file,) (Set TextDocumentVersion
 -> (NormalizedUri, Set TextDocumentVersion))
-> (TextDocumentVersion -> Set TextDocumentVersion)
-> TextDocumentVersion
-> (NormalizedUri, Set TextDocumentVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextDocumentVersion -> Set TextDocumentVersion
forall a. a -> Set a
Set.singleton (TextDocumentVersion -> (NormalizedUri, Set TextDocumentVersion))
-> Maybe TextDocumentVersion
-> Maybe (NormalizedUri, Set TextDocumentVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value Dynamic -> Maybe TextDocumentVersion
forall v. Value v -> Maybe TextDocumentVersion
valueVersion Value Dynamic
v) ([((NormalizedFilePath, Key), Value Dynamic)]
 -> [(NormalizedUri, Set TextDocumentVersion)])
-> [((NormalizedFilePath, Key), Value Dynamic)]
-> [(NormalizedUri, Set TextDocumentVersion)]
forall a b. (a -> b) -> a -> b
$
                   Values -> [((NormalizedFilePath, Key), Value Dynamic)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Values
newState
           Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> (HashMap
      NormalizedUri
      (Map TextDocumentVersion (PositionDelta, PositionMapping))
    -> IO
         (HashMap
            NormalizedUri
            (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping ((HashMap
    NormalizedUri
    (Map TextDocumentVersion (PositionDelta, PositionMapping))
  -> IO
       (HashMap
          NormalizedUri
          (Map TextDocumentVersion (PositionDelta, PositionMapping))))
 -> IO ())
-> (HashMap
      NormalizedUri
      (Map TextDocumentVersion (PositionDelta, PositionMapping))
    -> IO
         (HashMap
            NormalizedUri
            (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
mappings -> HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap
   NormalizedUri
   (Map TextDocumentVersion (PositionDelta, PositionMapping))
 -> IO
      (HashMap
         NormalizedUri
         (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a b. (a -> b) -> a -> b
$! HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
forall a.
HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap HashMap NormalizedUri (Set TextDocumentVersion)
versionsForFile HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
mappings

-- | Define a new Rule without early cutoff
define
    :: IdeRule k v
    => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define :: (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define k -> NormalizedFilePath -> Action (IdeResult v)
op = (k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff ((k
  -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
 -> Rules ())
-> (k
    -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \k
k NormalizedFilePath
v -> (Maybe ByteString
forall a. Maybe a
Nothing,) (IdeResult v -> (Maybe ByteString, IdeResult v))
-> Action (IdeResult v) -> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> Action (IdeResult v)
op k
k NormalizedFilePath
v

-- | Request a Rule result if available
use :: IdeRule k v
    => k -> NormalizedFilePath -> Action (Maybe v)
use :: k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file = [Maybe v] -> Maybe v
forall a. [a] -> a
head ([Maybe v] -> Maybe v) -> Action [Maybe v] -> Action (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [Maybe v]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses k
key [NormalizedFilePath
file]

-- | Request a Rule result, it not available return the last computed result, if any, which may be stale
useWithStale :: IdeRule k v
    => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale :: k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale k
key NormalizedFilePath
file = [Maybe (v, PositionMapping)] -> Maybe (v, PositionMapping)
forall a. [a] -> a
head ([Maybe (v, PositionMapping)] -> Maybe (v, PositionMapping))
-> Action [Maybe (v, PositionMapping)]
-> Action (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale k
key [NormalizedFilePath
file]

-- | Request a Rule result, it not available return the last computed result which may be stale.
--   Errors out if none available.
useWithStale_ :: IdeRule k v
    => k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ :: k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ k
key NormalizedFilePath
file = [(v, PositionMapping)] -> (v, PositionMapping)
forall a. [a] -> a
head ([(v, PositionMapping)] -> (v, PositionMapping))
-> Action [(v, PositionMapping)] -> Action (v, PositionMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
usesWithStale_ k
key [NormalizedFilePath
file]

-- | Plural version of 'useWithStale_'
usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
usesWithStale_ :: k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
usesWithStale_ k
key [NormalizedFilePath]
files = do
    [Maybe (v, PositionMapping)]
res <- k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale k
key [NormalizedFilePath]
files
    case [Maybe (v, PositionMapping)] -> Maybe [(v, PositionMapping)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe (v, PositionMapping)]
res of
        Maybe [(v, PositionMapping)]
Nothing -> IO [(v, PositionMapping)] -> Action [(v, PositionMapping)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(v, PositionMapping)] -> Action [(v, PositionMapping)])
-> IO [(v, PositionMapping)] -> Action [(v, PositionMapping)]
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO [(v, PositionMapping)]
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO [(v, PositionMapping)])
-> BadDependency -> IO [(v, PositionMapping)]
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
key)
        Just [(v, PositionMapping)]
v -> [(v, PositionMapping)] -> Action [(v, PositionMapping)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(v, PositionMapping)]
v

newtype IdeAction a = IdeAction { IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT  :: (ReaderT ShakeExtras IO) a }
    deriving newtype (MonadReader ShakeExtras, Monad IdeAction
Monad IdeAction
-> (forall a. IO a -> IdeAction a) -> MonadIO IdeAction
IO a -> IdeAction a
forall a. IO a -> IdeAction a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> IdeAction a
$cliftIO :: forall a. IO a -> IdeAction a
$cp1MonadIO :: Monad IdeAction
MonadIO, a -> IdeAction b -> IdeAction a
(a -> b) -> IdeAction a -> IdeAction b
(forall a b. (a -> b) -> IdeAction a -> IdeAction b)
-> (forall a b. a -> IdeAction b -> IdeAction a)
-> Functor IdeAction
forall a b. a -> IdeAction b -> IdeAction a
forall a b. (a -> b) -> IdeAction a -> IdeAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IdeAction b -> IdeAction a
$c<$ :: forall a b. a -> IdeAction b -> IdeAction a
fmap :: (a -> b) -> IdeAction a -> IdeAction b
$cfmap :: forall a b. (a -> b) -> IdeAction a -> IdeAction b
Functor, Functor IdeAction
a -> IdeAction a
Functor IdeAction
-> (forall a. a -> IdeAction a)
-> (forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b)
-> (forall a b c.
    (a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction b)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction a)
-> Applicative IdeAction
IdeAction a -> IdeAction b -> IdeAction b
IdeAction a -> IdeAction b -> IdeAction a
IdeAction (a -> b) -> IdeAction a -> IdeAction b
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
forall a. a -> IdeAction a
forall a b. IdeAction a -> IdeAction b -> IdeAction a
forall a b. IdeAction a -> IdeAction b -> IdeAction b
forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: IdeAction a -> IdeAction b -> IdeAction a
$c<* :: forall a b. IdeAction a -> IdeAction b -> IdeAction a
*> :: IdeAction a -> IdeAction b -> IdeAction b
$c*> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
liftA2 :: (a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
$cliftA2 :: forall a b c.
(a -> b -> c) -> IdeAction a -> IdeAction b -> IdeAction c
<*> :: IdeAction (a -> b) -> IdeAction a -> IdeAction b
$c<*> :: forall a b. IdeAction (a -> b) -> IdeAction a -> IdeAction b
pure :: a -> IdeAction a
$cpure :: forall a. a -> IdeAction a
$cp1Applicative :: Functor IdeAction
Applicative, Applicative IdeAction
a -> IdeAction a
Applicative IdeAction
-> (forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b)
-> (forall a b. IdeAction a -> IdeAction b -> IdeAction b)
-> (forall a. a -> IdeAction a)
-> Monad IdeAction
IdeAction a -> (a -> IdeAction b) -> IdeAction b
IdeAction a -> IdeAction b -> IdeAction b
forall a. a -> IdeAction a
forall a b. IdeAction a -> IdeAction b -> IdeAction b
forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> IdeAction a
$creturn :: forall a. a -> IdeAction a
>> :: IdeAction a -> IdeAction b -> IdeAction b
$c>> :: forall a b. IdeAction a -> IdeAction b -> IdeAction b
>>= :: IdeAction a -> (a -> IdeAction b) -> IdeAction b
$c>>= :: forall a b. IdeAction a -> (a -> IdeAction b) -> IdeAction b
$cp1Monad :: Applicative IdeAction
Monad)

-- | IdeActions are used when we want to return a result immediately, even if it
-- is stale Useful for UI actions like hover, completion where we don't want to
-- block.
runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
_herald ShakeExtras
s IdeAction a
i = ReaderT ShakeExtras IO a -> ShakeExtras -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (IdeAction a -> ReaderT ShakeExtras IO a
forall a. IdeAction a -> ReaderT ShakeExtras IO a
runIdeActionT IdeAction a
i) ShakeExtras
s

askShake :: IdeAction ShakeExtras
askShake :: IdeAction ShakeExtras
askShake = IdeAction ShakeExtras
forall r (m :: * -> *). MonadReader r m => m r
ask

mkUpdater :: MaybeT IdeAction NameCacheUpdater
mkUpdater :: MaybeT IdeAction NameCacheUpdater
mkUpdater = do
  IORef NameCache
ref <- IdeAction (IORef NameCache) -> MaybeT IdeAction (IORef NameCache)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IdeAction (IORef NameCache) -> MaybeT IdeAction (IORef NameCache))
-> IdeAction (IORef NameCache)
-> MaybeT IdeAction (IORef NameCache)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IORef NameCache
ideNc (ShakeExtras -> IORef NameCache)
-> IdeAction ShakeExtras -> IdeAction (IORef NameCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdeAction ShakeExtras
askShake
  NameCacheUpdater -> MaybeT IdeAction NameCacheUpdater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameCacheUpdater -> MaybeT IdeAction NameCacheUpdater)
-> NameCacheUpdater -> MaybeT IdeAction NameCacheUpdater
forall a b. (a -> b) -> a -> b
$ (forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU (IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
upNameCache IORef NameCache
ref)

-- | A (maybe) stale result now, and an up to date one later
data FastResult a = FastResult { FastResult a -> Maybe (a, PositionMapping)
stale :: Maybe (a,PositionMapping), FastResult a -> IO (Maybe a)
uptoDate :: IO (Maybe a)  }

-- | Lookup value in the database and return with the stale value immediately
-- Will queue an action to refresh the value.
-- Might block the first time the rule runs, but never blocks after that.
useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast :: k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
useWithStaleFast k
key NormalizedFilePath
file = FastResult v -> Maybe (v, PositionMapping)
forall a. FastResult a -> Maybe (a, PositionMapping)
stale (FastResult v -> Maybe (v, PositionMapping))
-> IdeAction (FastResult v)
-> IdeAction (Maybe (v, PositionMapping))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> NormalizedFilePath -> IdeAction (FastResult v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file

-- | Same as useWithStaleFast but lets you wait for an up to date result
useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' :: k -> NormalizedFilePath -> IdeAction (FastResult v)
useWithStaleFast' k
key NormalizedFilePath
file = do
  -- This lookup directly looks up the key in the shake database and
  -- returns the last value that was computed for this key without
  -- checking freshness.

  -- Async trigger the key to be built anyway because we want to
  -- keep updating the value in the key.
  IO (Maybe v)
wait <- DelayedAction (Maybe v) -> IdeAction (IO (Maybe v))
forall a. DelayedAction a -> IdeAction (IO a)
delayedAction (DelayedAction (Maybe v) -> IdeAction (IO (Maybe v)))
-> DelayedAction (Maybe v) -> IdeAction (IO (Maybe v))
forall a b. (a -> b) -> a -> b
$ String -> Priority -> Action (Maybe v) -> DelayedAction (Maybe v)
forall a. String -> Priority -> Action a -> DelayedAction a
mkDelayedAction (String
"C:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
key) Priority
Debug (Action (Maybe v) -> DelayedAction (Maybe v))
-> Action (Maybe v) -> DelayedAction (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
file

  s :: ShakeExtras
s@ShakeExtras{Var Values
state :: Var Values
state :: ShakeExtras -> Var Values
state} <- IdeAction ShakeExtras
askShake
  Maybe (Value v)
r <- IO (Maybe (Value v)) -> IdeAction (Maybe (Value v))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v)) -> IdeAction (Maybe (Value v)))
-> IO (Maybe (Value v)) -> IdeAction (Maybe (Value v))
forall a b. (a -> b) -> a -> b
$ Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state k
key NormalizedFilePath
file
  IO (FastResult v) -> IdeAction (FastResult v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FastResult v) -> IdeAction (FastResult v))
-> IO (FastResult v) -> IdeAction (FastResult v)
forall a b. (a -> b) -> a -> b
$ case Maybe (Value v)
r of
    -- block for the result if we haven't computed before
    Maybe (Value v)
Nothing -> do
      Maybe v
a <- IO (Maybe v)
wait
      Maybe (Value v)
r <- Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state k
key NormalizedFilePath
file
      case Maybe (Value v)
r of
        Maybe (Value v)
Nothing -> FastResult v -> IO (FastResult v)
forall (m :: * -> *) a. Monad m => a -> m a
return (FastResult v -> IO (FastResult v))
-> FastResult v -> IO (FastResult v)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionMapping) -> IO (Maybe v) -> FastResult v
forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
forall a. Maybe a
Nothing (Maybe v -> IO (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
a)
        Just Value v
v -> do
          Maybe (v, PositionMapping)
res <- ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
forall v.
ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s NormalizedFilePath
file Value v
v
          FastResult v -> IO (FastResult v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastResult v -> IO (FastResult v))
-> FastResult v -> IO (FastResult v)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionMapping) -> IO (Maybe v) -> FastResult v
forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
res (Maybe v -> IO (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
a)
    -- Otherwise, use the computed value even if it's out of date.
    Just Value v
v -> do
      Maybe (v, PositionMapping)
res <- ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
forall v.
ShakeExtras
-> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
lastValueIO ShakeExtras
s NormalizedFilePath
file Value v
v
      FastResult v -> IO (FastResult v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastResult v -> IO (FastResult v))
-> FastResult v -> IO (FastResult v)
forall a b. (a -> b) -> a -> b
$ Maybe (v, PositionMapping) -> IO (Maybe v) -> FastResult v
forall a.
Maybe (a, PositionMapping) -> IO (Maybe a) -> FastResult a
FastResult Maybe (v, PositionMapping)
res IO (Maybe v)
wait

useNoFile :: IdeRule k v => k -> Action (Maybe v)
useNoFile :: k -> Action (Maybe v)
useNoFile k
key = k -> NormalizedFilePath -> Action (Maybe v)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
key NormalizedFilePath
emptyFilePath

use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
use_ :: k -> NormalizedFilePath -> Action v
use_ k
key NormalizedFilePath
file = [v] -> v
forall a. [a] -> a
head ([v] -> v) -> Action [v] -> Action v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> [NormalizedFilePath] -> Action [v]
forall k v. IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ k
key [NormalizedFilePath
file]

useNoFile_ :: IdeRule k v => k -> Action v
useNoFile_ :: k -> Action v
useNoFile_ k
key = k -> NormalizedFilePath -> Action v
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ k
key NormalizedFilePath
emptyFilePath

uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ :: k -> [NormalizedFilePath] -> Action [v]
uses_ k
key [NormalizedFilePath]
files = do
    [Maybe v]
res <- k -> [NormalizedFilePath] -> Action [Maybe v]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses k
key [NormalizedFilePath]
files
    case [Maybe v] -> Maybe [v]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe v]
res of
        Maybe [v]
Nothing -> IO [v] -> Action [v]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [v] -> Action [v]) -> IO [v] -> Action [v]
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO [v]
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO [v]) -> BadDependency -> IO [v]
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
key)
        Just [v]
v -> [v] -> Action [v]
forall (m :: * -> *) a. Monad m => a -> m a
return [v]
v


-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
--   which short-circuits the rest of the action
data BadDependency = BadDependency String deriving Int -> BadDependency -> ShowS
[BadDependency] -> ShowS
BadDependency -> String
(Int -> BadDependency -> ShowS)
-> (BadDependency -> String)
-> ([BadDependency] -> ShowS)
-> Show BadDependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadDependency] -> ShowS
$cshowList :: [BadDependency] -> ShowS
show :: BadDependency -> String
$cshow :: BadDependency -> String
showsPrec :: Int -> BadDependency -> ShowS
$cshowsPrec :: Int -> BadDependency -> ShowS
Show
instance Exception BadDependency

isBadDependency :: SomeException -> Bool
isBadDependency :: SomeException -> Bool
isBadDependency SomeException
x
    | Just (ShakeException
x :: ShakeException) <- SomeException -> Maybe ShakeException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x = SomeException -> Bool
isBadDependency (SomeException -> Bool) -> SomeException -> Bool
forall a b. (a -> b) -> a -> b
$ ShakeException -> SomeException
shakeExceptionInner ShakeException
x
    | Just (BadDependency
_ :: BadDependency) <- SomeException -> Maybe BadDependency
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x = Bool
True
    | Bool
otherwise = Bool
False

newtype Q k = Q (k, NormalizedFilePath)
    deriving newtype (Q k -> Q k -> Bool
(Q k -> Q k -> Bool) -> (Q k -> Q k -> Bool) -> Eq (Q k)
forall k. Eq k => Q k -> Q k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Q k -> Q k -> Bool
$c/= :: forall k. Eq k => Q k -> Q k -> Bool
== :: Q k -> Q k -> Bool
$c== :: forall k. Eq k => Q k -> Q k -> Bool
Eq, Int -> Q k -> Int
Q k -> Int
(Int -> Q k -> Int) -> (Q k -> Int) -> Hashable (Q k)
forall k. Hashable k => Int -> Q k -> Int
forall k. Hashable k => Q k -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Q k -> Int
$chash :: forall k. Hashable k => Q k -> Int
hashWithSalt :: Int -> Q k -> Int
$chashWithSalt :: forall k. Hashable k => Int -> Q k -> Int
Hashable, Q k -> ()
(Q k -> ()) -> NFData (Q k)
forall k. NFData k => Q k -> ()
forall a. (a -> ()) -> NFData a
rnf :: Q k -> ()
$crnf :: forall k. NFData k => Q k -> ()
NFData)

instance Binary k => Binary (Q k) where
    put :: Q k -> Put
put (Q (k
k, NormalizedFilePath
fp)) = (k, NormalizedFilePath) -> Put
forall t. Binary t => t -> Put
put (k
k, NormalizedFilePath
fp)
    get :: Get (Q k)
get = do
        (k
k, String
fp) <- Get (k, String)
forall t. Binary t => Get t
get
        -- The `get` implementation of NormalizedFilePath
        -- does not handle empty file paths so we
        -- need to handle this ourselves here.
        Q k -> Get (Q k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q (k
k, String -> NormalizedFilePath
toNormalizedFilePath' String
fp))

instance Show k => Show (Q k) where
    show :: Q k -> String
show (Q (k
k, NormalizedFilePath
file)) = k -> String
forall a. Show a => a -> String
show k
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file

-- | Invariant: the 'v' must be in normal form (fully evaluated).
--   Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
newtype A v = A (Value v)
    deriving Int -> A v -> ShowS
[A v] -> ShowS
A v -> String
(Int -> A v -> ShowS)
-> (A v -> String) -> ([A v] -> ShowS) -> Show (A v)
forall v. Show v => Int -> A v -> ShowS
forall v. Show v => [A v] -> ShowS
forall v. Show v => A v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [A v] -> ShowS
$cshowList :: forall v. Show v => [A v] -> ShowS
show :: A v -> String
$cshow :: forall v. Show v => A v -> String
showsPrec :: Int -> A v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> A v -> ShowS
Show

instance NFData (A v) where rnf :: A v -> ()
rnf (A Value v
v) = Value v
v Value v -> () -> ()
`seq` ()

-- In the Shake database we only store one type of key/result pairs,
-- namely Q (question) / A (answer).
type instance RuleResult (Q k) = A (RuleResult k)


-- | Plural version of 'use'
uses :: IdeRule k v
    => k -> [NormalizedFilePath] -> Action [Maybe v]
uses :: k -> [NormalizedFilePath] -> Action [Maybe v]
uses k
key [NormalizedFilePath]
files = (A v -> Maybe v) -> [A v] -> [Maybe v]
forall a b. (a -> b) -> [a] -> [b]
map (\(A Value v
value) -> Value v -> Maybe v
forall v. Value v -> Maybe v
currentValue Value v
value) ([A v] -> [Maybe v]) -> Action [A v] -> Action [Maybe v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q k] -> Action [A v]
forall key value.
(Partial, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
[key] -> Action [value]
apply ((NormalizedFilePath -> Q k) -> [NormalizedFilePath] -> [Q k]
forall a b. (a -> b) -> [a] -> [b]
map ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q ((k, NormalizedFilePath) -> Q k)
-> (NormalizedFilePath -> (k, NormalizedFilePath))
-> NormalizedFilePath
-> Q k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) [NormalizedFilePath]
files)

-- | Return the last computed result which might be stale.
usesWithStale :: IdeRule k v
    => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale :: k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale k
key [NormalizedFilePath]
files = do
    [Value v]
values <- (A v -> Value v) -> [A v] -> [Value v]
forall a b. (a -> b) -> [a] -> [b]
map (\(A Value v
value) -> Value v
value) ([A v] -> [Value v]) -> Action [A v] -> Action [Value v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q k] -> Action [A v]
forall key value.
(Partial, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
[key] -> Action [value]
apply ((NormalizedFilePath -> Q k) -> [NormalizedFilePath] -> [Q k]
forall a b. (a -> b) -> [a] -> [b]
map ((k, NormalizedFilePath) -> Q k
forall k. (k, NormalizedFilePath) -> Q k
Q ((k, NormalizedFilePath) -> Q k)
-> (NormalizedFilePath -> (k, NormalizedFilePath))
-> NormalizedFilePath
-> Q k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k
key,)) [NormalizedFilePath]
files)
    (NormalizedFilePath
 -> Value v -> Action (Maybe (v, PositionMapping)))
-> [NormalizedFilePath]
-> [Value v]
-> Action [Maybe (v, PositionMapping)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM NormalizedFilePath
-> Value v -> Action (Maybe (v, PositionMapping))
forall v.
NormalizedFilePath
-> Value v -> Action (Maybe (v, PositionMapping))
lastValue [NormalizedFilePath]
files [Value v]
values

-- | Define a new Rule with early cutoff
defineEarlyCutoff
    :: IdeRule k v
    => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
    -> Rules ()
defineEarlyCutoff :: (k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v)
op = BuiltinLint (Q k) (A v)
-> BuiltinIdentity (Q k) (A v)
-> BuiltinRun (Q k) (A v)
-> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
 NFData value, Show value, Partial) =>
BuiltinLint key value
-> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
addBuiltinRule BuiltinLint (Q k) (A v)
forall key value. BuiltinLint key value
noLint BuiltinIdentity (Q k) (A v)
forall key value. BuiltinIdentity key value
noIdentity (BuiltinRun (Q k) (A v) -> Rules ())
-> BuiltinRun (Q k) (A v) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Q (k
key, NormalizedFilePath
file)) (Maybe ByteString
old :: Maybe BS.ByteString) RunMode
mode -> do
    extras :: ShakeExtras
extras@ShakeExtras{Var Values
state :: Var Values
state :: ShakeExtras -> Var Values
state, Var (HashMap NormalizedFilePath Int)
inProgress :: Var (HashMap NormalizedFilePath Int)
inProgress :: ShakeExtras -> Var (HashMap NormalizedFilePath Int)
inProgress} <- Action ShakeExtras
getShakeExtras
    -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
    (if k -> String
forall a. Show a => a -> String
show k
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GetFileExists" then Action (RunResult (A v)) -> Action (RunResult (A v))
forall a. a -> a
id else Var (HashMap NormalizedFilePath Int)
-> NormalizedFilePath
-> Action (RunResult (A v))
-> Action (RunResult (A v))
forall a b.
(Eq a, Hashable a) =>
Var (HashMap a Int) -> a -> Action b -> Action b
withProgressVar Var (HashMap NormalizedFilePath Int)
inProgress NormalizedFilePath
file) (Action (RunResult (A v)) -> Action (RunResult (A v)))
-> Action (RunResult (A v)) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ do
        Maybe (RunResult (A v))
val <- case Maybe ByteString
old of
            Just ByteString
old | RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame -> do
                Maybe (Value v)
v <- IO (Maybe (Value v)) -> Action (Maybe (Value v))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v)) -> Action (Maybe (Value v)))
-> IO (Maybe (Value v)) -> Action (Maybe (Value v))
forall a b. (a -> b) -> a -> b
$ Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state k
key NormalizedFilePath
file
                case Maybe (Value v)
v of
                    -- No changes in the dependencies and we have
                    -- an existing result.
                    Just Value v
v -> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v))))
-> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall a b. (a -> b) -> a -> b
$ RunResult (A v) -> Maybe (RunResult (A v))
forall a. a -> Maybe a
Just (RunResult (A v) -> Maybe (RunResult (A v)))
-> RunResult (A v) -> Maybe (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> A v -> RunResult (A v)
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old (A v -> RunResult (A v)) -> A v -> RunResult (A v)
forall a b. (a -> b) -> a -> b
$ Value v -> A v
forall v. Value v -> A v
A Value v
v
                    Maybe (Value v)
_ -> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RunResult (A v))
forall a. Maybe a
Nothing
            Maybe ByteString
_ -> Maybe (RunResult (A v)) -> Action (Maybe (RunResult (A v)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RunResult (A v))
forall a. Maybe a
Nothing
        case Maybe (RunResult (A v))
val of
            Just RunResult (A v)
res -> RunResult (A v) -> Action (RunResult (A v))
forall (m :: * -> *) a. Monad m => a -> m a
return RunResult (A v)
res
            Maybe (RunResult (A v))
Nothing -> do
                (Maybe ByteString
bs, ([FileDiagnostic]
diags, Maybe v
res)) <- Action (Maybe ByteString, IdeResult v)
-> (SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch
                    (do (Maybe ByteString, IdeResult v)
v <- k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v)
op k
key NormalizedFilePath
file; IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString, IdeResult v)
 -> Action (Maybe ByteString, IdeResult v))
-> IO (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v)
forall a. a -> IO a
evaluate ((Maybe ByteString, IdeResult v)
 -> IO (Maybe ByteString, IdeResult v))
-> (Maybe ByteString, IdeResult v)
-> IO (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$ (Maybe ByteString, IdeResult v) -> (Maybe ByteString, IdeResult v)
forall a. NFData a => a -> a
force (Maybe ByteString, IdeResult v)
v) ((SomeException -> Action (Maybe ByteString, IdeResult v))
 -> Action (Maybe ByteString, IdeResult v))
-> (SomeException -> Action (Maybe ByteString, IdeResult v))
-> Action (Maybe ByteString, IdeResult v)
forall a b. (a -> b) -> a -> b
$
                    \(SomeException
e :: SomeException) -> (Maybe ByteString, IdeResult v)
-> Action (Maybe ByteString, IdeResult v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, ([NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isBadDependency SomeException
e],Maybe v
forall a. Maybe a
Nothing))
                Maybe FileVersion
modTime <- IO (Maybe FileVersion) -> Action (Maybe FileVersion)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FileVersion) -> Action (Maybe FileVersion))
-> IO (Maybe FileVersion) -> Action (Maybe FileVersion)
forall a b. (a -> b) -> a -> b
$ (Value FileVersion -> Maybe FileVersion
forall v. Value v -> Maybe v
currentValue (Value FileVersion -> Maybe FileVersion)
-> Maybe (Value FileVersion) -> Maybe FileVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe (Value FileVersion) -> Maybe FileVersion)
-> IO (Maybe (Value FileVersion)) -> IO (Maybe FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var Values
-> GetModificationTime
-> NormalizedFilePath
-> IO (Maybe (Value FileVersion))
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state GetModificationTime
GetModificationTime NormalizedFilePath
file
                (ShakeValue
bs, Value v
res) <- case Maybe v
res of
                    Maybe v
Nothing -> do
                        Maybe (Value v)
staleV <- IO (Maybe (Value v)) -> Action (Maybe (Value v))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Value v)) -> Action (Maybe (Value v)))
-> IO (Maybe (Value v)) -> Action (Maybe (Value v))
forall a b. (a -> b) -> a -> b
$ Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state k
key NormalizedFilePath
file
                        (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ShakeValue, Value v) -> Action (ShakeValue, Value v))
-> (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall a b. (a -> b) -> a -> b
$ case Maybe (Value v)
staleV of
                            Maybe (Value v)
Nothing -> ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, Value v
forall v. Value v
Failed)
                            Just Value v
v -> case Value v
v of
                                Succeeded TextDocumentVersion
ver v
v -> ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeStale Maybe ByteString
bs, TextDocumentVersion -> v -> Value v
forall v. TextDocumentVersion -> v -> Value v
Stale TextDocumentVersion
ver v
v)
                                Stale TextDocumentVersion
ver v
v -> ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeStale Maybe ByteString
bs, TextDocumentVersion -> v -> Value v
forall v. TextDocumentVersion -> v -> Value v
Stale TextDocumentVersion
ver v
v)
                                Value v
Failed -> ((ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, Value v
forall v. Value v
Failed)
                    Just v
v -> (ShakeValue, Value v) -> Action (ShakeValue, Value v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeValue
-> (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShakeValue
ShakeNoCutoff ByteString -> ShakeValue
ShakeResult Maybe ByteString
bs, TextDocumentVersion -> v -> Value v
forall v. TextDocumentVersion -> v -> Value v
Succeeded (FileVersion -> TextDocumentVersion
vfsVersion (FileVersion -> TextDocumentVersion)
-> Maybe FileVersion -> TextDocumentVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
modTime) v
v)
                IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Var Values -> k -> NormalizedFilePath -> Value v -> IO ()
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> Value v -> IO ()
setValues Var Values
state k
key NormalizedFilePath
file Value v
res
                NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> [(ShowDiagnostic, Diagnostic)] -> Action ()
forall a b. (a -> b) -> a -> b
$ (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) [FileDiagnostic]
diags
                let eq :: Bool
eq = case (ShakeValue
bs, (ByteString -> ShakeValue) -> Maybe ByteString -> Maybe ShakeValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ShakeValue
decodeShakeValue Maybe ByteString
old) of
                        (ShakeResult ByteString
a, Just (ShakeResult ByteString
b)) -> ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
b
                        (ShakeStale ByteString
a, Just (ShakeStale ByteString
b)) -> ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
b
                        -- If we do not have a previous result
                        -- or we got ShakeNoCutoff we always return False.
                        (ShakeValue, Maybe ShakeValue)
_ -> Bool
False
                RunResult (A v) -> Action (RunResult (A v))
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult (A v) -> Action (RunResult (A v)))
-> RunResult (A v) -> Action (RunResult (A v))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> A v -> RunResult (A v)
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult
                    (if Bool
eq then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff)
                    (ShakeValue -> ByteString
encodeShakeValue ShakeValue
bs) (A v -> RunResult (A v)) -> A v -> RunResult (A v)
forall a b. (a -> b) -> a -> b
$
                    Value v -> A v
forall v. Value v -> A v
A Value v
res
  where
    withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
    withProgressVar :: Var (HashMap a Int) -> a -> Action b -> Action b
withProgressVar Var (HashMap a Int)
var a
file = IO () -> (() -> IO ()) -> (() -> Action b) -> Action b
forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket ((Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
succ) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
pred) ((() -> Action b) -> Action b)
-> (Action b -> () -> Action b) -> Action b -> Action b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action b -> () -> Action b
forall a b. a -> b -> a
const
        -- This functions are deliberately eta-expanded to avoid space leaks.
        -- Do not remove the eta-expansion without profiling a session with at
        -- least 1000 modifications.
        where f :: (Int -> Int) -> IO ()
f Int -> Int
shift = Var (HashMap a Int)
-> (HashMap a Int -> IO (HashMap a Int)) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap a Int)
var ((HashMap a Int -> IO (HashMap a Int)) -> IO ())
-> (HashMap a Int -> IO (HashMap a Int)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap a Int
x -> HashMap a Int -> IO (HashMap a Int)
forall a. a -> IO a
evaluate (HashMap a Int -> IO (HashMap a Int))
-> HashMap a Int -> IO (HashMap a Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> a -> Int -> HashMap a Int -> HashMap a Int
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HMap.insertWith (\Int
_ Int
x -> Int -> Int
shift Int
x) a
file (Int -> Int
shift Int
0) HashMap a Int
x




-- | Rule type, input file
data QDisk k = QDisk k NormalizedFilePath
  deriving (QDisk k -> QDisk k -> Bool
(QDisk k -> QDisk k -> Bool)
-> (QDisk k -> QDisk k -> Bool) -> Eq (QDisk k)
forall k. Eq k => QDisk k -> QDisk k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QDisk k -> QDisk k -> Bool
$c/= :: forall k. Eq k => QDisk k -> QDisk k -> Bool
== :: QDisk k -> QDisk k -> Bool
$c== :: forall k. Eq k => QDisk k -> QDisk k -> Bool
Eq, (forall x. QDisk k -> Rep (QDisk k) x)
-> (forall x. Rep (QDisk k) x -> QDisk k) -> Generic (QDisk k)
forall x. Rep (QDisk k) x -> QDisk k
forall x. QDisk k -> Rep (QDisk k) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k x. Rep (QDisk k) x -> QDisk k
forall k x. QDisk k -> Rep (QDisk k) x
$cto :: forall k x. Rep (QDisk k) x -> QDisk k
$cfrom :: forall k x. QDisk k -> Rep (QDisk k) x
Generic)

instance Hashable k => Hashable (QDisk k)

instance NFData k => NFData (QDisk k)

instance Binary k => Binary (QDisk k)

instance Show k => Show (QDisk k) where
    show :: QDisk k -> String
show (QDisk k
k NormalizedFilePath
file) =
        k -> String
forall a. Show a => a -> String
show k
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file

type instance RuleResult (QDisk k) = Bool

data OnDiskRule = OnDiskRule
  { OnDiskRule -> Action ByteString
getHash :: Action BS.ByteString
  -- This is used to figure out if the state on disk corresponds to the state in the Shake
  -- database and we can therefore avoid rerunning. Often this can just be the file hash but
  -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which
  -- is more stable than the hash of the interface file.
  -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.
  -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.
  , OnDiskRule -> Action (IdeResult ByteString)
runRule :: Action (IdeResult BS.ByteString)
  -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.
  }

-- This is used by the DAML compiler for incremental builds. Right now this is not used by
-- ghcide itself but that might change in the future.
-- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on
-- the internals of this module that we do not want to expose.
defineOnDisk
  :: (Shake.ShakeValue k, RuleResult k ~ ())
  => (k -> NormalizedFilePath -> OnDiskRule)
  -> Rules ()
defineOnDisk :: (k -> NormalizedFilePath -> OnDiskRule) -> Rules ()
defineOnDisk k -> NormalizedFilePath -> OnDiskRule
act = BuiltinLint (QDisk k) Bool
-> BuiltinIdentity (QDisk k) Bool
-> BuiltinRun (QDisk k) Bool
-> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
 NFData value, Show value, Partial) =>
BuiltinLint key value
-> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
addBuiltinRule BuiltinLint (QDisk k) Bool
forall key value. BuiltinLint key value
noLint BuiltinIdentity (QDisk k) Bool
forall key value. BuiltinIdentity key value
noIdentity (BuiltinRun (QDisk k) Bool -> Rules ())
-> BuiltinRun (QDisk k) Bool -> Rules ()
forall a b. (a -> b) -> a -> b
$
  \(QDisk k
key NormalizedFilePath
file) (Maybe ByteString
mbOld :: Maybe BS.ByteString) RunMode
mode -> do
      ShakeExtras
extras <- Action ShakeExtras
getShakeExtras
      let OnDiskRule{Action (IdeResult ByteString)
Action ByteString
runRule :: Action (IdeResult ByteString)
getHash :: Action ByteString
runRule :: OnDiskRule -> Action (IdeResult ByteString)
getHash :: OnDiskRule -> Action ByteString
..} = k -> NormalizedFilePath -> OnDiskRule
act k
key NormalizedFilePath
file
      let validateHash :: ByteString -> Maybe ByteString
validateHash ByteString
h
              | ByteString -> Bool
BS.null ByteString
h = Maybe ByteString
forall a. Maybe a
Nothing
              | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
h
      let runAct :: Action (IdeResult ByteString)
runAct = Action (IdeResult ByteString)
-> (SomeException -> Action (IdeResult ByteString))
-> Action (IdeResult ByteString)
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch Action (IdeResult ByteString)
runRule ((SomeException -> Action (IdeResult ByteString))
 -> Action (IdeResult ByteString))
-> (SomeException -> Action (IdeResult ByteString))
-> Action (IdeResult ByteString)
forall a b. (a -> b) -> a -> b
$
              \(SomeException
e :: SomeException) -> IdeResult ByteString -> Action (IdeResult ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText NormalizedFilePath
file (Text -> FileDiagnostic) -> Text -> FileDiagnostic
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
isBadDependency SomeException
e], Maybe ByteString
forall a. Maybe a
Nothing)
      case Maybe ByteString
mbOld of
          Maybe ByteString
Nothing -> do
              ([FileDiagnostic]
diags, Maybe ByteString
mbHash) <- Action (IdeResult ByteString)
runAct
              NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> [(ShowDiagnostic, Diagnostic)] -> Action ()
forall a b. (a -> b) -> a -> b
$ (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) [FileDiagnostic]
diags
              RunResult Bool -> Action (RunResult Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Bool -> Action (RunResult Bool))
-> RunResult Bool -> Action (RunResult Bool)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Bool -> RunResult Bool
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedRecomputeDiff (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbHash) (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mbHash)
          Just ByteString
old -> do
              Maybe ByteString
current <- ByteString -> Maybe ByteString
validateHash (ByteString -> Maybe ByteString)
-> Action ByteString -> Action (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Action ByteString
-> (SomeException -> Action ByteString) -> Action ByteString
forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch Action ByteString
getHash ((SomeException -> Action ByteString) -> Action ByteString)
-> (SomeException -> Action ByteString) -> Action ByteString
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) -> ByteString -> Action ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"")
              if RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame Bool -> Bool -> Bool
&& ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
old Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
current Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
old)
                  then
                    -- None of our dependencies changed, we’ve had a successful run before and
                    -- the state on disk matches the state in the Shake database.
                    RunResult Bool -> Action (RunResult Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Bool -> Action (RunResult Bool))
-> RunResult Bool -> Action (RunResult Bool)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Bool -> RunResult Bool
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
current) (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
current)
                  else do
                    ([FileDiagnostic]
diags, Maybe ByteString
mbHash) <- Action (IdeResult ByteString)
runAct
                    NormalizedFilePath
-> Key
-> ShakeExtras
-> [(ShowDiagnostic, Diagnostic)]
-> Action ()
forall (m :: * -> *).
MonadIO m =>
NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
file (k -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key k
key) ShakeExtras
extras ([(ShowDiagnostic, Diagnostic)] -> Action ())
-> [(ShowDiagnostic, Diagnostic)] -> Action ()
forall a b. (a -> b) -> a -> b
$ (FileDiagnostic -> (ShowDiagnostic, Diagnostic))
-> [FileDiagnostic] -> [(ShowDiagnostic, Diagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map (\(NormalizedFilePath
_,ShowDiagnostic
y,Diagnostic
z) -> (ShowDiagnostic
y,Diagnostic
z)) [FileDiagnostic]
diags
                    let change :: RunChanged
change
                          | Maybe ByteString
mbHash Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
old = RunChanged
ChangedRecomputeSame
                          | Bool
otherwise = RunChanged
ChangedRecomputeDiff
                    RunResult Bool -> Action (RunResult Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Bool -> Action (RunResult Bool))
-> RunResult Bool -> Action (RunResult Bool)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Bool -> RunResult Bool
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
change (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbHash) (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mbHash)

needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
needOnDisk :: k -> NormalizedFilePath -> Action ()
needOnDisk k
k NormalizedFilePath
file = do
    Bool
successfull <- QDisk k -> Action Bool
forall key value.
(Partial, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
key -> Action value
apply1 (k -> NormalizedFilePath -> QDisk k
forall k. k -> NormalizedFilePath -> QDisk k
QDisk k
k NormalizedFilePath
file)
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
successfull (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO ()
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO ()) -> BadDependency -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
k)

needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
needOnDisks :: k -> [NormalizedFilePath] -> Action ()
needOnDisks k
k [NormalizedFilePath]
files = do
    [Bool]
successfulls <- [QDisk k] -> Action [Bool]
forall key value.
(Partial, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
[key] -> Action [value]
apply ([QDisk k] -> Action [Bool]) -> [QDisk k] -> Action [Bool]
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> QDisk k)
-> [NormalizedFilePath] -> [QDisk k]
forall a b. (a -> b) -> [a] -> [b]
map (k -> NormalizedFilePath -> QDisk k
forall k. k -> NormalizedFilePath -> QDisk k
QDisk k
k) [NormalizedFilePath]
files
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
successfulls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BadDependency -> IO ()
forall e a. Exception e => e -> IO a
throwIO (BadDependency -> IO ()) -> BadDependency -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> BadDependency
BadDependency (k -> String
forall a. Show a => a -> String
show k
k)

toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
toShakeValue :: (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
toShakeValue = ShakeValue
-> (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShakeValue
ShakeNoCutoff

data ShakeValue
    = ShakeNoCutoff
    -- ^ This is what we use when we get Nothing from
    -- a rule.
    | ShakeResult !BS.ByteString
    -- ^ This is used both for `Failed`
    -- as well as `Succeeded`.
    | ShakeStale !BS.ByteString
    deriving ((forall x. ShakeValue -> Rep ShakeValue x)
-> (forall x. Rep ShakeValue x -> ShakeValue) -> Generic ShakeValue
forall x. Rep ShakeValue x -> ShakeValue
forall x. ShakeValue -> Rep ShakeValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShakeValue x -> ShakeValue
$cfrom :: forall x. ShakeValue -> Rep ShakeValue x
Generic, Int -> ShakeValue -> ShowS
[ShakeValue] -> ShowS
ShakeValue -> String
(Int -> ShakeValue -> ShowS)
-> (ShakeValue -> String)
-> ([ShakeValue] -> ShowS)
-> Show ShakeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShakeValue] -> ShowS
$cshowList :: [ShakeValue] -> ShowS
show :: ShakeValue -> String
$cshow :: ShakeValue -> String
showsPrec :: Int -> ShakeValue -> ShowS
$cshowsPrec :: Int -> ShakeValue -> ShowS
Show)

instance NFData ShakeValue

encodeShakeValue :: ShakeValue -> BS.ByteString
encodeShakeValue :: ShakeValue -> ByteString
encodeShakeValue = \case
    ShakeValue
ShakeNoCutoff -> ByteString
BS.empty
    ShakeResult ByteString
r -> Char -> ByteString -> ByteString
BS.cons Char
'r' ByteString
r
    ShakeStale ByteString
r -> Char -> ByteString -> ByteString
BS.cons Char
's' ByteString
r

decodeShakeValue :: BS.ByteString -> ShakeValue
decodeShakeValue :: ByteString -> ShakeValue
decodeShakeValue ByteString
bs = case ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
bs of
    Maybe (Char, ByteString)
Nothing -> ShakeValue
ShakeNoCutoff
    Just (Char
x, ByteString
xs)
      | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'r' -> ByteString -> ShakeValue
ShakeResult ByteString
xs
      | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
's' -> ByteString -> ShakeValue
ShakeStale ByteString
xs
      | Bool
otherwise -> String -> ShakeValue
forall a. Partial => String -> a
error (String -> ShakeValue) -> String -> ShakeValue
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse shake value " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs


updateFileDiagnostics :: MonadIO m
  => NormalizedFilePath
  -> Key
  -> ShakeExtras
  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
  -> m ()
updateFileDiagnostics :: NormalizedFilePath
-> Key -> ShakeExtras -> [(ShowDiagnostic, Diagnostic)] -> m ()
updateFileDiagnostics NormalizedFilePath
fp Key
k ShakeExtras{Var DiagnosticStore
diagnostics :: Var DiagnosticStore
diagnostics :: ShakeExtras -> Var DiagnosticStore
diagnostics, Var DiagnosticStore
hiddenDiagnostics :: Var DiagnosticStore
hiddenDiagnostics :: ShakeExtras -> Var DiagnosticStore
hiddenDiagnostics, Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics :: ShakeExtras -> Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics, Var Values
state :: Var Values
state :: ShakeExtras -> Var Values
state, Debouncer NormalizedUri
debouncer :: Debouncer NormalizedUri
debouncer :: ShakeExtras -> Debouncer NormalizedUri
debouncer, FromServerMessage -> IO ()
eventer :: FromServerMessage -> IO ()
eventer :: ShakeExtras -> FromServerMessage -> IO ()
eventer} [(ShowDiagnostic, Diagnostic)]
current = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe FileVersion
modTime <- (Value FileVersion -> Maybe FileVersion
forall v. Value v -> Maybe v
currentValue (Value FileVersion -> Maybe FileVersion)
-> Maybe (Value FileVersion) -> Maybe FileVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe (Value FileVersion) -> Maybe FileVersion)
-> IO (Maybe (Value FileVersion)) -> IO (Maybe FileVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var Values
-> GetModificationTime
-> NormalizedFilePath
-> IO (Maybe (Value FileVersion))
forall k v.
IdeRule k v =>
Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues Var Values
state GetModificationTime
GetModificationTime NormalizedFilePath
fp
    let ([(ShowDiagnostic, Diagnostic)]
currentShown, [(ShowDiagnostic, Diagnostic)]
currentHidden) = ((ShowDiagnostic, Diagnostic) -> Bool)
-> [(ShowDiagnostic, Diagnostic)]
-> ([(ShowDiagnostic, Diagnostic)], [(ShowDiagnostic, Diagnostic)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ShowDiagnostic -> ShowDiagnostic -> Bool
forall a. Eq a => a -> a -> Bool
== ShowDiagnostic
ShowDiag) (ShowDiagnostic -> Bool)
-> ((ShowDiagnostic, Diagnostic) -> ShowDiagnostic)
-> (ShowDiagnostic, Diagnostic)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowDiagnostic, Diagnostic) -> ShowDiagnostic
forall a b. (a, b) -> a
fst) [(ShowDiagnostic, Diagnostic)]
current
    IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- Mask async exceptions to ensure that updated diagnostics are always
        -- published. Otherwise, we might never publish certain diagnostics if
        -- an exception strikes between modifyVar but before
        -- publishDiagnosticsNotification.
        [Diagnostic]
newDiags <- Var DiagnosticStore
-> (DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic]
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var DiagnosticStore
diagnostics ((DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
 -> IO [Diagnostic])
-> (DiagnosticStore -> IO (DiagnosticStore, [Diagnostic]))
-> IO [Diagnostic]
forall a b. (a -> b) -> a -> b
$ \DiagnosticStore
old -> do
            let newDiagsStore :: DiagnosticStore
newDiagsStore = NormalizedFilePath
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics NormalizedFilePath
fp (FileVersion -> TextDocumentVersion
vfsVersion (FileVersion -> TextDocumentVersion)
-> Maybe FileVersion -> TextDocumentVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
modTime)
                                  (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k) (((ShowDiagnostic, Diagnostic) -> Diagnostic)
-> [(ShowDiagnostic, Diagnostic)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (ShowDiagnostic, Diagnostic) -> Diagnostic
forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentShown) DiagnosticStore
old
            let newDiags :: [Diagnostic]
newDiags = NormalizedFilePath -> DiagnosticStore -> [Diagnostic]
getFileDiagnostics NormalizedFilePath
fp DiagnosticStore
newDiagsStore
            DiagnosticStore
_ <- DiagnosticStore -> IO DiagnosticStore
forall a. a -> IO a
evaluate DiagnosticStore
newDiagsStore
            [Diagnostic]
_ <- [Diagnostic] -> IO [Diagnostic]
forall a. a -> IO a
evaluate [Diagnostic]
newDiags
            (DiagnosticStore, [Diagnostic])
-> IO (DiagnosticStore, [Diagnostic])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiagnosticStore
newDiagsStore, [Diagnostic]
newDiags)
        Var DiagnosticStore
-> (DiagnosticStore -> IO DiagnosticStore) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var DiagnosticStore
hiddenDiagnostics ((DiagnosticStore -> IO DiagnosticStore) -> IO ())
-> (DiagnosticStore -> IO DiagnosticStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DiagnosticStore
old -> do
            let newDiagsStore :: DiagnosticStore
newDiagsStore = NormalizedFilePath
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics NormalizedFilePath
fp (FileVersion -> TextDocumentVersion
vfsVersion (FileVersion -> TextDocumentVersion)
-> Maybe FileVersion -> TextDocumentVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FileVersion
modTime)
                                  (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k) (((ShowDiagnostic, Diagnostic) -> Diagnostic)
-> [(ShowDiagnostic, Diagnostic)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (ShowDiagnostic, Diagnostic) -> Diagnostic
forall a b. (a, b) -> b
snd [(ShowDiagnostic, Diagnostic)]
currentHidden) DiagnosticStore
old
            let newDiags :: [Diagnostic]
newDiags = NormalizedFilePath -> DiagnosticStore -> [Diagnostic]
getFileDiagnostics NormalizedFilePath
fp DiagnosticStore
newDiagsStore
            DiagnosticStore
_ <- DiagnosticStore -> IO DiagnosticStore
forall a. a -> IO a
evaluate DiagnosticStore
newDiagsStore
            [Diagnostic]
_ <- [Diagnostic] -> IO [Diagnostic]
forall a. a -> IO a
evaluate [Diagnostic]
newDiags
            DiagnosticStore -> IO DiagnosticStore
forall (m :: * -> *) a. Monad m => a -> m a
return DiagnosticStore
newDiagsStore
        let uri :: NormalizedUri
uri = NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp
        let delay :: Seconds
delay = if [Diagnostic] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Diagnostic]
newDiags then Seconds
0.1 else Seconds
0
        Debouncer NormalizedUri
-> Seconds -> NormalizedUri -> IO () -> IO ()
forall k. Debouncer k -> Seconds -> k -> IO () -> IO ()
registerEvent Debouncer NormalizedUri
debouncer Seconds
delay NormalizedUri
uri (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (HashMap NormalizedUri [Diagnostic])
-> (HashMap NormalizedUri [Diagnostic]
    -> IO (HashMap NormalizedUri [Diagnostic]))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap NormalizedUri [Diagnostic])
publishedDiagnostics ((HashMap NormalizedUri [Diagnostic]
  -> IO (HashMap NormalizedUri [Diagnostic]))
 -> IO ())
-> (HashMap NormalizedUri [Diagnostic]
    -> IO (HashMap NormalizedUri [Diagnostic]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap NormalizedUri [Diagnostic]
published -> do
                 let lastPublish :: [Diagnostic]
lastPublish = [Diagnostic]
-> NormalizedUri
-> HashMap NormalizedUri [Diagnostic]
-> [Diagnostic]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HMap.lookupDefault [] NormalizedUri
uri HashMap NormalizedUri [Diagnostic]
published
                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Diagnostic]
lastPublish [Diagnostic] -> [Diagnostic] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Diagnostic]
newDiags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                     FromServerMessage -> IO ()
eventer (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Uri -> [Diagnostic] -> FromServerMessage
publishDiagnosticsNotification (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri) [Diagnostic]
newDiags
                 HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap NormalizedUri [Diagnostic]
 -> IO (HashMap NormalizedUri [Diagnostic]))
-> HashMap NormalizedUri [Diagnostic]
-> IO (HashMap NormalizedUri [Diagnostic])
forall a b. (a -> b) -> a -> b
$! NormalizedUri
-> [Diagnostic]
-> HashMap NormalizedUri [Diagnostic]
-> HashMap NormalizedUri [Diagnostic]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert NormalizedUri
uri [Diagnostic]
newDiags HashMap NormalizedUri [Diagnostic]
published

publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
publishDiagnosticsNotification :: Uri -> [Diagnostic] -> FromServerMessage
publishDiagnosticsNotification Uri
uri [Diagnostic]
diags =
    PublishDiagnosticsNotification -> FromServerMessage
LSP.NotPublishDiagnostics (PublishDiagnosticsNotification -> FromServerMessage)
-> PublishDiagnosticsNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
    Text
-> ServerMethod
-> PublishDiagnosticsParams
-> PublishDiagnosticsNotification
forall m a. Text -> m -> a -> NotificationMessage m a
LSP.NotificationMessage Text
"2.0" ServerMethod
LSP.TextDocumentPublishDiagnostics (PublishDiagnosticsParams -> PublishDiagnosticsNotification)
-> PublishDiagnosticsParams -> PublishDiagnosticsNotification
forall a b. (a -> b) -> a -> b
$
    Uri -> List Diagnostic -> PublishDiagnosticsParams
LSP.PublishDiagnosticsParams Uri
uri ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
List [Diagnostic]
diags)

newtype Priority = Priority Double

setPriority :: Priority -> Action ()
setPriority :: Priority -> Action ()
setPriority (Priority Seconds
p) = Seconds -> Action ()
reschedule Seconds
p

sendEvent :: LSP.FromServerMessage -> Action ()
sendEvent :: FromServerMessage -> Action ()
sendEvent FromServerMessage
e = do
    ShakeExtras{FromServerMessage -> IO ()
eventer :: FromServerMessage -> IO ()
eventer :: ShakeExtras -> FromServerMessage -> IO ()
eventer} <- 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
$ FromServerMessage -> IO ()
eventer FromServerMessage
e

ideLogger :: IdeState -> Logger
ideLogger :: IdeState -> Logger
ideLogger IdeState{shakeExtras :: IdeState -> ShakeExtras
shakeExtras=ShakeExtras{Logger
logger :: Logger
logger :: ShakeExtras -> Logger
logger}} = Logger
logger

actionLogger :: Action Logger
actionLogger :: Action Logger
actionLogger = do
    ShakeExtras{Logger
logger :: Logger
logger :: ShakeExtras -> Logger
logger} <- Action ShakeExtras
getShakeExtras
    Logger -> Action Logger
forall (m :: * -> *) a. Monad m => a -> m a
return Logger
logger


-- The Shake key type for getModificationTime queries
data GetModificationTime = GetModificationTime_
    { GetModificationTime -> Bool
missingFileDiagnostics :: Bool
      -- ^ If false, missing file diagnostics are not reported
    }
    deriving (Int -> GetModificationTime -> ShowS
[GetModificationTime] -> ShowS
GetModificationTime -> String
(Int -> GetModificationTime -> ShowS)
-> (GetModificationTime -> String)
-> ([GetModificationTime] -> ShowS)
-> Show GetModificationTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetModificationTime] -> ShowS
$cshowList :: [GetModificationTime] -> ShowS
show :: GetModificationTime -> String
$cshow :: GetModificationTime -> String
showsPrec :: Int -> GetModificationTime -> ShowS
$cshowsPrec :: Int -> GetModificationTime -> ShowS
Show, (forall x. GetModificationTime -> Rep GetModificationTime x)
-> (forall x. Rep GetModificationTime x -> GetModificationTime)
-> Generic GetModificationTime
forall x. Rep GetModificationTime x -> GetModificationTime
forall x. GetModificationTime -> Rep GetModificationTime x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetModificationTime x -> GetModificationTime
$cfrom :: forall x. GetModificationTime -> Rep GetModificationTime x
Generic)

instance Eq GetModificationTime where
    -- Since the diagnostics are not part of the answer, the query identity is
    -- independent from the 'missingFileDiagnostics' field
    GetModificationTime
_ == :: GetModificationTime -> GetModificationTime -> Bool
== GetModificationTime
_ = Bool
True

instance Hashable GetModificationTime where
    -- Since the diagnostics are not part of the answer, the query identity is
    -- independent from the 'missingFileDiagnostics' field
    hashWithSalt :: Int -> GetModificationTime -> Int
hashWithSalt Int
salt GetModificationTime
_ = Int
salt

instance NFData   GetModificationTime
instance Binary   GetModificationTime

pattern GetModificationTime :: GetModificationTime
pattern $bGetModificationTime :: GetModificationTime
$mGetModificationTime :: forall r. GetModificationTime -> (Void# -> r) -> (Void# -> r) -> r
GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}

-- | Get the modification time of a file.
type instance RuleResult GetModificationTime = FileVersion

data FileVersion
    = VFSVersion !Int
    | ModificationTime
      !Int64   -- ^ Large unit (platform dependent, do not make assumptions)
      !Int64   -- ^ Small unit (platform dependent, do not make assumptions)
    deriving (Int -> FileVersion -> ShowS
[FileVersion] -> ShowS
FileVersion -> String
(Int -> FileVersion -> ShowS)
-> (FileVersion -> String)
-> ([FileVersion] -> ShowS)
-> Show FileVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileVersion] -> ShowS
$cshowList :: [FileVersion] -> ShowS
show :: FileVersion -> String
$cshow :: FileVersion -> String
showsPrec :: Int -> FileVersion -> ShowS
$cshowsPrec :: Int -> FileVersion -> ShowS
Show, (forall x. FileVersion -> Rep FileVersion x)
-> (forall x. Rep FileVersion x -> FileVersion)
-> Generic FileVersion
forall x. Rep FileVersion x -> FileVersion
forall x. FileVersion -> Rep FileVersion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileVersion x -> FileVersion
$cfrom :: forall x. FileVersion -> Rep FileVersion x
Generic)

instance NFData FileVersion

vfsVersion :: FileVersion -> Maybe Int
vfsVersion :: FileVersion -> TextDocumentVersion
vfsVersion (VFSVersion Int
i) = Int -> TextDocumentVersion
forall a. a -> Maybe a
Just Int
i
vfsVersion ModificationTime{} = TextDocumentVersion
forall a. Maybe a
Nothing

getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem TextDocumentVersion
_ DiagnosticsBySource
diags) = (SortedList Diagnostic -> [Diagnostic])
-> [SortedList Diagnostic] -> [Diagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SortedList Diagnostic -> [Diagnostic]
forall a. SortedList a -> [a]
SL.fromSortedList ([SortedList Diagnostic] -> [Diagnostic])
-> [SortedList Diagnostic] -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$ DiagnosticsBySource -> [SortedList Diagnostic]
forall k a. Map k a -> [a]
Map.elems DiagnosticsBySource
diags


-- | Sets the diagnostics for a file and compilation step
--   if you want to clear the diagnostics call this with an empty list
setStageDiagnostics
    :: NormalizedFilePath
    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
    -> T.Text
    -> [LSP.Diagnostic]
    -> DiagnosticStore
    -> DiagnosticStore
setStageDiagnostics :: NormalizedFilePath
-> TextDocumentVersion
-> Text
-> [Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics NormalizedFilePath
fp TextDocumentVersion
timeM Text
stage [Diagnostic]
diags DiagnosticStore
ds  =
    DiagnosticStore
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> DiagnosticStore
updateDiagnostics DiagnosticStore
ds NormalizedUri
uri TextDocumentVersion
timeM DiagnosticsBySource
diagsBySource
    where
        diagsBySource :: DiagnosticsBySource
diagsBySource = Maybe Text -> SortedList Diagnostic -> DiagnosticsBySource
forall k a. k -> a -> Map k a
Map.singleton (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stage) ([Diagnostic] -> SortedList Diagnostic
forall a. Ord a => [a] -> SortedList a
SL.toSortedList [Diagnostic]
diags)
        uri :: NormalizedUri
uri = NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp

getAllDiagnostics ::
    DiagnosticStore ->
    [FileDiagnostic]
getAllDiagnostics :: DiagnosticStore -> [FileDiagnostic]
getAllDiagnostics =
    ((NormalizedUri, StoreItem) -> [FileDiagnostic])
-> [(NormalizedUri, StoreItem)] -> [FileDiagnostic]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(NormalizedUri
k,StoreItem
v) -> (Diagnostic -> FileDiagnostic) -> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (NormalizedUri -> NormalizedFilePath
fromUri NormalizedUri
k,ShowDiagnostic
ShowDiag,) ([Diagnostic] -> [FileDiagnostic])
-> [Diagnostic] -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ StoreItem -> [Diagnostic]
getDiagnosticsFromStore StoreItem
v) ([(NormalizedUri, StoreItem)] -> [FileDiagnostic])
-> (DiagnosticStore -> [(NormalizedUri, StoreItem)])
-> DiagnosticStore
-> [FileDiagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticStore -> [(NormalizedUri, StoreItem)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList

getFileDiagnostics ::
    NormalizedFilePath ->
    DiagnosticStore ->
    [LSP.Diagnostic]
getFileDiagnostics :: NormalizedFilePath -> DiagnosticStore -> [Diagnostic]
getFileDiagnostics NormalizedFilePath
fp DiagnosticStore
ds =
    [Diagnostic]
-> (StoreItem -> [Diagnostic]) -> Maybe StoreItem -> [Diagnostic]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] StoreItem -> [Diagnostic]
getDiagnosticsFromStore (Maybe StoreItem -> [Diagnostic])
-> Maybe StoreItem -> [Diagnostic]
forall a b. (a -> b) -> a -> b
$
    NormalizedUri -> DiagnosticStore -> Maybe StoreItem
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
fp) DiagnosticStore
ds

filterDiagnostics ::
    (NormalizedFilePath -> Bool) ->
    DiagnosticStore ->
    DiagnosticStore
filterDiagnostics :: (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore
filterDiagnostics NormalizedFilePath -> Bool
keep =
    (NormalizedUri -> StoreItem -> Bool)
-> DiagnosticStore -> DiagnosticStore
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HMap.filterWithKey (\NormalizedUri
uri StoreItem
_ -> Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (NormalizedFilePath -> Bool
keep (NormalizedFilePath -> Bool)
-> (String -> NormalizedFilePath) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath') (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath' (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri)

filterVersionMap
    :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap :: HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
filterVersionMap =
    (Set TextDocumentVersion
 -> Map TextDocumentVersion a -> Map TextDocumentVersion a)
-> HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
HMap.intersectionWith ((Set TextDocumentVersion
  -> Map TextDocumentVersion a -> Map TextDocumentVersion a)
 -> HashMap NormalizedUri (Set TextDocumentVersion)
 -> HashMap NormalizedUri (Map TextDocumentVersion a)
 -> HashMap NormalizedUri (Map TextDocumentVersion a))
-> (Set TextDocumentVersion
    -> Map TextDocumentVersion a -> Map TextDocumentVersion a)
-> HashMap NormalizedUri (Set TextDocumentVersion)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
-> HashMap NormalizedUri (Map TextDocumentVersion a)
forall a b. (a -> b) -> a -> b
$ \Set TextDocumentVersion
versionsToKeep Map TextDocumentVersion a
versionMap -> Map TextDocumentVersion a
-> Set TextDocumentVersion -> Map TextDocumentVersion a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TextDocumentVersion a
versionMap Set TextDocumentVersion
versionsToKeep

updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
updatePositionMapping :: IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> IO ()
updatePositionMapping IdeState{shakeExtras :: IdeState -> ShakeExtras
shakeExtras = ShakeExtras{Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping :: ShakeExtras
-> Var
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping}} VersionedTextDocumentIdentifier{TextDocumentVersion
Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
$sel:_version:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> TextDocumentVersion
_version :: TextDocumentVersion
_uri :: Uri
..} (List [TextDocumentContentChangeEvent]
changes) = do
    Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-> (HashMap
      NormalizedUri
      (Map TextDocumentVersion (PositionDelta, PositionMapping))
    -> IO
         (HashMap
            NormalizedUri
            (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var
  (HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping)))
positionMapping ((HashMap
    NormalizedUri
    (Map TextDocumentVersion (PositionDelta, PositionMapping))
  -> IO
       (HashMap
          NormalizedUri
          (Map TextDocumentVersion (PositionDelta, PositionMapping))))
 -> IO ())
-> (HashMap
      NormalizedUri
      (Map TextDocumentVersion (PositionDelta, PositionMapping))
    -> IO
         (HashMap
            NormalizedUri
            (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings -> do
        let uri :: NormalizedUri
uri = Uri -> NormalizedUri
toNormalizedUri Uri
_uri
        let mappingForUri :: Map TextDocumentVersion (PositionDelta, PositionMapping)
mappingForUri = Map TextDocumentVersion (PositionDelta, PositionMapping)
-> NormalizedUri
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HMap.lookupDefault Map TextDocumentVersion (PositionDelta, PositionMapping)
forall k a. Map k a
Map.empty NormalizedUri
uri HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings
        let (PositionMapping
_, Map TextDocumentVersion (PositionDelta, PositionMapping)
updatedMapping) =
                -- Very important to use mapAccum here so that the tails of
                -- each mapping can be shared, otherwise quadratic space is
                -- used which is evident in long running sessions.
                (PositionMapping
 -> TextDocumentVersion
 -> (PositionDelta, PositionMapping)
 -> (PositionMapping, (PositionDelta, PositionMapping)))
-> PositionMapping
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
-> (PositionMapping,
    Map TextDocumentVersion (PositionDelta, PositionMapping))
forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumRWithKey (\PositionMapping
acc TextDocumentVersion
_k (PositionDelta
delta, PositionMapping
_) -> let new :: PositionMapping
new = PositionDelta -> PositionMapping -> PositionMapping
addDelta PositionDelta
delta PositionMapping
acc in (PositionMapping
new, (PositionDelta
delta, PositionMapping
acc)))
                  PositionMapping
zeroMapping
                  (TextDocumentVersion
-> (PositionDelta, PositionMapping)
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TextDocumentVersion
_version (PositionDelta
shared_change, PositionMapping
zeroMapping) Map TextDocumentVersion (PositionDelta, PositionMapping)
mappingForUri)
        HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap
   NormalizedUri
   (Map TextDocumentVersion (PositionDelta, PositionMapping))
 -> IO
      (HashMap
         NormalizedUri
         (Map TextDocumentVersion (PositionDelta, PositionMapping))))
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> IO
     (HashMap
        NormalizedUri
        (Map TextDocumentVersion (PositionDelta, PositionMapping)))
forall a b. (a -> b) -> a -> b
$! NormalizedUri
-> Map TextDocumentVersion (PositionDelta, PositionMapping)
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
-> HashMap
     NormalizedUri
     (Map TextDocumentVersion (PositionDelta, PositionMapping))
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert NormalizedUri
uri Map TextDocumentVersion (PositionDelta, PositionMapping)
updatedMapping HashMap
  NormalizedUri
  (Map TextDocumentVersion (PositionDelta, PositionMapping))
allMappings
  where
    shared_change :: PositionDelta
shared_change = [TextDocumentContentChangeEvent] -> PositionDelta
mkDelta [TextDocumentContentChangeEvent]
changes