{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
module Development.IDE.Core.Shake(
IdeState,
IdeRule, IdeResult, GetModificationTime(..),
shakeOpen, shakeShut,
shakeRun,
shakeProfile,
use, useWithStale, useNoFile, uses, usesWithStale,
use_, useNoFile_, uses_,
define, defineEarlyCutoff,
getDiagnostics, unsafeClearDiagnostics,
IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
garbageCollect,
setPriority,
sendEvent,
ideLogger,
actionLogger,
FileVersion(..),
Priority(..),
updatePositionMapping
) where
import Development.Shake hiding (ShakeValue)
import Development.Shake.Database
import Development.Shake.Classes
import Development.Shake.Rule
import qualified Data.HashMap.Strict as HMap
import qualified Data.Map.Strict as Map
import qualified Data.Map.Merge.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
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.Core.PositionMapping
import Development.IDE.Types.Logger hiding (Priority)
import Language.Haskell.LSP.Diagnostics
import qualified Data.SortedList as SL
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import Control.Concurrent.Extra
import Control.Exception
import Control.DeepSeq
import System.Time.Extra
import Data.Typeable
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 Numeric.Extra
import Language.Haskell.LSP.Types
data ShakeExtras = ShakeExtras
{eventer :: LSP.FromServerMessage -> IO ()
,debouncer :: Debouncer NormalizedUri
,logger :: Logger
,globals :: Var (HMap.HashMap TypeRep Dynamic)
,state :: Var Values
,diagnostics :: Var DiagnosticStore
,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
}
getShakeExtras :: Action ShakeExtras
getShakeExtras = do
Just x <- getShakeExtra @ShakeExtras
return x
getShakeExtrasRules :: Rules ShakeExtras
getShakeExtrasRules = do
Just x <- getShakeExtraRules @ShakeExtras
return x
class Typeable a => IsIdeGlobal a where
addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
addIdeGlobal x@(typeOf -> ty) = do
ShakeExtras{globals} <- getShakeExtrasRules
liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
Nothing -> return $! HMap.insert ty (toDyn x) mp
getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras{globals} = do
Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
return $ fromDyn x $ error "Serious error, corrupt globals"
getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState = getIdeGlobalExtras . shakeExtras
type Values = HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)
data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
instance Show Key where
show (Key k) = show k
instance Eq Key where
Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
| otherwise = False
instance Hashable Key where
hashWithSalt salt (Key key) = hashWithSalt salt key
type IdeResult v = ([FileDiagnostic], Maybe v)
data Value v
= Succeeded TextDocumentVersion v
| Stale TextDocumentVersion v
| Failed
deriving (Functor, Generic, Show)
instance NFData v => NFData (Value v)
currentValue :: Value v -> Maybe v
currentValue (Succeeded _ v) = Just v
currentValue (Stale _ _) = Nothing
currentValue Failed = Nothing
lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
lastValue file v = do
ShakeExtras{positionMapping} <- getShakeExtras
allMappings <- liftIO $ readVar positionMapping
pure $ case v of
Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)
Stale ver v -> Just (v, mappingForVersion allMappings file ver)
Failed -> Nothing
valueVersion :: Value v -> Maybe TextDocumentVersion
valueVersion = \case
Succeeded ver _ -> Just ver
Stale ver _ -> Just ver
Failed -> Nothing
mappingForVersion
:: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
-> NormalizedFilePath
-> TextDocumentVersion
-> PositionMapping
mappingForVersion allMappings file ver =
fromMaybe idMapping $
Map.lookup ver =<<
Map.lookup (filePathToUri' file) allMappings
type IdeRule k v =
( Shake.RuleResult k ~ v
, Show k
, Typeable k
, NFData k
, Hashable k
, Eq k
, Show v
, Typeable v
, NFData v
)
data IdeState = IdeState
{shakeDb :: ShakeDatabase
,shakeAbort :: MVar (IO ())
,shakeClose :: IO ()
,shakeExtras :: ShakeExtras
,shakeProfileDir :: Maybe FilePath
}
shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]
shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
(time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
whenJust mbProfileDir $ \dir -> do
count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
shakeProfileDatabase shakeDb $ dir </> file
return res
where
{-# NOINLINE profileStartTime #-}
profileStartTime :: String
profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
{-# NOINLINE profileCounter #-}
profileCounter :: Var Int
profileCounter = unsafePerformIO $ newVar 0
setValues :: IdeRule k v
=> Var Values
-> k
-> NormalizedFilePath
-> Value v
-> IO ()
setValues state key file val = modifyVar_ state $ \vals -> do
evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
getValues state key file = do
vs <- readVar state
case HMap.lookup (file, Key key) vs of
Nothing -> pure Nothing
Just v -> do
let r = fmap (fromJust . fromDynamic @v) v
evaluate (r `seqValue` Just r)
seqValue :: Value v -> b -> b
seqValue v b = case v of
Succeeded ver v -> rnf ver `seq` v `seq` b
Stale ver v -> rnf ver `seq` v `seq` b
Failed -> b
shakeOpen :: IO LSP.LspId
-> (LSP.FromServerMessage -> IO ())
-> Logger
-> Maybe FilePath
-> IdeReportProgress
-> ShakeOptions
-> Rules ()
-> IO IdeState
shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
shakeExtras <- do
globals <- newVar HMap.empty
state <- newVar HMap.empty
diagnostics <- newVar mempty
publishedDiagnostics <- newVar mempty
debouncer <- newDebouncer
positionMapping <- newVar Map.empty
pure ShakeExtras{..}
(shakeDb, shakeClose) <-
shakeOpenDatabase
opts
{ shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
, shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
}
rules
shakeAbort <- newMVar $ return ()
shakeDb <- shakeDb
return IdeState{..}
lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
lspShakeProgress getLspId sendMsg prog = do
lspId <- getLspId
u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
lspId $ LSP.WorkDoneProgressCreateParams
{ _token = u }
bracket_ (start u) (stop u) (loop u)
where
start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification
LSP.ProgressParams
{ _token = id
, _value = WorkDoneProgressBeginParams
{ _title = "Processing"
, _cancellable = Nothing
, _message = Nothing
, _percentage = Nothing
}
}
stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification
LSP.ProgressParams
{ _token = id
, _value = WorkDoneProgressEndParams
{ _message = Nothing
}
}
sample = 0.1
loop id = forever $ do
sleep sample
p <- prog
let done = countSkipped p + countBuilt p
let todo = done + countUnknown p + countTodo p
sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
LSP.ProgressParams
{ _token = id
, _value = LSP.WorkDoneProgressReportParams
{ _cancellable = Nothing
, _message = Just $ T.pack $ show done <> "/" <> show todo
, _percentage = Nothing
}
}
shakeProfile :: IdeState -> FilePath -> IO ()
shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
shakeShut :: IdeState -> IO ()
shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
stop
shakeClose
withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' var unmasked masked = mask $ \restore -> do
a <- takeMVar var
b <- restore (unmasked a) `onException` putMVar var a
(a', c) <- masked b
putMVar var a'
pure c
shakeRun :: IdeState -> [Action a] -> IO (IO [a])
shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
withMVar'
shakeAbort
(\stop -> do
(stopTime,_) <- duration stop
logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
bar <- newBarrier
start <- offsetTime
pure (start, bar))
(\(start, bar) -> do
thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
runTime <- start
let res' = case res of
Left e -> "exception: " <> displayException e
Right _ -> "completed"
logDebug logger $ T.pack $
"Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
signalBarrier bar res
pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
getDiagnostics :: IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
val <- readVar diagnostics
return $ getAllDiagnostics val
unsafeClearDiagnostics :: IdeState -> IO ()
unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
writeVar diagnostics mempty
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
garbageCollect keep = do
ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
liftIO $
do newState <- modifyVar state $ \values -> do
values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
return $! dupe values
modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
let versionsForFile =
Map.fromListWith Set.union $
mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
HMap.toList newState
modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
define
:: IdeRule k v
=> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
use :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe v)
use key file = head <$> uses key [file]
useWithStale :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale key file = head <$> usesWithStale key [file]
useNoFile :: IdeRule k v => k -> Action (Maybe v)
useNoFile key = use key ""
use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
use_ key file = head <$> uses_ key [file]
useNoFile_ :: IdeRule k v => k -> Action v
useNoFile_ key = use_ key ""
uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ key files = do
res <- uses key files
case sequence res of
Nothing -> liftIO $ throwIO BadDependency
Just v -> return v
data BadDependency = BadDependency deriving Show
instance Exception BadDependency
isBadDependency :: SomeException -> Bool
isBadDependency x
| Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
| Just (_ :: BadDependency) <- fromException x = True
| otherwise = False
newtype Q k = Q (k, NormalizedFilePath)
deriving (Eq,Hashable,NFData)
instance Binary (Q k) where
put _ = return ()
get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
instance Show k => Show (Q k) where
show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
data A v = A (Value v) ShakeValue
deriving Show
instance NFData (A v) where rnf (A v x) = v `seq` rnf x
type instance RuleResult (Q k) = A (RuleResult k)
uses :: IdeRule k v
=> k -> [NormalizedFilePath] -> Action [Maybe v]
uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)
usesWithStale :: IdeRule k v
=> k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
usesWithStale key files = do
values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
mapM (uncurry lastValue) (zip files values)
defineEarlyCutoff
:: IdeRule k v
=> (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
-> Rules ()
defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
extras@ShakeExtras{state} <- getShakeExtras
val <- case old of
Just old | mode == RunDependenciesSame -> do
v <- liftIO $ getValues state key file
case v of
Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
_ -> return Nothing
_ -> return Nothing
case val of
Just res -> return res
Nothing -> do
(bs, (diags, res)) <- actionCatch
(do v <- op key file; liftIO $ evaluate $ force $ v) $
\(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
(bs, res) <- case res of
Nothing -> do
staleV <- liftIO $ getValues state key file
pure $ case staleV of
Nothing -> (toShakeValue ShakeResult bs, Failed)
Just v -> case v of
Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
Failed -> (toShakeValue ShakeResult bs, Failed)
Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
liftIO $ setValues state key file res
updateFileDiagnostics file (Key key) extras $ map snd diags
let eq = case (bs, fmap decodeShakeValue old) of
(ShakeResult a, Just (ShakeResult b)) -> a == b
(ShakeStale a, Just (ShakeStale b)) -> a == b
_ -> False
return $ RunResult
(if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
(encodeShakeValue bs) $
A res bs
toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
toShakeValue = maybe ShakeNoCutoff
data ShakeValue
= ShakeNoCutoff
| ShakeResult !BS.ByteString
| ShakeStale !BS.ByteString
deriving (Generic, Show)
instance NFData ShakeValue
encodeShakeValue :: ShakeValue -> BS.ByteString
encodeShakeValue = \case
ShakeNoCutoff -> BS.empty
ShakeResult r -> BS.cons 'r' r
ShakeStale r -> BS.cons 's' r
decodeShakeValue :: BS.ByteString -> ShakeValue
decodeShakeValue bs = case BS.uncons bs of
Nothing -> ShakeNoCutoff
Just (x, xs)
| x == 'r' -> ShakeResult xs
| x == 's' -> ShakeStale xs
| otherwise -> error $ "Failed to parse shake value " <> show bs
updateFileDiagnostics ::
NormalizedFilePath
-> Key
-> ShakeExtras
-> [Diagnostic]
-> Action ()
updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
mask_ $ do
newDiags <- modifyVar diagnostics $ \old -> do
let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
let newDiags = getFileDiagnostics fp newDiagsStore
_ <- evaluate newDiagsStore
_ <- evaluate newDiags
pure $! (newDiagsStore, newDiags)
let uri = filePathToUri' fp
let delay = if null newDiags then 0.1 else 0
registerEvent debouncer delay uri $ do
mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
let lastPublish = Map.findWithDefault [] uri published
when (lastPublish /= newDiags) $
eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
pure $! Map.insert uri newDiags published
publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
publishDiagnosticsNotification uri diags =
LSP.NotPublishDiagnostics $
LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
LSP.PublishDiagnosticsParams uri (List diags)
newtype Priority = Priority Double
setPriority :: Priority -> Action ()
setPriority (Priority p) = deprioritize p
sendEvent :: LSP.FromServerMessage -> Action ()
sendEvent e = do
ShakeExtras{eventer} <- getShakeExtras
liftIO $ eventer e
ideLogger :: IdeState -> Logger
ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
actionLogger :: Action Logger
actionLogger = do
ShakeExtras{logger} <- getShakeExtras
return logger
data GetModificationTime = GetModificationTime
deriving (Eq, Show, Generic)
instance Hashable GetModificationTime
instance NFData GetModificationTime
type instance RuleResult GetModificationTime = FileVersion
data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
deriving (Show, Generic)
instance NFData FileVersion
vfsVersion :: FileVersion -> Maybe Int
vfsVersion (VFSVersion i) = Just i
vfsVersion (ModificationTime _) = Nothing
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
setStageDiagnostics
:: NormalizedFilePath
-> TextDocumentVersion
-> T.Text
-> [LSP.Diagnostic]
-> DiagnosticStore
-> DiagnosticStore
setStageDiagnostics fp timeM stage diags ds =
updateDiagnostics ds uri timeM diagsBySource
where
diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
uri = filePathToUri' fp
getAllDiagnostics ::
DiagnosticStore ->
[FileDiagnostic]
getAllDiagnostics =
concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
getFileDiagnostics ::
NormalizedFilePath ->
DiagnosticStore ->
[LSP.Diagnostic]
getFileDiagnostics fp ds =
maybe [] getDiagnosticsFromStore $
Map.lookup (filePathToUri' fp) ds
filterDiagnostics ::
(NormalizedFilePath -> Bool) ->
DiagnosticStore ->
DiagnosticStore
filterDiagnostics keep =
Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
filterVersionMap
:: Map NormalizedUri (Set.Set TextDocumentVersion)
-> Map NormalizedUri (Map TextDocumentVersion a)
-> Map NormalizedUri (Map TextDocumentVersion a)
filterVersionMap =
Map.merge Map.dropMissing Map.dropMissing $
Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
modifyVar_ positionMapping $ \allMappings -> do
let uri = toNormalizedUri _uri
let mappingForUri = Map.findWithDefault Map.empty uri allMappings
let updatedMapping =
Map.insert _version idMapping $
Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
pure $! Map.insert uri updatedMapping allMappings