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


--------------------------------------------------------------------------------
import           Control.Concurrent            (forkIO, getNumCapabilities,
                                                rtsSupportsBoundThreads)
import qualified Control.Concurrent.MVar       as MVar
import           Control.Exception             (SomeException, try)
import           Control.Monad                 (replicateM_, unless, void, when)
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                     (intercalate)
#if !(MIN_VERSION_base(4,20,0))
import           Data.List                     (foldl')
#endif
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
(Int -> RunMode -> ShowS)
-> (RunMode -> FilePath) -> ([RunMode] -> ShowS) -> Show RunMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunMode -> ShowS
showsPrec :: Int -> RunMode -> ShowS
$cshow :: RunMode -> FilePath
show :: RunMode -> FilePath
$cshowList :: [RunMode] -> ShowS
showList :: [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
    Logger -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Initialising..."
    Logger -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger FilePath
"Creating store..."
    store <- Bool -> FilePath -> IO Store
Store.new (Configuration -> Bool
inMemoryCache Configuration
config) (FilePath -> IO Store) -> FilePath -> IO Store
forall a b. (a -> b) -> a -> b
$ Configuration -> FilePath
storeDirectory Configuration
config
    Logger.message logger "Creating provider..."
    provider <- newProvider store (shouldIgnoreFile config) $
        providerDirectory config
    Logger.message logger "Running rules..."
    ruleSet  <- runRules rules provider

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

    -- Build runtime read/state
    scheduler <- IORef.newIORef $ emptyScheduler {schedulerFacts = oldFacts}
    let compilers = RuleSet -> [(Identifier, Compiler SomeItem)]
rulesCompilers RuleSet
ruleSet
        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      = [(Identifier, Compiler SomeItem)]
-> Map Identifier (Compiler SomeItem)
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
    runReaderT (build mode) read'
    errors <- schedulerErrors <$> IORef.readIORef scheduler
    if null errors then do
        Logger.debug logger "Removing tmp directory..."
        removeDirectory $ tmpDirectory config

        Logger.flush logger
        return (ExitSuccess, ruleSet)
    else do
        for_ errors $ \(Maybe Identifier
mbId, FilePath
err) -> Logger -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.error Logger
logger (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe Identifier
mbId of
            Just Identifier
identifier -> Identifier -> FilePath
forall a. Show a => a -> FilePath
show Identifier
identifier FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
err
            Maybe Identifier
Nothing         -> FilePath
err
        Logger.flush logger
        return (ExitFailure 1, 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
[(Maybe Identifier, FilePath)]
Map FilePath Identifier
DependencyFacts
Map Identifier (Set Identifier)
Map Identifier (Compiler SomeItem)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
forall {a}. [a]
forall {a}. Set a
forall {a}. Seq a
forall {k} {a}. Map k a
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerTodo :: forall {k} {a}. Map k a
schedulerDone :: forall {a}. Set a
schedulerQueue :: forall {a}. Seq a
schedulerWorking :: forall {a}. Set a
schedulerSnapshots :: forall {a}. Set a
schedulerRoutes :: forall {k} {a}. Map k a
schedulerBlocked :: forall {a}. Set a
schedulerTriggers :: forall {k} {a}. Map k a
schedulerStarved :: Int
schedulerFacts :: forall {k} {a}. Map k a
schedulerErrors :: forall {a}. [a]
..}
  where
    schedulerTodo :: Map k a
schedulerTodo      = Map k a
forall {k} {a}. Map k a
Map.empty
    schedulerDone :: Set a
schedulerDone      = Set a
forall {a}. Set a
Set.empty
    schedulerQueue :: Seq a
schedulerQueue     = Seq a
forall {a}. Seq a
Seq.empty
    schedulerWorking :: Set a
schedulerWorking   = Set a
forall {a}. Set a
Set.empty
    schedulerSnapshots :: Set a
schedulerSnapshots = Set a
forall {a}. Set a
Set.empty
    schedulerRoutes :: Map k a
schedulerRoutes    = Map k a
forall {k} {a}. Map k a
Map.empty
    schedulerBlocked :: Set a
schedulerBlocked   = Set a
forall {a}. Set a
Set.empty
    schedulerTriggers :: Map k a
schedulerTriggers  = Map k a
forall {k} {a}. Map k a
Map.empty
    schedulerStarved :: Int
schedulerStarved   = Int
0
    schedulerFacts :: Map k a
schedulerFacts     = Map k a
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 = (i, e) : schedulerErrors 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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..} =
    ( Scheduler
scheduler
        { schedulerQueue = schedulerQueue <> Seq.fromList (Map.keys todo)
        , schedulerDone  = schedulerDone <>
            (Map.keysSet universe `Set.difference` ood)
        , schedulerTodo  = schedulerTodo <> todo
        , schedulerFacts = facts'
        }
    , [FilePath]
msgs
    )
  where
    (Set Identifier
ood, DependencyFacts
facts', [FilePath]
msgs) = [Identifier]
-> Set Identifier
-> DependencyFacts
-> (Set Identifier, DependencyFacts, [FilePath])
outOfDate (Map Identifier (Compiler SomeItem) -> [Identifier]
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 = (Identifier -> Compiler SomeItem -> Bool)
-> Map Identifier (Compiler SomeItem)
-> Map Identifier (Compiler SomeItem)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Identifier
id' Compiler SomeItem
_ -> Identifier
id' Identifier -> Set Identifier -> Bool
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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..} = case Seq Identifier -> ViewL Identifier
forall a. Seq a -> ViewL a
Seq.viewl Seq Identifier
schedulerQueue of
    ViewL Identifier
Seq.EmptyL
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set Identifier -> Bool
forall a. Set a -> Bool
Set.null Set Identifier
schedulerWorking ->
            ( Scheduler
scheduler {schedulerStarved = schedulerStarved + 1}
            , SchedulerStep
SchedulerStarve
            )
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set Identifier -> Bool
forall a. Set a -> Bool
Set.null Set Identifier
schedulerBlocked ->
            let cycles :: [[Identifier]]
cycles = Scheduler -> [[Identifier]]
schedulerCycles Scheduler
scheduler
                msg :: FilePath
msg | [[Identifier]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Identifier]]
cycles = FilePath
"Possible dependency cycle in: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                        FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (Identifier -> FilePath
forall a. Show a => a -> FilePath
show (Identifier -> FilePath) -> [Identifier] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Identifier -> [Identifier]
forall a. Set a -> [a]
Set.toList Set Identifier
schedulerBlocked)
                    | Bool
