module Language.PureScript.Make.BuildPlan
  ( BuildPlan(bpEnv, bpIndex)
  , BuildJobResult(..)
  , buildJobSuccess
  , 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)

-- | The BuildPlan tracks information about our build progress, and holds all
-- prebuilt modules for incremental builds.
data BuildPlan = BuildPlan
  { BuildPlan -> Map ModuleName Prebuilt
bpPrebuilt :: M.Map ModuleName Prebuilt
  , BuildPlan -> Map ModuleName BuildJob
bpBuildJobs :: M.Map ModuleName BuildJob
  , BuildPlan -> MVar Env
bpEnv :: C.MVar Env
  , BuildPlan -> MVar Int
bpIndex :: C.MVar Int
  }

data Prebuilt = Prebuilt
  { Prebuilt -> UTCTime
pbModificationTime :: UTCTime
  , Prebuilt -> ExternsFile
pbExternsFile :: ExternsFile
  }

newtype BuildJob = BuildJob
  { BuildJob -> MVar BuildJobResult
bjResult :: C.MVar BuildJobResult
    -- ^ Note: an empty MVar indicates that the build job has not yet finished.
  }

data BuildJobResult
  = BuildJobSucceeded !MultipleErrors !ExternsFile
  -- ^ Succeeded, with warnings and externs
  --
  | BuildJobFailed !MultipleErrors
  -- ^ Failed, with errors

  | BuildJobSkipped
  -- ^ The build job was not run, because an upstream build job failed

buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile)
buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile)
buildJobSuccess (BuildJobSucceeded MultipleErrors
warnings ExternsFile
externs) = forall a. a -> Maybe a
Just (MultipleErrors
warnings, ExternsFile
externs)
buildJobSuccess BuildJobResult
_ = forall a. Maybe a
Nothing

-- | Information obtained about a particular module while constructing a build
-- plan; used to decide whether a module needs rebuilding.
data RebuildStatus = RebuildStatus
  { RebuildStatus -> ModuleName
statusModuleName :: ModuleName
  , RebuildStatus -> Bool
statusRebuildNever :: Bool
  , RebuildStatus -> Maybe CacheInfo
statusNewCacheInfo :: Maybe CacheInfo
    -- ^ New cache info for this module which should be stored for subsequent
    -- incremental builds. A value of Nothing indicates that cache info for
    -- this module should not be stored in the build cache, because it is being
    -- rebuilt according to a RebuildPolicy instead.
  , RebuildStatus -> Maybe Prebuilt
statusPrebuilt :: Maybe Prebuilt
    -- ^ Prebuilt externs and timestamp for this module, if any.
  }

-- | Called when we finished compiling a module and want to report back the
-- compilation result, as well as any potential errors that were thrown.
markComplete
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> ModuleName
  -> BuildJobResult
  -> m ()
markComplete :: forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> ModuleName -> BuildJobResult -> m ()
markComplete BuildPlan
buildPlan ModuleName
moduleName BuildJobResult
result = do
  let BuildJob MVar BuildJobResult
rVar = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"make: markComplete no barrier") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
moduleName (BuildPlan -> Map ModuleName BuildJob
bpBuildJobs BuildPlan
buildPlan)
  forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar BuildJobResult
rVar BuildJobResult
result

-- | Whether or not the module with the given ModuleName needs to be rebuilt
needsRebuild :: BuildPlan -> ModuleName -> Bool
needsRebuild :: BuildPlan -> ModuleName -> Bool
needsRebuild BuildPlan
bp ModuleName
moduleName = forall k a. Ord k => k -> Map k a -> Bool
M.member ModuleName
moduleName (BuildPlan -> Map ModuleName BuildJob
bpBuildJobs BuildPlan
bp)

-- | Collects results for all prebuilt as well as rebuilt modules. This will
-- block until all build jobs are finished. Prebuilt modules always return no
-- warnings.
collectResults
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> m (M.Map ModuleName BuildJobResult)
collectResults :: forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> m (Map ModuleName BuildJobResult)
collectResults BuildPlan
buildPlan = do
  let prebuiltResults :: Map ModuleName BuildJobResult
