--------------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards #-}
module Hakyll.Core.Runtime
    ( run
    , RunMode(..)
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent            (forkIO, getNumCapabilities,
                                                rtsSupportsBoundThreads)
import qualified Control.Concurrent.MVar       as MVar
import           Control.Monad                 (replicateM_, unless, void)
import           Control.Monad.Reader          (ReaderT, ask, runReaderT)
import           Control.Monad.Trans           (liftIO)
import           Data.Foldable                 (for_, traverse_)
import qualified Data.Graph                    as Graph
import           Data.IORef                    (IORef)
import qualified Data.IORef                    as IORef
import           Data.List                     (foldl', intercalate)
import           Data.Map                      (Map)
import qualified Data.Map                      as Map
import           Data.Maybe                    (fromMaybe)
import           Data.Sequence                 (Seq)
import qualified Data.Sequence                 as Seq
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           System.Exit                   (ExitCode (..))
import           System.FilePath               ((</>))


--------------------------------------------------------------------------------
import           Hakyll.Core.Compiler.Internal
import           Hakyll.Core.Compiler.Require
import           Hakyll.Core.Configuration
import           Hakyll.Core.Dependencies
import           Hakyll.Core.Identifier
import           Hakyll.Core.Item
import           Hakyll.Core.Item.SomeItem
import           Hakyll.Core.Logger            (Logger)
import qualified Hakyll.Core.Logger            as Logger
import           Hakyll.Core.Provider
import           Hakyll.Core.Routes
import           Hakyll.Core.Rules.Internal
import           Hakyll.Core.Store             (Store)
import qualified Hakyll.Core.Store             as Store
import           Hakyll.Core.Util.File
import           Hakyll.Core.Writable


factsKey :: [String]
factsKey :: [FilePath]
factsKey = [FilePath
"Hakyll.Core.Runtime.run", FilePath
"facts"]


--------------------------------------------------------------------------------
-- | Whether to execute a normal run (build the site) or a dry run.
data RunMode = RunModeNormal | RunModePrintOutOfDate
    deriving (Int -> RunMode -> ShowS
[RunMode] -> ShowS
RunMode -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RunMode] -> ShowS
$cshowList :: [RunMode] -> ShowS
show :: RunMode -> FilePath
$cshow :: RunMode -> FilePath
showsPrec :: Int -> RunMode -> ShowS
$cshowsPrec :: Int -> RunMode -> ShowS
Show)


--------------------------------------------------------------------------------
run :: RunMode -> Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)
run :: forall a.
RunMode
-> Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)
run RunMode
mode Configuration
config Logger
logger Rules a
rules = do
    -- Initialization
    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Initialising..."
    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger FilePath
"Creating store..."
    Store
store <- Bool -> FilePath -> IO Store
Store.new (Configuration -> Bool
inMemoryCache Configuration
config) forall a b. (a -> b) -> a -> b
$ Configuration -> FilePath
storeDirectory Configuration
config
    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger FilePath
"Creating provider..."
    Provider
provider <- Store -> (FilePath -> IO Bool) -> FilePath -> IO Provider
newProvider Store
store (Configuration -> FilePath -> IO Bool
shouldIgnoreFile Configuration
config) forall a b. (a -> b) -> a -> b
$
        Configuration -> FilePath
providerDirectory Configuration
config
    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger FilePath
"Running rules..."
    RuleSet
ruleSet  <- forall a. Rules a -> Provider -> IO RuleSet
runRules Rules a
rules Provider
provider

    -- Get old facts
    Result DependencyFacts
mOldFacts <- forall a.
(Binary a, Typeable a) =>
Store -> [FilePath] -> IO (Result a)
Store.get Store
store [FilePath]
factsKey
    let (DependencyFacts
oldFacts) = case Result DependencyFacts
mOldFacts of Store.Found DependencyFacts
f -> DependencyFacts
f
                                       Result DependencyFacts
_             -> forall a. Monoid a => a
mempty

    -- Build runtime read/state
    IORef Scheduler
scheduler <- forall a. a -> IO (IORef a)
IORef.newIORef forall a b. (a -> b) -> a -> b
$ Scheduler
emptyScheduler {schedulerFacts :: DependencyFacts
schedulerFacts = DependencyFacts
oldFacts}
    let compilers :: [(Identifier, Compiler SomeItem)]
compilers = RuleSet -> [(Identifier, Compiler SomeItem)]
rulesCompilers RuleSet
ruleSet
        read' :: RuntimeRead
read'     = RuntimeRead
            { runtimeConfiguration :: Configuration
runtimeConfiguration = Configuration
config
            , runtimeLogger :: Logger
runtimeLogger        = Logger
logger
            , runtimeProvider :: Provider
runtimeProvider      = Provider
provider
            , runtimeStore :: Store
runtimeStore         = Store
store
            , runtimeRoutes :: Routes
runtimeRoutes        = RuleSet -> Routes
rulesRoutes RuleSet
ruleSet
            , runtimeUniverse :: Map Identifier (Compiler SomeItem)
runtimeUniverse      = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Identifier, Compiler SomeItem)]
compilers
            , runtimeScheduler :: IORef Scheduler
