module Language.PureScript.Make.BuildPlan
( BuildPlan(bpEnv)
, BuildJobResult(..)
, buildJobSuccess
, buildJobFailure
, construct
, getResult
, collectResults
, markComplete
, needsRebuild
) where
import Prelude
import Control.Concurrent.Async.Lifted as A
import Control.Concurrent.Lifted as C
import Control.Monad.Base (liftBase)
import Control.Monad hiding (sequence)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Foldable (foldl')
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Time.Clock (UTCTime)
import Language.PureScript.AST
import Language.PureScript.Crash
import qualified Language.PureScript.CST as CST
import Language.PureScript.Errors
import Language.PureScript.Externs
import Language.PureScript.Make.Actions as Actions
import Language.PureScript.Make.Cache
import Language.PureScript.Names (ModuleName)
import Language.PureScript.Sugar.Names.Env
import System.Directory (getCurrentDirectory)
data BuildPlan = BuildPlan
{ bpPrebuilt :: M.Map ModuleName Prebuilt
, bpBuildJobs :: M.Map ModuleName BuildJob
, bpEnv :: C.MVar Env
}
data Prebuilt = Prebuilt
{ pbModificationTime :: UTCTime
, pbExternsFile :: ExternsFile
}
newtype BuildJob = BuildJob
{ bjResult :: C.MVar BuildJobResult
}
data BuildJobResult
= BuildJobSucceeded !MultipleErrors !ExternsFile
| BuildJobFailed !MultipleErrors
| BuildJobSkipped
buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile)
buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs)
buildJobSuccess _ = Nothing
buildJobFailure :: BuildJobResult -> Maybe MultipleErrors
buildJobFailure (BuildJobFailed errors) = Just errors
buildJobFailure _ = Nothing
data RebuildStatus = RebuildStatus
{ statusModuleName :: ModuleName
, statusRebuildNever :: Bool
, statusNewCacheInfo :: Maybe CacheInfo
, statusPrebuilt :: Maybe Prebuilt
}
markComplete
:: (MonadBaseControl IO m)
=> BuildPlan
-> ModuleName
-> BuildJobResult
-> m ()
markComplete buildPlan moduleName result = do
let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)
putMVar rVar result
needsRebuild :: BuildPlan -> ModuleName -> Bool
needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp)
collectResults
:: (MonadBaseControl IO m)
=> BuildPlan
-> m (M.Map ModuleName BuildJobResult)
collectResults buildPlan = do
let prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan)
barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan
pure (M.union prebuiltResults barrierResults)
getResult
:: (MonadBaseControl IO m)
=> BuildPlan
-> ModuleName
-> m (Maybe (MultipleErrors, ExternsFile))
getResult buildPlan moduleName =
case M.lookup moduleName (bpPrebuilt buildPlan) of
Just es ->
pure (Just (MultipleErrors [], pbExternsFile es))
Nothing -> do
r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)
pure $ buildJobSuccess r
construct
:: forall m. (Monad m, MonadBaseControl IO m)
=> MakeActions m
-> CacheDb
-> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
-> m (BuildPlan, CacheDb)
construct MakeActions{..} cacheDb (sorted, graph) = do
let sortedModuleNames = map (getModuleName . CST.resPartial) sorted
rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus
let prebuilt =
foldl' collectPrebuiltModules M.empty $
mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses
let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames
buildJobs <- foldM makeBuildJob M.empty toBeRebuilt
env <- C.newMVar primEnv
pure
( BuildPlan prebuilt buildJobs env
, let
update = flip $ \s ->
M.alter (const (statusNewCacheInfo s)) (statusModuleName s)
in
foldl' update cacheDb rebuildStatuses
)
where
makeBuildJob prev moduleName = do
buildJob <- BuildJob <$> C.newEmptyMVar
pure (M.insert moduleName buildJob prev)
getRebuildStatus :: ModuleName -> m RebuildStatus
getRebuildStatus moduleName = do
inputInfo <- getInputTimestampsAndHashes moduleName
case inputInfo of
Left RebuildNever -> do
prebuilt <- findExistingExtern moduleName
pure (RebuildStatus
{ statusModuleName = moduleName
, statusRebuildNever = True
, statusPrebuilt = prebuilt
, statusNewCacheInfo = Nothing
})
Left RebuildAlways -> do
pure (RebuildStatus
{ statusModuleName = moduleName
, statusRebuildNever = False
, statusPrebuilt = Nothing
, statusNewCacheInfo = Nothing
})
Right cacheInfo -> do
cwd <- liftBase getCurrentDirectory
(newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo
prebuilt <-
if isUpToDate
then findExistingExtern moduleName
else pure Nothing
pure (RebuildStatus
{ statusModuleName = moduleName
, statusRebuildNever = False
, statusPrebuilt = prebuilt
, statusNewCacheInfo = Just newCacheInfo
})
findExistingExtern :: ModuleName -> m (Maybe Prebuilt)
findExistingExtern moduleName = runMaybeT $ do
timestamp <- MaybeT $ getOutputTimestamp moduleName
externs <- MaybeT $ snd <$> readExterns moduleName
pure (Prebuilt timestamp externs)
collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
collectPrebuiltModules prev (moduleName, rebuildNever, pb)
| rebuildNever = M.insert moduleName pb prev
| otherwise = do
let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
case traverse (fmap pbModificationTime . flip M.lookup prev) deps of
Nothing ->
prev
Just modTimes ->
case maximumMaybe modTimes of
Just depModTime | pbModificationTime pb < depModTime ->
prev
_ -> M.insert moduleName pb prev
maximumMaybe :: Ord a => [a] -> Maybe a
maximumMaybe [] = Nothing
maximumMaybe xs = Just $ maximum xs