prebuiltResults = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (MultipleErrors -> ExternsFile -> BuildJobResult
BuildJobSucceeded ([ErrorMessage] -> MultipleErrors
MultipleErrors []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prebuilt -> ExternsFile
pbExternsFile) (BuildPlan -> Map ModuleName Prebuilt
bpPrebuilt BuildPlan
buildPlan)
  Map ModuleName BuildJobResult
barrierResults <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildJob -> MVar BuildJobResult
bjResult) forall a b. (a -> b) -> a -> b
$ BuildPlan -> Map ModuleName BuildJob
bpBuildJobs BuildPlan
buildPlan
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map ModuleName BuildJobResult
prebuiltResults Map ModuleName BuildJobResult
barrierResults)

-- | Gets the the build result for a given module name independent of whether it
-- was rebuilt or prebuilt. Prebuilt modules always return no warnings.
getResult
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> ModuleName
  -> m (Maybe (MultipleErrors, ExternsFile))
getResult :: forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> ModuleName -> m (Maybe (MultipleErrors, ExternsFile))
getResult BuildPlan
buildPlan ModuleName
moduleName =
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
moduleName (BuildPlan -> Map ModuleName Prebuilt
bpPrebuilt BuildPlan
buildPlan) of
    Just Prebuilt
es ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ([ErrorMessage] -> MultipleErrors
MultipleErrors [], Prebuilt -> ExternsFile
pbExternsFile Prebuilt
es))
    Maybe Prebuilt
Nothing -> do
      BuildJobResult
r <- forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar forall a b. (a -> b) -> a -> b
$ BuildJob -> MVar BuildJobResult
bjResult forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"make: no barrier") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
moduleName (BuildPlan -> Map ModuleName BuildJob
bpBuildJobs BuildPlan
buildPlan)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ BuildJobResult -> Maybe (MultipleErrors, ExternsFile)
buildJobSuccess BuildJobResult
r

-- | Constructs a BuildPlan for the given module graph.
--
-- The given MakeActions are used to collect various timestamps in order to
-- determine whether a module needs rebuilding.
construct
  :: forall m. (Monad m, MonadBaseControl IO m)
  => MakeActions m
  -> CacheDb
  -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
  -> m (BuildPlan, CacheDb)
construct :: forall (m :: * -> *).
(Monad m, MonadBaseControl IO m) =>
MakeActions m
-> CacheDb
-> ([PartialResult Module], [(ModuleName, [ModuleName])])
-> m (BuildPlan, CacheDb)
construct MakeActions{m ()
m CacheDb
CacheDb -> m ()
ModuleName -> m (Maybe UTCTime)
ModuleName
-> m (Either RebuildPolicy (Map String (UTCTime, m ContentHash)))
ModuleName -> m (String, Maybe ExternsFile)
Module Ann -> m ()
Module Ann -> Module -> ExternsFile -> SupplyT m ()
ProgressMessage -> m ()
outputPrimDocs :: forall (m :: * -> *). MakeActions m -> m ()
writePackageJson :: forall (m :: * -> *). MakeActions m -> m ()
writeCacheDb :: forall (m :: * -> *). MakeActions m -> CacheDb -> m ()
readCacheDb :: forall (m :: * -> *). MakeActions m -> m CacheDb
progress :: forall (m :: * -> *). MakeActions m -> ProgressMessage -> m ()
ffiCodegen :: forall (m :: * -> *). MakeActions m -> Module Ann -> m ()
codegen :: forall (m :: * -> *).
MakeActions m
-> Module Ann -> Module -> ExternsFile -> SupplyT m ()
readExterns :: forall (m :: * -> *).
MakeActions m -> ModuleName -> m (String, Maybe ExternsFile)
getOutputTimestamp :: forall (m :: * -> *).
MakeActions m -> ModuleName -> m (Maybe UTCTime)
getInputTimestampsAndHashes :: forall (m :: * -> *).
MakeActions m
-> ModuleName
-> m (Either RebuildPolicy (Map String (UTCTime, m ContentHash)))
outputPrimDocs :: m ()
writePackageJson :: m ()
writeCacheDb :: CacheDb -> m ()
readCacheDb :: m CacheDb
progress :: ProgressMessage -> m ()
ffiCodegen :: Module Ann -> m ()
codegen :: Module Ann -> Module -> ExternsFile -> SupplyT m ()
readExterns :: ModuleName -> m (String, Maybe ExternsFile)
getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
getInputTimestampsAndHashes :: ModuleName
-> m (Either RebuildPolicy (Map String (UTCTime, m ContentHash)))
..} CacheDb
cacheDb ([PartialResult Module]
sorted, [(ModuleName, [ModuleName])]
graph) = do
  let sortedModuleNames :: [ModuleName]
