--------------------------------------------------------------------------------
module Hakyll.Core.Runtime
    ( run
    , RunMode(..)
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent.Async.Lifted (forConcurrently)
import           Control.Concurrent.MVar         (modifyMVar_, readMVar, newMVar, MVar)
import           Control.Monad                   (join, unless, when)
import           Control.Monad.Except            (ExceptT, runExceptT, throwError)
import           Control.Monad.Reader            (ReaderT, ask, runReaderT)
import           Control.Monad.Trans             (liftIO)
import           Data.Foldable                   (traverse_)
import           Data.List                       (intercalate)
import           Data.Map                        (Map)
import qualified Data.Map                        as M
import           Data.Set                        (Set)
import qualified Data.Set                        as S
import           Data.Traversable                (for)
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 :: [String]
factsKey = [String
"Hakyll.Core.Runtime.run", String
"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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunMode] -> ShowS
$cshowList :: [RunMode] -> ShowS
show :: RunMode -> String
$cshow :: RunMode -> String
showsPrec :: Int -> RunMode -> ShowS
$cshowsPrec :: Int -> RunMode -> ShowS
Show)


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

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

    MVar RuntimeState
state <- forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$ RuntimeState
            { runtimeDone :: Set Identifier
runtimeDone         = forall a. Set a
S.empty
            , runtimeSnapshots :: Set (Identifier, String)
runtimeSnapshots    = forall a. Set a
S.empty
            , runtimeTodo :: Map Identifier (Compiler SomeItem)
runtimeTodo         = forall k a. Map k a
M.empty
            , runtimeFacts :: DependencyFacts
runtimeFacts        = DependencyFacts
oldFacts
            , runtimeDependencies :: Map Identifier (Set (Identifier, String))
runtimeDependencies = forall k a. Map k a
M.empty
            }

    -- Build runtime read/state
    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
            , runtimeState :: MVar RuntimeState
runtimeState         = MVar RuntimeState
state
            , runtimeStore :: Store
runtimeStore         = Store
store
            , runtimeRoutes :: Routes
runtimeRoutes        = RuleSet -> Routes
rulesRoutes RuleSet
ruleSet
            , runtimeUniverse :: Map Identifier (Compiler SomeItem)
runtimeUniverse      = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Identifier, Compiler SomeItem)]
compilers
            }

    -- Run the program and fetch the resulting state
    Either String ()
result <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (RunMode -> Runtime ()
build RunMode
mode) RuntimeRead
read'
    case Either String ()
result of
        Left String
e          -> do
            forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.error Logger
logger String
e
            Logger -> IO ()
Logger.flush Logger
logger
            forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1, RuleSet
ruleSet)

        Right ()
_ -> do
            forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger String
"Removing tmp directory..."
            String -> IO ()
removeDirectory forall a b. (a -> b) -> a -> b
$ Configuration -> String
tmpDirectory Configuration
config

            Logger -> IO ()
Logger.flush Logger
logger
            forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, RuleSet
ruleSet)


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


--------------------------------------------------------------------------------
data RuntimeState = RuntimeState
    { RuntimeState -> Set Identifier
runtimeDone         :: Set Identifier
    , RuntimeState -> Set (Identifier, String)
runtimeSnapshots    :: Set (Identifier, Snapshot)
    , RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo         :: Map Identifier (Compiler SomeItem)
    , RuntimeState -> DependencyFacts
runtimeFacts        :: DependencyFacts
    , RuntimeState -> Map Identifier (Set (Identifier, String))
runtimeDependencies :: Map Identifier (Set (Identifier, Snapshot))
    }


--------------------------------------------------------------------------------
type Runtime a = ReaderT RuntimeRead (ExceptT String IO) a