runtimeScheduler     = IORef Scheduler
scheduler
            }

    -- Run the program and fetch the resulting state
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (RunMode -> ReaderT RuntimeRead IO ()
build RunMode
mode) RuntimeRead
read'
    [(Maybe Identifier, FilePath)]
errors <- Scheduler -> [(Maybe Identifier, FilePath)]
schedulerErrors forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef Scheduler
scheduler
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe Identifier, FilePath)]
errors then do
        forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.debug Logger
logger FilePath
"Removing tmp directory..."
        FilePath -> IO ()
removeDirectory forall a b. (a -> b) -> a -> b
$ Configuration -> FilePath
tmpDirectory Configuration
config

        Logger -> forall (m :: * -> *). MonadIO m => m ()
Logger.flush Logger
logger
        forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, RuleSet
ruleSet)
    else do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Maybe Identifier, FilePath)]
errors forall a b. (a -> b) -> a -> b
$ \(Maybe Identifier
mbId, FilePath
err) -> forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.error Logger
logger forall a b. (a -> b) -> a -> b
$ case Maybe Identifier
mbId of
            Just Identifier
identifier -> forall a. Show a => a -> FilePath
show Identifier
identifier forall a. Semigroup a => a -> a -> a
<> FilePath
": " forall a. Semigroup a => a -> a -> a
<> FilePath
err
            Maybe Identifier
Nothing         -> FilePath
err
        Logger -> forall (m :: * -> *). MonadIO m => m ()
Logger.flush Logger
logger
        forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1, RuleSet
ruleSet)


--------------------------------------------------------------------------------
data RuntimeRead = RuntimeRead
    { RuntimeRead -> Configuration
runtimeConfiguration :: Configuration
    , RuntimeRead -> Logger
runtimeLogger        :: Logger
    , RuntimeRead -> Provider
runtimeProvider      :: Provider
    , RuntimeRead -> Store
runtimeStore         :: Store
    , RuntimeRead -> Routes
runtimeRoutes        :: Routes
    , RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse      :: Map Identifier (Compiler SomeItem)
    , RuntimeRead -> IORef Scheduler
runtimeScheduler     :: IORef Scheduler
    }


--------------------------------------------------------------------------------
-- | A Scheduler is a pure representation of work going on, works that needs
-- to be done, and work already done.  Workers can obtain things to do
-- by interacting with the Scheduler, and execute them synchronously or
-- asynchronously.
--
-- All operations on Scheduler look like 'Scheduler -> (Scheduler, a)' and
-- should be used with atomicModifyIORef'.
data Scheduler = Scheduler
    { -- | Items to work on next.  Identifiers may appear multiple times.
      Scheduler -> Seq Identifier
schedulerQueue     :: !(Seq Identifier)
    , -- | Items that we haven't started yet.
      Scheduler -> Map Identifier (Compiler SomeItem)
schedulerTodo      :: !(Map Identifier (Compiler SomeItem))
    , -- | Currently processing
      Scheduler -> Set Identifier
schedulerWorking   :: !(Set Identifier)
    , -- | Finished
      Scheduler -> Set Identifier
schedulerDone      :: !(Set Identifier)
    , -- | Any snapshots stored.
      Scheduler -> Set (Identifier, FilePath)
schedulerSnapshots :: !(Set (Identifier, Snapshot))
    , -- | Any routed files and who wrote them.  This is used to detect multiple
      -- writes to the same file, which can yield inconsistent results.
      Scheduler -> Map FilePath Identifier
schedulerRoutes    :: !(Map FilePath Identifier)
    , -- | Currently blocked compilers.
      Scheduler -> Set Identifier
schedulerBlocked   :: !(Set Identifier)
    , -- | Compilers that may resume on triggers
      Scheduler -> Map Identifier (Set Identifier)
schedulerTriggers  :: !(Map Identifier (Set Identifier))
    , -- | Number of starved pops; tracking this allows us to start a new
      -- number of threads again later.
      Scheduler -> Int
schedulerStarved   :: !Int
    , -- | Dynamic dependency info.
      Scheduler -> DependencyFacts
schedulerFacts     :: !DependencyFacts
    , -- | Errors encountered.
      Scheduler -> [(Maybe Identifier, FilePath)]
schedulerErrors    :: ![(Maybe Identifier, String)]
    }


--------------------------------------------------------------------------------
emptyScheduler :: Scheduler
emptyScheduler :: Scheduler
emptyScheduler = Scheduler {Int
forall {a}. [a]
forall {a}. Seq a
forall {a}. Set a
forall {k} {a}. Map k a
schedulerErrors :: forall {a}. [a]
schedulerFacts :: forall {k} {a}. Map k a
schedulerStarved :: Int
schedulerTriggers :: forall {k} {a}. Map k a
schedulerBlocked :: forall {a}. Set a
schedulerRoutes :: forall {k} {a}. Map k a
schedulerSnapshots :: forall {a}. Set a
schedulerWorking :: forall {a}. Set a
schedulerQueue :: forall {a}. Seq a
schedulerDone :: forall {a}. Set a
schedulerTodo :: forall {k} {a}. Map k a
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
..}
  where
    schedulerTodo :: Map k a
schedulerTodo      = forall {k} {a}. Map k a
Map.empty
    schedulerDone :: Set a
schedulerDone      = forall {a}. Set a
Set.empty
    schedulerQueue :: Seq a
schedulerQueue     = forall {a}. Seq a
Seq.empty
    schedulerWorking :: Set a
schedulerWorking   = forall {a}. Set a
Set.empty
    schedulerSnapshots :: Set a
schedulerSnapshots = forall {a}. Set a
Set.empty
    schedulerRoutes :: Map k a
schedulerRoutes    = forall {k} {a}. Map k a
Map.empty
    schedulerBlocked :: Set a
schedulerBlocked   = forall {a}. Set a
Set.empty
    schedulerTriggers :: Map k a
schedulerTriggers  = forall {k} {a}. Map k a
Map.empty
    schedulerStarved :: Int
schedulerStarved   = Int
0
    schedulerFacts :: Map k a
schedulerFacts     = forall {k} {a}. Map k a
Map.empty
    schedulerErrors :: [a]
schedulerErrors    = []


--------------------------------------------------------------------------------
schedulerError :: Maybe Identifier -> String -> Scheduler -> (Scheduler, ())
schedulerError :: Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError Maybe Identifier
i FilePath
e Scheduler
s = (Scheduler
s {schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerErrors = (Maybe Identifier
i, FilePath
e) forall a. a -> [a] -> [a]
: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerErrors Scheduler
s}, ())


--------------------------------------------------------------------------------
schedulerMarkOutOfDate
    :: Map Identifier (Compiler SomeItem)
    -> Set Identifier
    -> Scheduler
    -> (Scheduler, [String])
schedulerMarkOutOfDate :: Map Identifier (Compiler SomeItem)
-> Set Identifier -> Scheduler -> (Scheduler, [FilePath])
schedulerMarkOutOfDate Map Identifier (Compiler SomeItem)
universe Set Identifier
modified scheduler :: Scheduler
scheduler@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..} =
    ( Scheduler
scheduler
        { schedulerQueue :: Seq Identifier
schedulerQueue = Seq Identifier
schedulerQueue forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Seq a
Seq.fromList (forall k a. Map k a -> [k]
Map.keys Map Identifier (Compiler SomeItem)
todo)
        , schedulerDone :: Set Identifier
schedulerDone  = Set Identifier
schedulerDone forall a. Semigroup a => a -> a -> a
<>
            (forall k a. Map k a -> Set k
Map.keysSet Map Identifier (Compiler SomeItem)
universe forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Identifier
ood)
        , schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerTodo  = Map Identifier (Compiler SomeItem)
schedulerTodo forall a. Semigroup a => a -> a -> a
<> Map Identifier (Compiler SomeItem)
todo
        , schedulerFacts :: DependencyFacts
schedulerFacts = DependencyFacts
facts'
        }
    , [FilePath]
msgs
    )
  where
    (Set Identifier
ood, DependencyFacts
facts', [FilePath]
msgs) = [Identifier]
-> Set Identifier
-> DependencyFacts
-> (Set Identifier, DependencyFacts, [FilePath])
outOfDate (forall k a. Map k a -> [k]
Map.keys Map Identifier (Compiler SomeItem)
universe) Set Identifier
modified DependencyFacts
schedulerFacts
    todo :: Map Identifier (Compiler SomeItem)
todo = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Identifier
id' Compiler SomeItem
_ -> Identifier
id' forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
ood) Map Identifier (Compiler SomeItem)
universe


--------------------------------------------------------------------------------
data SchedulerStep
    -- | The scheduler instructs to offer some work on the given item.  It
    -- also returns the number of threads that can be resumed after they have
    -- starved.
    = SchedulerWork Identifier (Compiler SomeItem) Int
    -- | There's currently no work available, but there will be after other
    -- threads have finished whatever they are doing.
    | SchedulerStarve
    -- | We've finished all work.
    | SchedulerFinish
    -- | An error occurred.  You can retrieve the errors from 'schedulerErrors'.
    | SchedulerError


--------------------------------------------------------------------------------
schedulerPop :: Scheduler -> (Scheduler, SchedulerStep)
schedulerPop :: Scheduler -> (Scheduler, SchedulerStep)
schedulerPop scheduler :: Scheduler
scheduler@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..} = case forall a. Seq a -> ViewL a
Seq.viewl Seq Identifier
schedulerQueue of
    ViewL Identifier