otherwise = FilePath
"Dependency cycles: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                        FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"; "
                            (([Identifier] -> FilePath) -> [[Identifier]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" -> " ([FilePath] -> FilePath)
-> ([Identifier] -> [FilePath]) -> [Identifier] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> FilePath) -> [Identifier] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> FilePath
forall a. Show a => a -> FilePath
show) [[Identifier]]
cycles) in
            SchedulerStep
SchedulerError SchedulerStep -> (Scheduler, ()) -> (Scheduler, SchedulerStep)
forall a b. a -> (Scheduler, b) -> (Scheduler, a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError Maybe Identifier
forall a. Maybe a
Nothing FilePath
msg Scheduler
scheduler
        | Bool
otherwise -> (Scheduler
scheduler, SchedulerStep
SchedulerFinish)
    Identifier
x Seq.:< Seq Identifier
xs
        | Identifier
x Identifier -> Set Identifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerDone ->
            Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler {schedulerQueue = xs}
        | Identifier
x Identifier -> Set Identifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerWorking ->
            Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler {schedulerQueue = xs}
        | Identifier
x Identifier -> Set Identifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerBlocked ->
            Scheduler -> (Scheduler, SchedulerStep)
schedulerPop Scheduler
scheduler {schedulerQueue = xs}
        | Bool
otherwise -> case Identifier
-> Map Identifier (Compiler SomeItem) -> Maybe (Compiler SomeItem)
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 SchedulerStep -> (Scheduler, ()) -> (Scheduler, SchedulerStep)
forall a b. a -> (Scheduler, b) -> (Scheduler, a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
                Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
x) FilePath
"Compiler not found" Scheduler
scheduler
            Just Compiler SomeItem
c  ->
                ( Scheduler
scheduler
                    { schedulerQueue   = xs
                    , schedulerWorking = Set.insert x 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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..} =
    [[Identifier]
c | Graph.CyclicSCC [Identifier]
c <- [(Identifier, Identifier, [Identifier])] -> [SCC Identifier]
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, Set Identifier -> [Identifier]
forall a. Set a -> [a]
Set.toList Set Identifier
ys) | (Identifier
x, Set Identifier
ys) <- Map Identifier (Set Identifier) -> [(Identifier, Set Identifier)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Identifier (Set Identifier)
edges]
    edges :: Map Identifier (Set Identifier)
edges = (Set Identifier -> Set Identifier -> Set Identifier)
-> [(Identifier, Set Identifier)]
-> Map Identifier (Set Identifier)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Identifier -> Set Identifier -> Set Identifier
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(Identifier, Set Identifier)] -> Map Identifier (Set Identifier))
-> [(Identifier, Set Identifier)]
-> Map Identifier (Set Identifier)
forall a b. (a -> b) -> a -> b
$ do
        (dep, xs) <- Map Identifier (Set Identifier) -> [(Identifier, Set Identifier)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Identifier (Set Identifier) -> [(Identifier, Set Identifier)])
-> Map Identifier (Set Identifier)
-> [(Identifier, Set Identifier)]
forall a b. (a -> b) -> a -> b
$ Map Identifier (Set Identifier)
schedulerTriggers
        x <- Set.toList xs
        pure (x, Set.singleton 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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..}
    | [(Identifier, FilePath)] -> Bool
forall a. [a] -> Bool
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 (Scheduler -> (Scheduler, SchedulerStep))
-> Scheduler -> (Scheduler, SchedulerStep)
forall a b. (a -> b) -> a -> b
$ Scheduler
scheduler
         { schedulerQueue    =
             -- Optimization: move deps to the front and item to the back
             Seq.fromList depIds <>
             schedulerQueue <>
             Seq.singleton identifier
         , schedulerTodo     =
             Map.insert identifier
                 (Compiler $ \CompilerRead
_ -> CompilerResult SomeItem -> IO (CompilerResult SomeItem)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompilerResult SomeItem -> IO (CompilerResult SomeItem))
-> CompilerResult SomeItem -> IO (CompilerResult SomeItem)
forall a b. (a -> b) -> a -> b
$ [(Identifier, FilePath)]
-> Compiler SomeItem -> CompilerResult SomeItem
forall a.
[(Identifier, FilePath)] -> Compiler a -> CompilerResult a
CompilerRequire [(Identifier, FilePath)]
deps0 Compiler SomeItem
compiler)
                 schedulerTodo
         , schedulerWorking  = Set.delete identifier schedulerWorking
         , schedulerBlocked  = Set.insert identifier schedulerBlocked
         , schedulerTriggers = foldl'
             (\Map Identifier (Set Identifier)
acc (Identifier
depId, FilePath
_) ->
                 (Set Identifier -> Set Identifier -> Set Identifier)
-> Identifier
-> Set Identifier
-> Map Identifier (Set Identifier)
-> Map Identifier (Set Identifier)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set Identifier -> Set Identifier -> Set Identifier
forall a. Ord a => Set a -> Set a -> Set a
Set.union Identifier
depId (Identifier -> Set Identifier
forall a. a -> Set a
Set.singleton Identifier
identifier) Map Identifier (Set Identifier)
acc)
             schedulerTriggers
             deps1
         }
  where
    deps1 :: [(Identifier, FilePath)]
deps1  = ((Identifier, FilePath) -> Bool)
-> [(Identifier, FilePath)] -> [(Identifier, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Identifier, FilePath) -> Bool)
-> (Identifier, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, FilePath) -> Bool
done) [(Identifier, FilePath)]
deps0
    depIds :: [Identifier]
depIds = ((Identifier, FilePath) -> Identifier)
-> [(Identifier, FilePath)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, FilePath) -> Identifier
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 Identifier -> Set Identifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Identifier
schedulerDone Bool -> Bool -> Bool
||
        (Identifier
depId, FilePath
depSnapshot) (Identifier, FilePath) -> Set (Identifier, FilePath) -> Bool
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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..} =
    ( Scheduler
scheduler
        { schedulerQueue    =
            schedulerQueue <> Seq.fromList (Set.toList triggered)
        , schedulerStarved  = 0
        , schedulerBlocked  = Set.delete identifier $
            schedulerBlocked `Set.difference` triggered
        , schedulerTriggers = Map.delete identifier schedulerTriggers
        }
    , Int
schedulerStarved
    )
  where
    triggered :: Set Identifier