sortedModuleNames = forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) [PartialResult Module]
sorted
  [RebuildStatus]
rebuildStatuses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadBaseControl IO m) =>
t a -> (a -> m b) -> m (t b)
A.forConcurrently [ModuleName]
sortedModuleNames ModuleName -> m RebuildStatus
getRebuildStatus
  let prebuilt :: Map ModuleName Prebuilt
prebuilt =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ModuleName Prebuilt
-> (ModuleName, Bool, Prebuilt) -> Map ModuleName Prebuilt
collectPrebuiltModules forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\RebuildStatus
s -> (RebuildStatus -> ModuleName
statusModuleName RebuildStatus
s, RebuildStatus -> Bool
statusRebuildNever RebuildStatus
s,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RebuildStatus -> Maybe Prebuilt
statusPrebuilt RebuildStatus
s) [RebuildStatus]
rebuildStatuses
  let toBeRebuilt :: [ModuleName]
toBeRebuilt = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Bool
M.member Map ModuleName Prebuilt
prebuilt) [ModuleName]
sortedModuleNames
  Map ModuleName BuildJob
buildJobs <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {k}.
(MonadBase IO m, Ord k) =>
Map k BuildJob -> k -> m (Map k BuildJob)
makeBuildJob forall k a. Map k a
M.empty [ModuleName]
toBeRebuilt
  MVar Env
env <- forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
C.newMVar Env
primEnv
  MVar Int
idx <- forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
C.newMVar Int
1
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Map ModuleName Prebuilt
-> Map ModuleName BuildJob -> MVar Env -> MVar Int -> BuildPlan
BuildPlan Map ModuleName Prebuilt
prebuilt Map ModuleName BuildJob
buildJobs MVar Env
env MVar Int
idx
    , let
        update :: CacheDb -> RebuildStatus -> CacheDb
update = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \RebuildStatus
s ->
          forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall a b. a -> b -> a
const (RebuildStatus -> Maybe CacheInfo
statusNewCacheInfo RebuildStatus
s)) (RebuildStatus -> ModuleName
statusModuleName RebuildStatus
s)
      in
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CacheDb -> RebuildStatus -> CacheDb
update CacheDb
cacheDb [RebuildStatus]
rebuildStatuses
    )
  where
    makeBuildJob :: Map k BuildJob -> k -> m (Map k BuildJob)
makeBuildJob Map k BuildJob
prev k
moduleName = do
      BuildJob
buildJob <- MVar BuildJobResult -> BuildJob
BuildJob forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
C.newEmptyMVar
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
moduleName BuildJob
buildJob Map k BuildJob
prev)

    getRebuildStatus :: ModuleName -> m RebuildStatus
    getRebuildStatus :: ModuleName -> m RebuildStatus
getRebuildStatus ModuleName
moduleName = do
      Either RebuildPolicy (Map String (UTCTime, m ContentHash))
inputInfo <- ModuleName
-> m (Either RebuildPolicy (Map String (UTCTime, m ContentHash)))
getInputTimestampsAndHashes ModuleName
moduleName
      case Either RebuildPolicy (Map String (UTCTime, m ContentHash))
inputInfo of
        Left RebuildPolicy
RebuildNever -> do
          Maybe Prebuilt
prebuilt <- ModuleName -> m (Maybe Prebuilt)
findExistingExtern ModuleName
moduleName
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (RebuildStatus
            { statusModuleName :: ModuleName
statusModuleName = ModuleName
moduleName
            , statusRebuildNever :: Bool
statusRebuildNever = Bool
True
            , statusPrebuilt :: Maybe Prebuilt
statusPrebuilt = Maybe Prebuilt
prebuilt
            , statusNewCacheInfo :: Maybe CacheInfo
statusNewCacheInfo = forall a. Maybe a
Nothing
            })
        Left RebuildPolicy