--------------------------------------------------------------------------------
-- Because compilation of rules often revolves around IO,
-- be very careful when modifying the state
modifyRuntimeState :: (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState :: (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState RuntimeState -> RuntimeState
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeState -> RuntimeState
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeRead -> MVar RuntimeState
runtimeState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask


--------------------------------------------------------------------------------
getRuntimeState :: Runtime RuntimeState
getRuntimeState :: Runtime RuntimeState
getRuntimeState = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeRead -> MVar RuntimeState
runtimeState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask


--------------------------------------------------------------------------------
build :: RunMode -> Runtime ()
build :: RunMode -> Runtime ()
build RunMode
mode = do
    Logger
logger <- RuntimeRead -> Logger
runtimeLogger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.header Logger
logger String
"Checking for out-of-date items"
    Runtime ()
scheduleOutOfDate
    case RunMode
mode of
        RunMode
RunModeNormal -> do
            forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.header Logger
logger String
"Compiling"
            Runtime ()
pickAndChase
            forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.header Logger
logger String
"Success"
            DependencyFacts
facts <- RuntimeState -> DependencyFacts
runtimeFacts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Runtime RuntimeState
getRuntimeState
            Store
store <- RuntimeRead -> Store
runtimeStore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
Store.set Store
store [String]
factsKey DependencyFacts
facts
        RunMode
RunModePrintOutOfDate -> do
            forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.header Logger
logger String
"Out of date items:"
            Map Identifier (Compiler SomeItem)
todo <- RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Runtime RuntimeState
getRuntimeState
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.message Logger
logger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (forall k a. Map k a -> [k]
M.keys Map Identifier (Compiler SomeItem)
todo)


--------------------------------------------------------------------------------
scheduleOutOfDate :: Runtime ()
scheduleOutOfDate :: Runtime ()
scheduleOutOfDate = do
    Logger
logger   <- RuntimeRead -> Logger
runtimeLogger   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Provider
provider <- RuntimeRead -> Provider
runtimeProvider forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Map Identifier (Compiler SomeItem)
universe <- RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

    let identifiers :: [Identifier]
identifiers = forall k a. Map k a -> [k]
M.keys Map Identifier (Compiler SomeItem)
universe
        modified :: Set Identifier
modified    = forall a. (a -> Bool) -> Set a -> Set a
S.filter (Provider -> Identifier -> Bool
resourceModified Provider
provider) (forall k a. Map k a -> Set k
M.keysSet Map Identifier (Compiler SomeItem)
universe)

    RuntimeState
state <- Runtime RuntimeState
getRuntimeState
    let facts :: DependencyFacts
facts = RuntimeState -> DependencyFacts
runtimeFacts RuntimeState
state
        todo :: Map Identifier (Compiler SomeItem)
todo  = RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo RuntimeState
state
        done :: Set Identifier
done  = RuntimeState -> Set Identifier
runtimeDone RuntimeState
state

    let (Set Identifier
ood, DependencyFacts
facts', [String]
msgs) = [Identifier]
-> Set Identifier
-> DependencyFacts
-> (Set Identifier, DependencyFacts, [String])
outOfDate [Identifier]
identifiers Set Identifier
modified DependencyFacts
facts
        todo' :: Map Identifier (Compiler SomeItem)
todo'               = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Identifier
id' Compiler SomeItem
_ -> Identifier
id' forall a. Ord a => a -> Set a -> Bool
`S.member` Set Identifier
ood) Map Identifier (Compiler SomeItem)
universe
        done' :: Set Identifier
done'               = Set Identifier
done forall a. Ord a => Set a -> Set a -> Set a
`S.union` (forall k a. Map k a -> Set k
M.keysSet Map Identifier (Compiler SomeItem)
universe forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Identifier
ood)

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

    -- Update facts and todo items
    (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState forall a b. (a -> b) -> a -> b
$ \RuntimeState
s -> RuntimeState
s
        { runtimeDone :: Set Identifier
runtimeDone  = Set Identifier
done'
        , runtimeTodo :: Map Identifier (Compiler SomeItem)
runtimeTodo  = Map Identifier (Compiler SomeItem)
todo forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Identifier (Compiler SomeItem)
todo'
        , runtimeFacts :: DependencyFacts
runtimeFacts = DependencyFacts
facts'
        }


--------------------------------------------------------------------------------
pickAndChase :: Runtime ()
pickAndChase :: Runtime ()
pickAndChase = do
    Map Identifier (Compiler SomeItem)
todo <- RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Runtime RuntimeState
getRuntimeState
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Identifier (Compiler SomeItem)
todo) forall a b. (a -> b) -> a -> b
$ do
        Progress
acted <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadBaseControl IO m) =>
t a -> (a -> m b) -> m (t b)
forConcurrently (forall k a. Map k a -> [k]
M.keys Map Identifier (Compiler SomeItem)
todo) Identifier -> ReaderT RuntimeRead (ExceptT String IO) Progress
chase
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Progress
acted forall a. Eq a => a -> a -> Bool
== Progress
Idled) forall a b. (a -> b) -> a -> b
$ do
            -- This clause happens when chasing *every item* in `todo` resulted in 
            -- idling because tasks are all waiting on something: a dependency cycle  
            Map Identifier (Set (Identifier, String))
deps <- RuntimeState -> Map Identifier (Set (Identifier, String))
runtimeDependencies forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Runtime RuntimeState
getRuntimeState
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"Hakyll.Core.Runtime.pickAndChase: Dependency cycle detected: " forall a. [a] -> [a] -> [a]
++ 
                forall a. [a] -> [[a]] -> [a]
intercalate String
", " [forall a. Show a => a -> String
show Identifier
k forall a. [a] -> [a] -> [a]
++ String
" depends on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Set a -> [a]
S.toList Set (Identifier, String)
v) | (Identifier
k, Set (Identifier, String)
v) <- forall k a. Map k a -> [(k, a)]
M.toList Map Identifier (Set (Identifier, String))
deps]
        Runtime ()
pickAndChase


--------------------------------------------------------------------------------
-- | Tracks whether a set of tasks has progressed overall (at least one task progressed)
-- or has idled
data Progress = Progressed | Idled deriving (Progress -> Progress -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c== :: Progress -> Progress -> Bool
Eq)

instance Semigroup Progress where
    Progress
Idled      <> :: Progress -> Progress -> Progress
<> Progress
Idled      = Progress
Idled
    Progress
Progressed <> Progress
_          = Progress
Progressed
    Progress
_          <> Progress
Progressed = Progress
Progressed

instance Monoid Progress where
    mempty :: Progress
mempty = Progress
Idled


--------------------------------------------------------------------------------
chase :: Identifier -> Runtime Progress
chase :: Identifier -> ReaderT RuntimeRead (ExceptT String IO) Progress
chase Identifier
id' = do
    Logger
logger    <- RuntimeRead -> Logger
runtimeLogger        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Provider
provider  <- RuntimeRead -> Provider
runtimeProvider      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Map Identifier (Compiler SomeItem)
universe  <- RuntimeRead -> Map Identifier (Compiler SomeItem)
runtimeUniverse      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Routes
routes    <- RuntimeRead -> Routes
runtimeRoutes        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Store
store     <- RuntimeRead -> Store
runtimeStore         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    Configuration
config    <- RuntimeRead -> Configuration
runtimeConfiguration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

    RuntimeState
state     <- Runtime RuntimeState
getRuntimeState

    forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger forall a b. (a -> b) -> a -> b
$ String
"Processing " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
id'

    let compiler :: Compiler SomeItem
compiler = (RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo RuntimeState
state) forall k a. Ord k => Map k a -> k -> a
M.! Identifier
id'
        read' :: CompilerRead
read' = CompilerRead
            { compilerConfig :: Configuration
compilerConfig     = Configuration
config
            , compilerUnderlying :: Identifier
compilerUnderlying = Identifier
id'
            , compilerProvider :: Provider
compilerProvider   = Provider
provider
            , compilerUniverse :: Set Identifier
compilerUniverse   = forall k a. Map k a -> Set k
M.keysSet Map Identifier (Compiler SomeItem)
universe
            , compilerRoutes :: Routes
compilerRoutes     = Routes
routes
            , compilerStore :: Store
compilerStore      = Store
store
            , compilerLogger :: Logger
compilerLogger     = Logger
logger
            }

    CompilerResult SomeItem
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Compiler a -> CompilerRead -> IO (CompilerResult a)
runCompiler Compiler SomeItem
compiler CompilerRead
read'
    case CompilerResult SomeItem
result of
        -- Rethrow error
        CompilerError CompilerErrors String
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ case forall a. CompilerErrors a -> [a]
compilerErrorMessages CompilerErrors String
e of
            [] -> String
"Compiler failed but no info given, try running with -v?"
            [String]
es -> forall a. [a] -> [[a]] -> [a]
intercalate String
"; " [String]
es

        -- Signal that a snapshot was saved ->
        CompilerSnapshot String
snapshot Compiler SomeItem
c -> do
            -- Update info. The next 'chase' will pick us again at some
            -- point so we can continue then.
            (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState forall a b. (a -> b) -> a -> b
$ \RuntimeState
s -> RuntimeState
s
                { runtimeSnapshots :: Set (Identifier, String)
runtimeSnapshots = forall a. Ord a => a -> Set a -> Set a
S.insert (Identifier
id', String
snapshot) (RuntimeState -> Set (Identifier, String)
runtimeSnapshots RuntimeState
s)
                , runtimeTodo :: Map Identifier (Compiler SomeItem)
runtimeTodo      = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Identifier
id' Compiler SomeItem
c (RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo RuntimeState
s)
                }

            forall (m :: * -> *) a. Monad m => a -> m a
return Progress
Progressed


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

            -- Sanity check
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Item a -> Identifier
itemIdentifier Item a
item forall a. Eq a => a -> a -> Bool
== Identifier
id') forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
                String
"The compiler yielded an Item with Identifier " forall a. [a] -> [a] -> [a]
++
                forall a. Show a => a -> String
show (forall a. Item a -> Identifier
itemIdentifier Item a
item) forall a. [a] -> [a] -> [a]
++ String
", but we were expecting " forall a. [a] -> [a] -> [a]
++
                String
"an Item with Identifier " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
id' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
                String
"(you probably want to call makeItem to solve this problem)"

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

            -- Save! (For load)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (Binary a, Typeable a) => Store -> Item a -> IO ()
save Store
store Item a
item

            (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState forall a b. (a -> b) -> a -> b
$ \RuntimeState
s -> RuntimeState
s
                { runtimeDone :: Set Identifier
runtimeDone         = forall a. Ord a => a -> Set a -> Set a
S.insert Identifier
id' (RuntimeState -> Set Identifier
runtimeDone RuntimeState
s)
                , runtimeTodo :: Map Identifier (Compiler SomeItem)
runtimeTodo         = forall k a. Ord k => k -> Map k a -> Map k a
M.delete Identifier
id' (RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo RuntimeState
s)
                , runtimeFacts :: DependencyFacts
runtimeFacts        = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Identifier
id' [Dependency]
facts (RuntimeState -> DependencyFacts
runtimeFacts RuntimeState
s)
                , runtimeDependencies :: Map Identifier (Set (Identifier, String))
runtimeDependencies = forall k a. Ord k => k -> Map k a -> Map k a
M.delete Identifier
id' (RuntimeState -> Map Identifier (Set (Identifier, String))
runtimeDependencies RuntimeState
s)
                }
            
            forall (m :: * -> *) a. Monad m => a -> m a
return Progress
Progressed

        -- Try something else first
        CompilerRequire [(Identifier, String)]
reqs Compiler SomeItem
c -> do
            let done :: Set Identifier
done      = RuntimeState -> Set Identifier
runtimeDone RuntimeState
state
                snapshots :: Set (Identifier, String)
snapshots = RuntimeState -> Set (Identifier, String)
runtimeSnapshots RuntimeState
state

            [(Identifier, String)]
deps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Identifier, String)]
reqs forall a b. (a -> b) -> a -> b
$ \(Identifier
depId, String
depSnapshot) -> do
                forall (m :: * -> *). MonadIO m => Logger -> String -> m ()
Logger.debug Logger
logger forall a b. (a -> b) -> a -> b
$
                    String
"Compiler requirement found for: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
id' forall a. [a] -> [a] -> [a]
++
                    String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
depId forall a. [a] -> [a] -> [a]
++ String
" (snapshot " forall a. [a] -> [a] -> [a]
++ String
depSnapshot forall a. [a] -> [a] -> [a]
++ String
")"

                -- Done if we either completed the entire item (runtimeDone) or
                -- if we previously saved the snapshot (runtimeSnapshots).
                let depDone :: Bool
depDone =
                        Identifier
depId forall a. Ord a => a -> Set a -> Bool
`S.member` Set Identifier
done Bool -> Bool -> Bool
||
                        (Identifier
depId, String
depSnapshot) forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Identifier, String)
snapshots
                    actualDep :: [(Identifier, String)]
actualDep = [(Identifier
depId, String
depSnapshot) | Bool -> Bool
not Bool
depDone]

                forall (m :: * -> *) a. Monad m => a -> m a
return [(Identifier, String)]
actualDep  

            (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState forall a b. (a -> b) -> a -> b
$ \RuntimeState
s -> RuntimeState
s
                { runtimeTodo :: Map Identifier (Compiler SomeItem)
runtimeTodo         = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Identifier
id'
                    (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Identifier, String)]
deps then Compiler SomeItem
c else forall a. CompilerResult a -> Compiler a
compilerResult CompilerResult SomeItem
result)
                    (RuntimeState -> Map Identifier (Compiler SomeItem)
runtimeTodo RuntimeState
s)
                 -- We track dependencies only to inform users when an infinite loop is detected
                , runtimeDependencies :: Map Identifier (Set (Identifier, String))
runtimeDependencies = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Ord a => Set a -> Set a -> Set a
S.union Identifier
id' (forall a. Ord a => [a] -> Set a
S.fromList [(Identifier, String)]
deps) (RuntimeState -> Map Identifier (Set (Identifier, String))
runtimeDependencies RuntimeState
s)
                }

            -- Progress has been made if at least one of the 
            -- requirements can move forwards at the next pass
            -- In some cases, dependencies have been processed in parallel in which case `deps` 
            -- can be empty, and we can progress to the next stage. See issue #907
            let progress :: Progress
progress | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Identifier, String)]
deps    = Progress
Progressed
                         | [(Identifier, String)]
deps forall a. Eq a => a -> a -> Bool
== [(Identifier, String)]
reqs = Progress
Idled
                         | Bool
otherwise    = Progress
Progressed

            forall (m :: * -> *) a. Monad m => a -> m a
return Progress
progress