Seq.EmptyL
        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set Identifier
schedulerWorking ->
            ( Scheduler
scheduler {schedulerStarved :: Int
schedulerStarved = Int
schedulerStarved forall a. Num a => a -> a -> a
+ Int
1}
            , SchedulerStep
SchedulerStarve
            )
        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set Identifier
schedulerBlocked ->
            let cycles :: [[Identifier]]
cycles = Scheduler -> [[Identifier]]
schedulerCycles Scheduler
scheduler
                msg :: FilePath
msg | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Identifier]]
cycles = FilePath
"Possible dependency cycle in: " forall a. Semigroup a => a -> a -> a
<>
                        forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a. Show a => a -> FilePath
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set Identifier
schedulerBlocked)
                    | Bool
otherwise = FilePath
"Dependency cycles: " forall a. Semigroup a => a -> a -> a
<>
                        forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"; "
                            (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" -> " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show) [[Identifier]]
cycles) in
            SchedulerStep
SchedulerError forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError forall a. Maybe a
Nothing FilePath
msg Scheduler
scheduler
        | Bool
otherwise -> (Scheduler
scheduler, SchedulerStep
SchedulerFinish)
    Identifier
x Seq.:< Seq Identifier
xs
        | Identifier
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerDone ->
            Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler {schedulerQueue :: Seq Identifier
schedulerQueue = Seq Identifier
xs}
        | Identifier
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerWorking ->
            Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler {schedulerQueue :: Seq Identifier
schedulerQueue = Seq Identifier
xs}
        | Identifier
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerBlocked ->
            Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler {schedulerQueue :: Seq Identifier
schedulerQueue = Seq Identifier
xs}
        | Bool
otherwise -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
x Map Identifier (Compiler SomeItem)
schedulerTodo of
            Maybe (Compiler SomeItem)
Nothing -> SchedulerStep
SchedulerError forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
                Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (forall a. a -> Maybe a
Just Identifier
x) FilePath
"Compiler not found" Scheduler
scheduler
            Just Compiler SomeItem
c  ->
                ( Scheduler
scheduler
                    { schedulerQueue :: Seq Identifier
schedulerQueue   = Seq Identifier
xs
                    , schedulerWorking :: Set Identifier
schedulerWorking = forall a. Ord a => a -> Set a -> Set a
Set.insert Identifier
x Set Identifier
schedulerWorking
                    }
                , Identifier -> Compiler SomeItem -> Int -> SchedulerStep
SchedulerWork Identifier
x Compiler SomeItem
c Int
0
                )


--------------------------------------------------------------------------------
schedulerCycles :: Scheduler -> [[Identifier]]
schedulerCycles :: Scheduler -> [[Identifier]]
schedulerCycles Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..} =
    [[Identifier]
c | Graph.CyclicSCC [Identifier]
c <- forall key node. Ord key => [(node, key, [key])] -> [SCC node]
Graph.stronglyConnComp [(Identifier, Identifier, [Identifier])]
graph]
  where
    graph :: [(Identifier, Identifier, [Identifier])]
graph = [(Identifier
x, Identifier
x, forall a. Set a -> [a]
Set.toList Set Identifier
ys) | (Identifier
x, Set Identifier
ys) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Identifier (Set Identifier)
edges]
    edges :: Map Identifier (Set Identifier)
edges = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a b. (a -> b) -> a -> b
$ do
        (Identifier
dep, Set Identifier
xs) <- forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Map Identifier (Set Identifier)
schedulerTriggers
        Identifier
x <- forall a. Set a -> [a]
Set.toList Set Identifier
xs
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Identifier
x, forall a. a -> Set a
Set.singleton Identifier
dep)


--------------------------------------------------------------------------------
schedulerBlock
    :: Identifier
    -> [(Identifier, Snapshot)]
    -> Compiler SomeItem
    -> Scheduler
    -> (Scheduler, SchedulerStep)
schedulerBlock :: Identifier
-> [(Identifier, FilePath)]
-> Compiler SomeItem
-> Scheduler
-> (Scheduler, SchedulerStep)
schedulerBlock Identifier
identifier [(Identifier, FilePath)]
deps0 Compiler SomeItem
compiler scheduler :: Scheduler
scheduler@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..}
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Identifier, FilePath)]
deps1 = (Scheduler
scheduler, Identifier -> Compiler SomeItem -> Int -> SchedulerStep
SchedulerWork Identifier
identifier Compiler SomeItem
compiler Int
0)
    | Bool
otherwise  = Scheduler -> (Scheduler, SchedulerStep)
schedulerPop forall a b. (a -> b) -> a -> b
$ Scheduler
scheduler
         { schedulerQueue :: Seq Identifier
schedulerQueue    =
             -- Optimization: move deps to the front and item to the back
             forall a. [a] -> Seq a
Seq.fromList [Identifier]
depIds forall a. Semigroup a => a -> a -> a
<>
             Seq Identifier
schedulerQueue forall a. Semigroup a => a -> a -> a
<>
             forall a. a -> Seq a
Seq.singleton Identifier
identifier
         , schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerTodo     =
             forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Identifier
identifier
                 (forall a. (CompilerRead -> IO (CompilerResult a)) -> Compiler a
Compiler forall a b. (a -> b) -> a -> b
$ \CompilerRead
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
[(Identifier, FilePath)] -> Compiler a -> CompilerResult a
CompilerRequire [(Identifier, FilePath)]
deps0 Compiler SomeItem
compiler)
                 Map Identifier (Compiler SomeItem)
schedulerTodo
         , schedulerWorking :: Set Identifier
schedulerWorking  = forall a. Ord a => a -> Set a -> Set a
Set.delete Identifier
identifier Set Identifier
schedulerWorking
         , schedulerBlocked :: Set Identifier
schedulerBlocked  = forall a. Ord a => a -> Set a -> Set a
Set.insert Identifier
identifier Set Identifier
schedulerBlocked
         , schedulerTriggers :: Map Identifier (Set Identifier)
schedulerTriggers = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
             (\Map Identifier (Set Identifier)
acc (Identifier
depId, FilePath
_) ->
                 forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Identifier
depId (forall a. a -> Set a
Set.singleton Identifier
identifier) Map Identifier (Set Identifier)
acc)
             Map Identifier (Set Identifier)
schedulerTriggers
             [(Identifier, FilePath)]
deps1
         }
  where
    deps1 :: [(Identifier, FilePath)]
deps1  = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, FilePath) -> Bool
done) [(Identifier, FilePath)]
deps0
    depIds :: [Identifier]
depIds = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Identifier, FilePath)]
deps1

    -- Done if we either completed the entire item (runtimeDone) or
    -- if we previously saved the snapshot (runtimeSnapshots).
    done :: (Identifier, FilePath) -> Bool
done (Identifier
depId, FilePath
depSnapshot) =
        Identifier
depId forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerDone Bool -> Bool -> Bool
||
        (Identifier
depId, FilePath
depSnapshot) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Identifier, FilePath)
schedulerSnapshots


--------------------------------------------------------------------------------
schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int)
schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int)
schedulerUnblock Identifier
identifier scheduler :: Scheduler
scheduler@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..} =
    ( Scheduler
scheduler
        { schedulerQueue :: Seq Identifier
schedulerQueue    =
            Seq Identifier
schedulerQueue forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Seq a
Seq.fromList (forall a. Set a -> [a]
Set.toList Set Identifier
triggered)
        , schedulerStarved :: Int
schedulerStarved  = Int
0
        , schedulerBlocked :: Set Identifier
schedulerBlocked  = forall a. Ord a => a -> Set a -> Set a
Set.delete Identifier
identifier forall a b. (a -> b) -> a -> b
$
            Set Identifier
schedulerBlocked forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Identifier
triggered
        , schedulerTriggers :: Map Identifier (Set Identifier)
schedulerTriggers = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Identifier
identifier Map Identifier (Set Identifier)
schedulerTriggers
        }
    , Int
schedulerStarved
    )
  where
    triggered :: Set Identifier
triggered = forall a. a -> Maybe a -> a
fromMaybe forall {a}. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
identifier Map Identifier (Set Identifier)
schedulerTriggers


--------------------------------------------------------------------------------
schedulerSnapshot
    :: Identifier -> Snapshot -> Compiler SomeItem
    -> Scheduler -> (Scheduler, SchedulerStep)
schedulerSnapshot :: Identifier
-> FilePath
-> Compiler SomeItem
-> Scheduler
-> (Scheduler, SchedulerStep)
schedulerSnapshot Identifier
identifier FilePath
snapshot Compiler SomeItem
compiler scheduler :: Scheduler
scheduler@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..} =
    let (Scheduler
scheduler', Int
resume) = Identifier -> Scheduler -> (Scheduler, Int)
schedulerUnblock Identifier
identifier Scheduler
scheduler
            { schedulerSnapshots :: Set (Identifier, FilePath)
schedulerSnapshots =
                forall a. Ord a => a -> Set a -> Set a
Set.insert (Identifier
identifier, FilePath
snapshot) Set (Identifier, FilePath)
schedulerSnapshots
            } in
    (Scheduler
scheduler', Identifier -> Compiler SomeItem -> Int -> SchedulerStep
SchedulerWork Identifier
identifier Compiler SomeItem
compiler Int
resume)


--------------------------------------------------------------------------------
schedulerWrite
    :: Identifier
    -> [Dependency]
    -> Scheduler
    -> (Scheduler, SchedulerStep)
schedulerWrite :: Identifier
-> [Dependency] -> Scheduler -> (Scheduler, SchedulerStep)
schedulerWrite Identifier
identifier [Dependency]
depFacts scheduler0 :: Scheduler
scheduler0@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..} =
    let (Scheduler
scheduler1, Int
resume) = Identifier -> Scheduler -> (Scheduler, Int)
schedulerUnblock Identifier
identifier Scheduler
scheduler0
            { schedulerWorking :: Set Identifier
schedulerWorking = forall a. Ord a => a -> Set a -> Set a
Set.delete Identifier
identifier Set Identifier
schedulerWorking
            , schedulerFacts :: DependencyFacts
schedulerFacts   = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Identifier
identifier [Dependency]
depFacts DependencyFacts
schedulerFacts
            , schedulerDone :: Set Identifier
schedulerDone    =
                forall a. Ord a => a -> Set a -> Set a
Set.insert Identifier
identifier Set Identifier
schedulerDone
            , schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerTodo    =
                forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Identifier
identifier Map Identifier (Compiler SomeItem)
schedulerTodo
            }
        (Scheduler
scheduler2, SchedulerStep
step) = Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler1 in
    case SchedulerStep
step of
        SchedulerWork Identifier
i Compiler SomeItem
c Int
n -> (Scheduler
scheduler2, Identifier -> Compiler SomeItem -> Int -> SchedulerStep
SchedulerWork Identifier
i Compiler SomeItem
c (Int
n forall a. Num a => a -> a -> a
+ Int
resume))
        SchedulerStep
_                   -> (Scheduler
scheduler2, SchedulerStep
step)


--------------------------------------------------------------------------------
-- | Record that a specific identifier was routed to a specific filepath.
-- This is used to detect multiple (inconsistent) writes to the same file.
schedulerRoute
    :: Identifier
    -> FilePath
    -> Scheduler
    -> (Scheduler, ())
schedulerRoute :: Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerRoute Identifier
id0 FilePath
path scheduler0 :: Scheduler
scheduler0@Scheduler {Int
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Seq Identifier
Set (Identifier, FilePath)
Set Identifier
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerFacts :: DependencyFacts
schedulerStarved :: Int
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerBlocked :: Set Identifier
schedulerRoutes :: Map FilePath Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerDone :: Set Identifier
schedulerWorking :: Set Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerQueue :: Seq Identifier
schedulerStarved :: Scheduler -> Int
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerBlocked :: Scheduler -> Set Identifier
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerDone :: Scheduler -> Set Identifier
schedulerWorking :: Scheduler -> Set Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerQueue :: Scheduler -> Seq Identifier
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerFacts :: Scheduler -> DependencyFacts
..}
    | Just Identifier
id1 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
path Map FilePath Identifier
schedulerRoutes, Identifier
id0 forall a. Eq a => a -> a -> Bool
/= Identifier
id1 =
        let msg :: FilePath
msg = FilePath
"multiple writes for route " forall a. [a] -> [a] -> [a]
++ FilePath
path forall a. [a] -> [a] -> [a]
++ FilePath
": " forall a. [a] -> [a] -> [a]
++
                forall a. Show a => a -> FilePath
show Identifier
id0 forall a. [a] -> [a] -> [a]
++ FilePath
" and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Identifier
id1 in
        Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (forall a. a -> Maybe a
Just Identifier
id0) FilePath
msg Scheduler
scheduler0
    | Bool
otherwise =
        let routes :: Map FilePath Identifier
routes = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
path Identifier
id0 Map FilePath Identifier
schedulerRoutes in
        (Scheduler
scheduler0 {schedulerRoutes :: Map FilePath Identifier
schedulerRoutes = Map FilePath Identifier
routes}, ())


--------------------------------------------------------------------------------
build :: RunMode -> ReaderT RuntimeRead IO ()
build :: RunMode -> ReaderT RuntimeRead IO ()
build RunMode
mode = do
    Logger
logger <- RuntimeRead -> Logger
runtimeLogger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Checking for out-of-date items"
    IORef Scheduler
schedulerRef <- RuntimeRead -> IORef Scheduler
runtimeScheduler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    ReaderT RuntimeRead IO ()
scheduleOutOfDate
    case RunMode
mode of
        RunMode
RunModeNormal -> do
            forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Compiling"
            if Bool
rtsSupportsBoundThreads then ReaderT RuntimeRead IO ()
pickAndChaseAsync else ReaderT RuntimeRead IO ()
pickAndChase
            forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Success"
            DependencyFacts
facts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Scheduler -> DependencyFacts
schedulerFacts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef Scheduler
schedulerRef
            Store
store <- RuntimeRead -> Store
runtimeStore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
(Binary a, Typeable a) =>
Store -> [FilePath] -> a -> IO ()
Store.set Store
store [FilePath]
factsKey DependencyFacts
facts
        RunMode
RunModePrintOutOfDate -> do
            forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Out of date items:"
            Map Identifier (Compiler SomeItem)
todo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Scheduler -> Map Identifier (Compiler SomeItem)
schedulerTodo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef Scheduler
schedulerRef
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) (forall k a. Map k a -> [k]
Map.keys Map Identifier (Compiler SomeItem)
todo)


--------------------------------------------------------------------------------
scheduleOutOfDate :: ReaderT RuntimeRead IO ()
scheduleOutOfDate :: ReaderT RuntimeRead IO ()
scheduleOutOfDate = do
    Logger
logger       <- RuntimeRead -> Logger
runtimeLogger    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Provider
provider     <- RuntimeRead -> Provider
runtimeProvider  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Map Identifier (Compiler SomeItem)
universe     <- RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    IORef Scheduler
schedulerRef <- RuntimeRead -> IORef Scheduler
runtimeScheduler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    let modified :: Set Identifier
modified  = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Provider -> Identifier -> Bool
resourceModified Provider
provider) (forall k a. Map k a -> Set k
Map.keysSet Map Identifier (Compiler SomeItem)
universe)
    [FilePath]
msgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
schedulerRef forall a b. (a -> b) -> a -> b
$
        Map Identifier (Compiler SomeItem)
-> Set Identifier -> Scheduler -> (Scheduler, [FilePath])
schedulerMarkOutOfDate Map Identifier (Compiler SomeItem)
universe Set Identifier
modified

    -- Print messages
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.debug Logger
logger) [FilePath]
msgs


--------------------------------------------------------------------------------
pickAndChase :: ReaderT RuntimeRead IO ()
pickAndChase :: ReaderT RuntimeRead IO ()
pickAndChase = do
    IORef Scheduler
scheduler <- RuntimeRead -> IORef Scheduler
runtimeScheduler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    let go :: SchedulerStep -> ReaderT RuntimeRead IO ()
go SchedulerStep
SchedulerFinish       = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        go SchedulerStep
SchedulerError        = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        go (SchedulerWork Identifier
i Compiler SomeItem
c Int
_) = Identifier
-> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep
work Identifier
i Compiler SomeItem
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchedulerStep -> ReaderT RuntimeRead IO ()
go
        go SchedulerStep
SchedulerStarve       =
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$
            Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError forall a. Maybe a
Nothing FilePath
"Starved, possible dependency cycle?"
    SchedulerStep
pop <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$ Scheduler -> (Scheduler, SchedulerStep)
schedulerPop
    SchedulerStep -> ReaderT RuntimeRead IO ()
go SchedulerStep
pop


--------------------------------------------------------------------------------
pickAndChaseAsync :: ReaderT RuntimeRead IO ()
pickAndChaseAsync :: ReaderT RuntimeRead IO ()
pickAndChaseAsync = do
    RuntimeRead
runtimeRead <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Int
numThreads  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumCapabilities
    let scheduler :: IORef Scheduler
scheduler = RuntimeRead -> IORef Scheduler
runtimeScheduler RuntimeRead
runtimeRead
    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message (RuntimeRead -> Logger
runtimeLogger RuntimeRead
runtimeRead) forall a b. (a -> b) -> a -> b
$
        FilePath
"Using async runtime with " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
numThreads forall a. Semigroup a => a -> a -> a
<> FilePath
" threads..."
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        MVar ()
signal     <- forall a. IO (MVar a)
MVar.newEmptyMVar

        let spawnN :: Int -> IO ()
            spawnN :: Int -> IO ()
spawnN Int
n = forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$
                forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler Scheduler -> (Scheduler, SchedulerStep)
schedulerPop forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchedulerStep -> IO ()
go

            go :: SchedulerStep -> IO ()
            go :: SchedulerStep -> IO ()
go SchedulerStep
step = case SchedulerStep
step of
                SchedulerStep
SchedulerFinish       -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
signal ()
                SchedulerStep
SchedulerStarve       -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                SchedulerStep
SchedulerError        -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
signal ()
                (SchedulerWork Identifier
i Compiler SomeItem
c Int
n) -> do
                    Int -> IO ()
spawnN Int
n
                    SchedulerStep
step' <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Identifier
-> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep
work Identifier
i Compiler SomeItem
c) RuntimeRead
runtimeRead
                    SchedulerStep -> IO ()
go SchedulerStep
step'

        Int -> IO ()
spawnN Int
numThreads
        forall a. MVar a -> IO a
MVar.readMVar MVar ()
signal


--------------------------------------------------------------------------------
work :: Identifier -> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep
work :: Identifier
-> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep
work Identifier
id' Compiler SomeItem
compiler = do
    Logger
logger    <- RuntimeRead -> Logger
runtimeLogger        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Provider
provider  <- RuntimeRead -> Provider
runtimeProvider      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Map Identifier (Compiler SomeItem)
universe  <- RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Routes
routes    <- RuntimeRead -> Routes
runtimeRoutes        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Store
store     <- RuntimeRead -> Store
runtimeStore         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Configuration
config    <- RuntimeRead -> Configuration
runtimeConfiguration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    IORef Scheduler
scheduler <- RuntimeRead -> IORef Scheduler
runtimeScheduler     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

    let cread :: CompilerRead
cread = CompilerRead
            { compilerConfig :: Configuration
compilerConfig     = Configuration
config
            , compilerUnderlying :: Identifier
compilerUnderlying = Identifier
id'
            , compilerProvider :: Provider
compilerProvider   = Provider
provider
            , compilerUniverse :: Set Identifier
compilerUniverse   = forall k a. Map k a -> Set k
Map.keysSet Map Identifier (Compiler SomeItem)
universe
            , compilerRoutes :: Routes
compilerRoutes     = Routes
routes
            , compilerStore :: Store
compilerStore      = Store
store
            , compilerLogger :: Logger
compilerLogger     = Logger
logger
            }
    CompilerResult SomeItem
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Compiler a -> CompilerRead -> IO (CompilerResult a)
runCompiler Compiler SomeItem
compiler CompilerRead
cread
    case CompilerResult SomeItem
result of
        CompilerError CompilerErrors FilePath
e -> do
            let msgs :: [FilePath]
msgs = case forall a. CompilerErrors a -> [a]
compilerErrorMessages CompilerErrors FilePath
e of
                    [] -> [FilePath
"Compiler failed but no info given, try running with -v?"]
                    [FilePath]
es -> [FilePath]
es
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
msgs forall a b. (a -> b) -> a -> b
$ \FilePath
msg -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$
                Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (forall a. a -> Maybe a
Just Identifier
id') FilePath
msg
            forall (m :: * -> *) a. Monad m => a -> m a
return SchedulerStep
SchedulerError

        CompilerSnapshot FilePath
snapshot Compiler SomeItem
c ->
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$
            Identifier
-> FilePath
-> Compiler SomeItem
-> Scheduler
-> (Scheduler, SchedulerStep)
schedulerSnapshot Identifier
id' FilePath
snapshot Compiler SomeItem
c

        CompilerDone (SomeItem Item a
item) CompilerWrite
cwrite -> do
            -- Print some info
            let facts :: [Dependency]
facts = CompilerWrite -> [Dependency]
compilerDependencies CompilerWrite
cwrite
                cacheHits :: FilePath
cacheHits
                    | CompilerWrite -> Int
compilerCacheHits CompilerWrite
cwrite forall a. Ord a => a -> a -> Bool
<= Int
0 = FilePath
"updated"
                    | Bool
otherwise                     = FilePath
"cached "
            forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger forall a b. (a -> b) -> a -> b
$ FilePath
cacheHits forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Identifier
id'

            -- Sanity check
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Item a -> Identifier
itemIdentifier Item a
item forall a. Eq a => a -> a -> Bool
== Identifier
id') forall a b. (a -> b) -> a -> b
$
                forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$ Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError
                    (forall a. a -> Maybe a
Just Identifier
id') forall a b. (a -> b) -> a -> b
$
                    FilePath
"The compiler yielded an Item with Identifier " forall a. [a] -> [a] -> [a]
++
                    forall a. Show a => a -> FilePath
show (forall a. Item a -> Identifier
itemIdentifier Item a
item) forall a. [a] -> [a] -> [a]
++ FilePath
", but we were expecting " forall a. [a] -> [a] -> [a]
++
                    FilePath
"an Item with Identifier " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Identifier
id' forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++
                    FilePath
"(you probably want to call makeItem to solve this problem)"

            -- Write if necessary
            (Maybe FilePath
mroute, Bool
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Routes -> Provider -> Identifier -> IO (Maybe FilePath, Bool)
runRoutes Routes
routes Provider
provider Identifier
id'
            case Maybe FilePath
mroute of
                Maybe FilePath
Nothing    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just FilePath
route -> do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$
                        Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerRoute Identifier
id' FilePath
route
                    let path :: FilePath
path = Configuration -> FilePath
destinationDirectory Configuration
config FilePath -> ShowS
</> FilePath
route
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
makeDirectories FilePath
path
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Writable a => FilePath -> Item a -> IO ()
write FilePath
path Item a
item
                    forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.debug Logger
logger forall a b. (a -> b) -> a -> b
$ FilePath
"Routed to " forall a. [a] -> [a] -> [a]
++ FilePath
path

            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (Binary a, Typeable a) => Store -> Item a -> IO ()
save Store
store Item a
item
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$
                Identifier
-> [Dependency] -> Scheduler -> (Scheduler, SchedulerStep)
schedulerWrite Identifier
id' [Dependency]
facts

        CompilerRequire [(Identifier, FilePath)]
reqs Compiler SomeItem
c ->
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler forall a b. (a -> b) -> a -> b
$
            Identifier
-> [(Identifier, FilePath)]
-> Compiler SomeItem
-> Scheduler
-> (Scheduler, SchedulerStep)
schedulerBlock Identifier
id' [(Identifier, FilePath)]
reqs Compiler SomeItem
c