RebuildAlways -> do
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (RebuildStatus
            { statusModuleName :: ModuleName
statusModuleName = ModuleName
moduleName
            , statusRebuildNever :: Bool
statusRebuildNever = Bool
False
            , statusPrebuilt :: Maybe Prebuilt
statusPrebuilt = forall a. Maybe a
Nothing
            , statusNewCacheInfo :: Maybe CacheInfo
statusNewCacheInfo = forall a. Maybe a
Nothing
            })
        Right Map String (UTCTime, m ContentHash)
cacheInfo -> do
          String
cwd <- forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO String
getCurrentDirectory
          (CacheInfo
newCacheInfo, Bool
isUpToDate) <- forall (m :: * -> *).
Monad m =>
CacheDb
-> ModuleName
-> String
-> Map String (UTCTime, m ContentHash)
-> m (CacheInfo, Bool)
checkChanged CacheDb
cacheDb ModuleName
moduleName String
cwd Map String (UTCTime, m ContentHash)
cacheInfo
          Maybe Prebuilt
prebuilt <-
            if Bool
isUpToDate
              then ModuleName -> m (Maybe Prebuilt)
findExistingExtern ModuleName
moduleName
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (RebuildStatus
            { statusModuleName :: ModuleName
statusModuleName = ModuleName
moduleName
            , statusRebuildNever :: Bool
statusRebuildNever = Bool
False
            , statusPrebuilt :: Maybe Prebuilt
statusPrebuilt = Maybe Prebuilt
prebuilt
            , statusNewCacheInfo :: Maybe CacheInfo
statusNewCacheInfo = forall a. a -> Maybe a
Just CacheInfo
newCacheInfo
            })

    findExistingExtern :: ModuleName -> m (Maybe Prebuilt)
    findExistingExtern :: ModuleName -> m (Maybe Prebuilt)
findExistingExtern ModuleName
moduleName = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
      UTCTime
timestamp <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ ModuleName -> m (Maybe UTCTime)
getOutputTimestamp ModuleName
moduleName
      ExternsFile
externs <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> m (String, Maybe ExternsFile)
readExterns ModuleName
moduleName
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> ExternsFile -> Prebuilt
Prebuilt UTCTime
timestamp ExternsFile
externs)

    collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
    collectPrebuiltModules :: Map ModuleName Prebuilt
-> (ModuleName, Bool, Prebuilt) -> Map ModuleName Prebuilt
collectPrebuiltModules Map ModuleName Prebuilt
prev (ModuleName
moduleName, Bool
rebuildNever, Prebuilt
pb)
      | Bool
rebuildNever = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ModuleName
moduleName Prebuilt
pb Map ModuleName Prebuilt
prev
      | Bool
otherwise = do
          let deps :: [ModuleName]
deps = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"make: module not found in dependency graph.") (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
moduleName [(ModuleName, [ModuleName])]
graph)
          case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prebuilt -> UTCTime
pbModificationTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map ModuleName Prebuilt
prev) [ModuleName]
deps of
            Maybe [UTCTime]
Nothing ->
              -- If we end up here, one of the dependencies didn't exist in the
              -- prebuilt map and so we know a dependency needs to be rebuilt, which
              -- means we need to be rebuilt in turn.
              Map ModuleName Prebuilt
prev
            Just [UTCTime]
modTimes ->
              case forall a. Ord a => [a] -> Maybe a
maximumMaybe [UTCTime]
modTimes of
                Just UTCTime
depModTime | Prebuilt -> UTCTime
pbModificationTime Prebuilt
pb forall a. Ord a => a -> a -> Bool
< UTCTime
depModTime ->
                  Map ModuleName Prebuilt
prev
                Maybe UTCTime
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ModuleName
moduleName Prebuilt
pb Map ModuleName Prebuilt
prev

maximumMaybe :: Ord a => [a] -> Maybe a
maximumMaybe :: forall a. Ord a => [a] -> Maybe a
maximumMaybe [] = forall a. Maybe a
Nothing
maximumMaybe [a]
xs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs