--------------------------------------------------------------------------------
{-# 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
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 -> FilePath -> IO ()
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) (FilePath -> IO Provider) -> FilePath -> IO Provider
forall a b. (a -> b) -> a -> b
$
        Configuration -> FilePath
providerDirectory Configuration
config
    Logger -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger FilePath
"Running rules..."
    RuleSet
ruleSet  <- Rules a -> Provider -> IO RuleSet
forall a. Rules a -> Provider -> IO RuleSet
runRules Rules a
rules Provider
provider

    -- Get old facts
    Result DependencyFacts
mOldFacts <- Store -> [FilePath] -> IO (Result DependencyFacts)
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
_             -> DependencyFacts
forall a. Monoid a => a
mempty

    -- Build runtime read/state
    IORef Scheduler
scheduler <- Scheduler -> IO (IORef Scheduler)
forall a. a -> IO (IORef a)
IORef.newIORef (Scheduler -> IO (IORef Scheduler))
-> Scheduler -> IO (IORef Scheduler)
forall a b. (a -> b) -> a -> b
$ Scheduler
emptyScheduler {schedulerFacts = 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      = [(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
    ReaderT RuntimeRead IO () -> RuntimeRead -> IO ()
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 (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
scheduler
    if [(Maybe Identifier, FilePath)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe Identifier, FilePath)]
errors then do
        Logger -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.debug Logger
logger FilePath
"Removing tmp directory..."
        FilePath -> IO ()
removeDirectory (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Configuration -> FilePath
tmpDirectory Configuration
config

        Logger -> forall (m :: * -> *). MonadIO m => m ()
Logger.flush Logger
logger
        (ExitCode, RuleSet) -> IO (ExitCode, RuleSet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, RuleSet
ruleSet)
    else do
        [(Maybe Identifier, FilePath)]
-> ((Maybe Identifier, FilePath) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Maybe Identifier, FilePath)]
errors (((Maybe Identifier, FilePath) -> IO ()) -> IO ())
-> ((Maybe Identifier, FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(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 -> forall (m :: * -> *). MonadIO m => m ()
Logger.flush Logger
logger
        (ExitCode, RuleSet) -> IO (ExitCode, RuleSet)
forall a. a -> IO a
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
[(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
        (Identifier
dep, Set Identifier
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
        Identifier
x <- Set Identifier -> [Identifier]
forall a. Set a -> [a]
Set.toList Set Identifier
xs
        (Identifier, Set Identifier) -> [(Identifier, Set Identifier)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Identifier
x, Identifier -> Set Identifier
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)
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
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 -> FilePath -> ReaderT RuntimeRead IO ()
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 (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
    ReaderT RuntimeRead IO ()
scheduleOutOfDate
    case RunMode
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
            [(Maybe Identifier, FilePath)]
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
            Bool -> ReaderT RuntimeRead IO () -> ReaderT RuntimeRead IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Maybe Identifier, FilePath)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe Identifier, FilePath)]
errs) (ReaderT RuntimeRead IO () -> ReaderT RuntimeRead IO ())
-> ReaderT RuntimeRead IO () -> ReaderT RuntimeRead IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> FilePath -> ReaderT RuntimeRead IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.header Logger
logger FilePath
"Success"
            DependencyFacts
facts <- IO DependencyFacts -> ReaderT RuntimeRead IO DependencyFacts
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DependencyFacts -> ReaderT RuntimeRead IO DependencyFacts)
-> IO DependencyFacts -> ReaderT RuntimeRead IO DependencyFacts
forall a b. (a -> b) -> a -> b
$ Scheduler -> DependencyFacts
schedulerFacts (Scheduler -> DependencyFacts)
-> IO Scheduler -> IO DependencyFacts
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
            Store
store <- RuntimeRead -> Store
runtimeStore (RuntimeRead -> Store)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Store
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
            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
$ Store -> [FilePath] -> DependencyFacts -> IO ()
forall a.
(Binary a, Typeable a) =>
Store -> [FilePath] -> a -> IO ()
Store.set Store
store [FilePath]
factsKey DependencyFacts
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:"
            Map Identifier (Compiler SomeItem)
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
            (Identifier -> ReaderT RuntimeRead IO ())
-> [Identifier] -> ReaderT RuntimeRead IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Logger -> FilePath -> ReaderT RuntimeRead IO ()
forall (m :: * -> *). MonadIO m => Logger -> FilePath -> m ()
Logger.message Logger
logger (FilePath -> ReaderT RuntimeRead IO ())
-> (Identifier -> FilePath)
-> Identifier
-> ReaderT RuntimeRead IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> FilePath
forall a. Show a => a -> FilePath
show) (Map Identifier (Compiler SomeItem) -> [Identifier]
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    (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
provider     <- RuntimeRead -> Provider
runtimeProvider  (RuntimeRead -> Provider)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Provider
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
    Map Identifier (Compiler SomeItem)
universe     <- RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse  (RuntimeRead -> Map Identifier (Compiler SomeItem))
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO (Map Identifier (Compiler SomeItem))
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
    IORef Scheduler
schedulerRef <- 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 modified :: Set Identifier
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)
    [FilePath]
msgs <- IO [FilePath] -> ReaderT RuntimeRead IO [FilePath]
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> ReaderT RuntimeRead IO [FilePath])
-> ((Scheduler -> (Scheduler, [FilePath])) -> IO [FilePath])
-> (Scheduler -> (Scheduler, [FilePath]))
-> ReaderT RuntimeRead IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Scheduler
-> (Scheduler -> (Scheduler, [FilePath])) -> IO [FilePath]
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Scheduler
schedulerRef ((Scheduler -> (Scheduler, [FilePath]))
 -> ReaderT RuntimeRead IO [FilePath])
-> (Scheduler -> (Scheduler, [FilePath]))
-> ReaderT RuntimeRead IO [FilePath]
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
    (FilePath -> ReaderT RuntimeRead IO ())
-> [FilePath] -> ReaderT RuntimeRead IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> FilePath -> ReaderT RuntimeRead IO ()
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 (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 -> ReaderT RuntimeRead IO ()
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?"
    SchedulerStep
pop <- 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
$ Scheduler -> (Scheduler, SchedulerStep)
schedulerPop
    SchedulerStep -> ReaderT RuntimeRead IO ()
go SchedulerStep
pop


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

        let spawnN :: Int -> IO ()
            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 -> 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
                    SchedulerStep
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
                    SchedulerStep -> IO ()
go SchedulerStep
step'

        Int -> IO ()
spawnN Int
numThreads
        MVar () -> IO ()
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        (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
provider  <- RuntimeRead -> Provider
runtimeProvider      (RuntimeRead -> Provider)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Provider
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
    Map Identifier (Compiler SomeItem)
universe  <- RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse      (RuntimeRead -> Map Identifier (Compiler SomeItem))
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO (Map Identifier (Compiler SomeItem))
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
    Routes
routes    <- RuntimeRead -> Routes
runtimeRoutes        (RuntimeRead -> Routes)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Routes
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
    Store
store     <- RuntimeRead -> Store
runtimeStore         (RuntimeRead -> Store)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Store
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
    Configuration
config    <- RuntimeRead -> Configuration
runtimeConfiguration (RuntimeRead -> Configuration)
-> ReaderT RuntimeRead IO RuntimeRead
-> ReaderT RuntimeRead IO Configuration
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
    IORef Scheduler
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 cread :: CompilerRead
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
            }
    CompilerResult SomeItem
result <- IO (CompilerResult SomeItem)
-> ReaderT RuntimeRead IO (CompilerResult SomeItem)
forall a. IO a -> ReaderT RuntimeRead IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CompilerResult SomeItem)
 -> ReaderT RuntimeRead IO (CompilerResult SomeItem))
-> IO (CompilerResult SomeItem)
-> ReaderT RuntimeRead IO (CompilerResult SomeItem)
forall a b. (a -> b) -> a -> b
$ Compiler SomeItem -> CompilerRead -> IO (CompilerResult SomeItem)
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 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.
            Either SomeException (Maybe FilePath)
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
                (Maybe FilePath
mroute, Bool
_) <- Routes -> Provider -> Identifier -> IO (Maybe FilePath, Bool)
runRoutes Routes
routes Provider
provider Identifier
id'
                Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FilePath
mroute ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
                Store -> Item a -> IO ()
forall a. (Binary a, Typeable a) => Store -> Item a -> IO ()
save Store
store Item a
item
                Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
mroute

            case Either SomeException (Maybe FilePath)
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