triggered = Set Identifier -> Maybe (Set Identifier) -> Set Identifier
forall a. a -> Maybe a -> a
fromMaybe Set Identifier
forall {a}. Set a
Set.empty (Maybe (Set Identifier) -> Set Identifier)
-> Maybe (Set Identifier) -> Set Identifier
forall a b. (a -> b) -> a -> b
$ Identifier
-> Map Identifier (Set Identifier) -> Maybe (Set Identifier)
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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..} =
    let (Scheduler
scheduler', Int
resume) = Identifier -> Scheduler -> (Scheduler, Int)
schedulerUnblock Identifier
identifier Scheduler
scheduler
            { schedulerSnapshots =
                Set.insert (identifier, snapshot) 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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..} =
    let (Scheduler
scheduler1, Int
resume) = Identifier -> Scheduler -> (Scheduler, Int)
schedulerUnblock Identifier
identifier Scheduler
scheduler0
            { schedulerWorking = Set.delete identifier schedulerWorking
            , schedulerFacts   = Map.insert identifier depFacts schedulerFacts
            , schedulerDone    =
                Set.insert identifier schedulerDone
            , schedulerTodo    =
                Map.delete identifier 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 Int -> Int -> Int
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)
Set (Identifier, FilePath)
Set Identifier
Seq Identifier
schedulerFacts :: Scheduler -> DependencyFacts
schedulerErrors :: Scheduler -> [(Maybe Identifier, FilePath)]
schedulerQueue :: Scheduler -> Seq Identifier
schedulerTodo :: Scheduler -> Map Identifier (Compiler SomeItem)
schedulerWorking :: Scheduler -> Set Identifier
schedulerDone :: Scheduler -> Set Identifier
schedulerSnapshots :: Scheduler -> Set (Identifier, FilePath)
schedulerRoutes :: Scheduler -> Map FilePath Identifier
schedulerBlocked :: Scheduler -> Set Identifier
schedulerTriggers :: Scheduler -> Map Identifier (Set Identifier)
schedulerStarved :: Scheduler -> Int
schedulerQueue :: Seq Identifier
schedulerTodo :: Map Identifier (Compiler SomeItem)
schedulerWorking :: Set Identifier
schedulerDone :: Set Identifier
schedulerSnapshots :: Set (Identifier, FilePath)
schedulerRoutes :: Map FilePath Identifier
schedulerBlocked :: Set Identifier
schedulerTriggers :: Map Identifier (Set Identifier)
schedulerStarved :: Int
schedulerFacts :: DependencyFacts
schedulerErrors :: [(Maybe Identifier, FilePath)]
..}
    | Just Identifier
id1 <- FilePath -> Map FilePath Identifier -> Maybe Identifier
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
path Map FilePath Identifier
schedulerRoutes, Identifier
id0 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
/= Identifier
id1 =
        let msg :: FilePath
msg = FilePath
"multiple writes for route " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
                Identifier -> FilePath
forall a. Show a => a -> FilePath
show Identifier
id0 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" and " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> FilePath
forall a. Show a => a -> FilePath
show Identifier
id1 in
        Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
id0) FilePath
msg Scheduler
scheduler0
    | Bool
otherwise =
        let routes :: Map FilePath Identifier
routes = FilePath
-> Identifier -> Map FilePath Identifier -> Map FilePath Identifier
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 = routes}, ())


--------------------------------------------------------------------------------
build :: RunMode -> ReaderT RuntimeRead IO ()
build :: RunMode -> ReaderT RuntimeRead IO ()
build RunMode
mode = do
    logger <- RuntimeRead -> Logger
runtimeLogger (RuntimeRead -> Logger)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RuntimeRead IO RuntimeRead
forall r (m :: * -> *). MonadReader r m => m r
ask
    Logger.header logger "Checking for out-of-date items"
    schedulerRef <- runtimeScheduler <$> ask
    scheduleOutOfDate
    case mode of
        RunMode
RunModeNormal -> do
            Logger -> FilePath -> ReaderT RuntimeRead IO ()
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
            errs <- IO [(Maybe Identifier, FilePath)]
-> ReaderT RuntimeRead IO [(Maybe Identifier, FilePath)]
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Maybe Identifier, FilePath)]
 -> ReaderT RuntimeRead IO [(Maybe Identifier, FilePath)])
-> IO [(Maybe Identifier, FilePath)]
-> ReaderT RuntimeRead IO [(Maybe Identifier, FilePath)]
forall a b. (a -> b) -> a -> b
$ Scheduler -> [(Maybe Identifier, FilePath)]
schedulerErrors (Scheduler -> [(Maybe Identifier, FilePath)])
-> IO Scheduler -> IO [(Maybe Identifier, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Scheduler -> IO Scheduler
forall a. IORef a -> IO a
IORef.readIORef IORef Scheduler
schedulerRef
            when (null errs) $ Logger.header logger "Success"
            facts <- liftIO $ schedulerFacts <$> IORef.readIORef schedulerRef
            store <- runtimeStore <$> ask
            liftIO $ Store.set store factsKey facts
        RunMode
RunModePrintOutOfDate -> do
            Logger -> FilePath -> ReaderT RuntimeRead IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Out of date items:"
            todo <- IO (Map Identifier (Compiler SomeItem))
-> ReaderT RuntimeRead IO (Map Identifier (Compiler SomeItem))
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Identifier (Compiler SomeItem))
 -> ReaderT RuntimeRead IO (Map Identifier (Compiler SomeItem)))
-> IO (Map Identifier (Compiler SomeItem))
-> ReaderT RuntimeRead IO (Map Identifier (Compiler SomeItem))
forall a b. (a -> b) -> a -> b
$ Scheduler -> Map Identifier (Compiler SomeItem)
schedulerTodo (Scheduler -> Map Identifier (Compiler SomeItem))
-> IO Scheduler -> IO (Map Identifier (Compiler SomeItem))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Scheduler -> IO Scheduler
forall a. IORef a -> IO a
IORef.readIORef IORef Scheduler
schedulerRef
            traverse_ (Logger.message logger . show) (Map.keys todo)


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

    -- Print messages
    mapM_ (Logger.debug logger) msgs


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


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

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

            go :: SchedulerStep -> IO ()
            go SchedulerStep
step = case SchedulerStep
step of
                SchedulerStep
SchedulerFinish       -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
signal ()
                SchedulerStep
SchedulerStarve       -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                SchedulerStep
SchedulerError        -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
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
                    step' <- ReaderT RuntimeRead IO SchedulerStep
-> RuntimeRead -> IO SchedulerStep
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
                    go step'

        spawnN numThreads
        MVar.readMVar 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    <- RuntimeRead -> Logger
runtimeLogger        (RuntimeRead -> Logger)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RuntimeRead IO RuntimeRead
forall r (m :: * -> *). MonadReader r m => m r
ask
    provider  <- runtimeProvider      <$> ask
    universe  <- runtimeUniverse      <$> ask
    routes    <- runtimeRoutes        <$> ask
    store     <- runtimeStore         <$> ask
    config    <- runtimeConfiguration <$> ask
    scheduler <- runtimeScheduler     <$> ask

    let cread = CompilerRead
            { compilerConfig :: Configuration
compilerConfig     = Configuration
config
            , compilerUnderlying :: Identifier
compilerUnderlying = Identifier
id'
            , compilerProvider :: Provider
compilerProvider   = Provider
provider
            , compilerUniverse :: Set Identifier
compilerUniverse   = Map Identifier (Compiler SomeItem) -> Set Identifier
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
            }
    result <- liftIO $ runCompiler compiler cread
    case result of
        CompilerError CompilerErrors FilePath
e -> do
            let msgs :: [FilePath]
msgs = case CompilerErrors FilePath -> [FilePath]
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
            [FilePath]
-> (FilePath -> ReaderT RuntimeRead IO ())
-> ReaderT RuntimeRead IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
msgs ((FilePath -> ReaderT RuntimeRead IO ())
 -> ReaderT RuntimeRead IO ())
-> (FilePath -> ReaderT RuntimeRead IO ())
-> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
msg -> IO () -> ReaderT RuntimeRead IO ()
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT RuntimeRead IO ())
-> ((Scheduler -> (Scheduler, ())) -> IO ())
-> (Scheduler -> (Scheduler, ()))
-> ReaderT RuntimeRead IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Scheduler -> (Scheduler -> (Scheduler, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler ((Scheduler -> (Scheduler, ())) -> ReaderT RuntimeRead IO ())
-> (Scheduler -> (Scheduler, ())) -> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$
                Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
id') FilePath
msg
            SchedulerStep -> ReaderT RuntimeRead IO SchedulerStep
forall a. a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SchedulerStep
SchedulerError

        CompilerSnapshot FilePath
snapshot Compiler SomeItem
c ->
            IO SchedulerStep -> ReaderT RuntimeRead IO SchedulerStep
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchedulerStep -> ReaderT RuntimeRead IO SchedulerStep)
-> ((Scheduler -> (Scheduler, SchedulerStep)) -> IO SchedulerStep)
-> (Scheduler -> (Scheduler, SchedulerStep))
-> ReaderT RuntimeRead IO SchedulerStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Scheduler
-> (Scheduler -> (Scheduler, SchedulerStep)) -> IO SchedulerStep
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler ((Scheduler -> (Scheduler, SchedulerStep))
 -> ReaderT RuntimeRead IO SchedulerStep)
-> (Scheduler -> (Scheduler, SchedulerStep))
-> ReaderT RuntimeRead IO SchedulerStep
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = FilePath
"updated"
                    | Bool
otherwise                     = FilePath
"cached "
            Logger -> FilePath -> ReaderT RuntimeRead IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger (FilePath -> ReaderT RuntimeRead IO ())
-> FilePath -> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
cacheHits FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> FilePath
forall a. Show a => a -> FilePath
show Identifier
id'

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

            -- Write if necessary.  Note that we want another exception handler
            -- around this: some compilers may successfully produce a
            -- 'CompilerResult', but the thing they are supposed to 'write' can
            -- have an un-evaluated 'error' them.
            routeOrErr <- IO (Either SomeException (Maybe FilePath))
-> ReaderT RuntimeRead IO (Either SomeException (Maybe FilePath))
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException (Maybe FilePath))
 -> ReaderT RuntimeRead IO (Either SomeException (Maybe FilePath)))
-> IO (Either SomeException (Maybe FilePath))
-> ReaderT RuntimeRead IO (Either SomeException (Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ IO (Maybe FilePath) -> IO (Either SomeException (Maybe FilePath))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe FilePath) -> IO (Either SomeException (Maybe FilePath)))
-> IO (Maybe FilePath)
-> IO (Either SomeException (Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ do
                (mroute, _) <- Routes -> Provider -> Identifier -> IO (Maybe FilePath, Bool)
runRoutes Routes
routes Provider
provider Identifier
id'
                for_ mroute $ \FilePath
route -> do
                    IORef Scheduler -> (Scheduler -> (Scheduler, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler ((Scheduler -> (Scheduler, ())) -> IO ())
-> (Scheduler -> (Scheduler, ())) -> IO ()
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
                    FilePath -> IO ()
makeDirectories FilePath
path
                    FilePath -> Item a -> IO ()
forall a. Writable a => FilePath -> Item a -> IO ()
write FilePath
path Item a
item
                save store item
                pure mroute

            case routeOrErr of
                Left SomeException
e -> do
                    IO () -> ReaderT RuntimeRead IO ()
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT RuntimeRead IO ())
-> IO () -> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$ IORef Scheduler -> (Scheduler -> (Scheduler, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler ((Scheduler -> (Scheduler, ())) -> IO ())
-> (Scheduler -> (Scheduler, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$
                        Maybe Identifier -> FilePath -> Scheduler -> (Scheduler, ())
schedulerError (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
id') (FilePath -> Scheduler -> (Scheduler, ()))
-> FilePath -> Scheduler -> (Scheduler, ())
forall a b. (a -> b) -> a -> b
$
                        FilePath
"An exception was thrown when persisting " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
                        FilePath
"the compiler result: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show (SomeException
e :: SomeException)
                    SchedulerStep -> ReaderT RuntimeRead IO SchedulerStep
forall a. a -> ReaderT RuntimeRead IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SchedulerStep
SchedulerError
                Right Maybe FilePath
mroute -> do
                    Maybe FilePath
-> (FilePath -> ReaderT RuntimeRead IO ())
-> ReaderT RuntimeRead IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FilePath
mroute ((FilePath -> ReaderT RuntimeRead IO ())
 -> ReaderT RuntimeRead IO ())
-> (FilePath -> ReaderT RuntimeRead IO ())
-> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
route ->
                        Logger -> FilePath -> ReaderT RuntimeRead IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.debug Logger
logger (FilePath -> ReaderT RuntimeRead IO ())
-> FilePath -> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Routed to " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
route
                    IO SchedulerStep -> ReaderT RuntimeRead IO SchedulerStep
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchedulerStep -> ReaderT RuntimeRead IO SchedulerStep)
-> ((Scheduler -> (Scheduler, SchedulerStep)) -> IO SchedulerStep)
-> (Scheduler -> (Scheduler, SchedulerStep))
-> ReaderT RuntimeRead IO SchedulerStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Scheduler
-> (Scheduler -> (Scheduler, SchedulerStep)) -> IO SchedulerStep
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
scheduler ((Scheduler -> (Scheduler, SchedulerStep))
 -> ReaderT RuntimeRead IO SchedulerStep)
-> (Scheduler -> (Scheduler, SchedulerStep))
-> ReaderT RuntimeRead IO SchedulerStep
forall a b. (a -> b) -> a -> b
$
                        Identifier
-> [Dependency] -> Scheduler -> (Scheduler, SchedulerStep)
schedulerWrite Identifier
id' [Dependency]
facts

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