--------------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
module Hakyll.Core.Dependencies
    ( Dependency (..)
    , DependencyFacts
    , outOfDate
    ) where


--------------------------------------------------------------------------------
import           Control.Monad                  (foldM, forM_, unless, when)
import           Control.Monad.Reader           (ask)
import           Control.Monad.RWS              (RWS, runRWS)
import qualified Control.Monad.State            as State
import           Control.Monad.Writer           (tell)
import           Data.Binary                    (Binary (..), getWord8,
                                                 putWord8)
import           Data.List                      (find)
import           Data.Map                       (Map)
import qualified Data.Map                       as M
import           Data.Maybe                     (fromMaybe)
import           Data.Set                       (Set)
import qualified Data.Set                       as S
import           Data.Typeable                  (Typeable)


--------------------------------------------------------------------------------
import           Hakyll.Core.Identifier
import           Hakyll.Core.Identifier.Pattern


--------------------------------------------------------------------------------
data Dependency
    = PatternDependency Pattern (Set Identifier)
    | IdentifierDependency Identifier
    | AlwaysOutOfDate
    deriving (Int -> Dependency -> ShowS
[Dependency] -> ShowS
Dependency -> String
(Int -> Dependency -> ShowS)
-> (Dependency -> String)
-> ([Dependency] -> ShowS)
-> Show Dependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependency -> ShowS
showsPrec :: Int -> Dependency -> ShowS
$cshow :: Dependency -> String
show :: Dependency -> String
$cshowList :: [Dependency] -> ShowS
showList :: [Dependency] -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Binary Dependency where
    put :: Dependency -> Put
put (PatternDependency Pattern
p Set Identifier
is) = Word8 -> Put
putWord8 Word8
0 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pattern -> Put
forall t. Binary t => t -> Put
put Pattern
p Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Set Identifier -> Put
forall t. Binary t => t -> Put
put Set Identifier
is
    put (IdentifierDependency Identifier
i) = Word8 -> Put
putWord8 Word8
1 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Identifier -> Put
forall t. Binary t => t -> Put
put Identifier
i
    put Dependency
AlwaysOutOfDate = Word8 -> Put
putWord8 Word8
2
    get :: Get Dependency
get = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Dependency) -> Get Dependency
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
t -> case Word8
t of
        Word8
0 -> Pattern -> Set Identifier -> Dependency
PatternDependency (Pattern -> Set Identifier -> Dependency)
-> Get Pattern -> Get (Set Identifier -> Dependency)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Pattern
forall t. Binary t => Get t
get Get (Set Identifier -> Dependency)
-> Get (Set Identifier) -> Get Dependency
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Set Identifier)
forall t. Binary t => Get t
get
        Word8
1 -> Identifier -> Dependency
IdentifierDependency (Identifier -> Dependency) -> Get Identifier -> Get Dependency
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Identifier
forall t. Binary t => Get t
get
        Word8
2 -> Dependency -> Get Dependency
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dependency
AlwaysOutOfDate
        Word8
_ -> String -> Get Dependency
forall a. HasCallStack => String -> a
error String
"Data.Binary.get: Invalid Dependency"


--------------------------------------------------------------------------------
type DependencyFacts = Map Identifier [Dependency]


--------------------------------------------------------------------------------
outOfDate
    :: [Identifier]     -- ^ All known identifiers
    -> Set Identifier   -- ^ Initially out-of-date resources
    -> DependencyFacts  -- ^ Old dependency facts
    -> (Set Identifier, DependencyFacts, [String])
outOfDate :: [Identifier]
-> Set Identifier
-> DependencyFacts
-> (Set Identifier, DependencyFacts, [String])
outOfDate [Identifier]
universe Set Identifier
ood DependencyFacts
oldFacts =
    let (()
_, DependencyState
state, [String]
logs) = RWS [Identifier] [String] DependencyState ()
-> [Identifier]
-> DependencyState
-> ((), DependencyState, [String])
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS RWS [Identifier] [String] DependencyState ()
rws [Identifier]
universe (DependencyFacts -> Set Identifier -> DependencyState
DependencyState DependencyFacts
oldFacts Set Identifier
ood)
    in (DependencyState -> Set Identifier
dependencyOod DependencyState
state, DependencyState -> DependencyFacts
dependencyFacts DependencyState
state, [String]
logs)
  where
    rws :: RWS [Identifier] [String] DependencyState ()
rws = do
        RWS [Identifier] [String] DependencyState ()
checkNew
        RWS [Identifier] [String] DependencyState ()
checkChangedPatterns
        RWS [Identifier] [String] DependencyState ()
bruteForce


--------------------------------------------------------------------------------
data DependencyState = DependencyState
    { DependencyState -> DependencyFacts
dependencyFacts :: DependencyFacts
    , DependencyState -> Set Identifier
dependencyOod   :: Set Identifier
    } deriving (Int -> DependencyState -> ShowS
[DependencyState] -> ShowS
DependencyState -> String
(Int -> DependencyState -> ShowS)
-> (DependencyState -> String)
-> ([DependencyState] -> ShowS)
-> Show DependencyState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependencyState -> ShowS
showsPrec :: Int -> DependencyState -> ShowS
$cshow :: DependencyState -> String
show :: DependencyState -> String
$cshowList :: [DependencyState] -> ShowS
showList :: [DependencyState] -> ShowS
Show)


--------------------------------------------------------------------------------
type DependencyM a = RWS [Identifier] [String] DependencyState a


--------------------------------------------------------------------------------
markOod :: Identifier -> DependencyM ()
markOod :: Identifier -> RWS [Identifier] [String] DependencyState ()
markOod Identifier
id' = (DependencyState -> DependencyState)
-> RWS [Identifier] [String] DependencyState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((DependencyState -> DependencyState)
 -> RWS [Identifier] [String] DependencyState ())
-> (DependencyState -> DependencyState)
-> RWS [Identifier] [String] DependencyState ()
forall a b. (a -> b) -> a -> b
$ \DependencyState
s ->
    DependencyState
s {dependencyOod = S.insert id' $ dependencyOod s}


--------------------------------------------------------------------------------
-- | Collection of dependencies that should be checked to determine
-- if an identifier needs rebuilding.
data Dependencies
  = DependsOn [Identifier]
  | MustRebuild
  deriving (Int -> Dependencies -> ShowS
[Dependencies] -> ShowS
Dependencies -> String
(Int -> Dependencies -> ShowS)
-> (Dependencies -> String)
-> ([Dependencies] -> ShowS)
-> Show Dependencies
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependencies -> ShowS
showsPrec :: Int -> Dependencies -> ShowS
$cshow :: Dependencies -> String
show :: Dependencies -> String
$cshowList :: [Dependencies] -> ShowS
showList :: [Dependencies] -> ShowS
Show)

instance Semigroup Dependencies where
  DependsOn [Identifier]
ids <> :: Dependencies -> Dependencies -> Dependencies
<> DependsOn [Identifier]
moreIds = [Identifier] -> Dependencies
DependsOn ([Identifier]
ids [Identifier] -> [Identifier] -> [Identifier]
forall a. Semigroup a => a -> a -> a
<> [Identifier]
moreIds)
  Dependencies
MustRebuild <> Dependencies
_ = Dependencies
MustRebuild
  Dependencies
_ <> Dependencies
MustRebuild = Dependencies
MustRebuild

instance Monoid Dependencies where
  mempty :: Dependencies
mempty = [Identifier] -> Dependencies
DependsOn []

--------------------------------------------------------------------------------
dependenciesFor :: Identifier -> DependencyM Dependencies
dependenciesFor :: Identifier -> DependencyM Dependencies
dependenciesFor Identifier
id' = do
    facts <- DependencyState -> DependencyFacts
dependencyFacts (DependencyState -> DependencyFacts)
-> RWST
     [Identifier] [String] DependencyState Identity DependencyState
-> RWST
     [Identifier] [String] DependencyState Identity DependencyFacts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST [Identifier] [String] DependencyState Identity DependencyState
forall s (m :: * -> *). MonadState s m => m s
State.get
    return $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts
  where
    dependenciesFor' :: Dependency -> Dependencies
dependenciesFor' (IdentifierDependency Identifier
i) = [Identifier] -> Dependencies
DependsOn [Identifier
i]
    dependenciesFor' (PatternDependency Pattern
_ Set Identifier
is) = [Identifier] -> Dependencies
DependsOn ([Identifier] -> Dependencies) -> [Identifier] -> Dependencies
forall a b. (a -> b) -> a -> b
$ Set Identifier -> [Identifier]
forall a. Set a -> [a]
S.toList Set Identifier
is
    dependenciesFor' Dependency
AlwaysOutOfDate          = Dependencies
MustRebuild


--------------------------------------------------------------------------------
checkNew :: DependencyM ()
checkNew :: RWS [Identifier] [String] DependencyState ()
checkNew = do
    universe <- RWST [Identifier] [String] DependencyState Identity [Identifier]
forall r (m :: * -> *). MonadReader r m => m r
ask
    facts    <- dependencyFacts <$> State.get
    forM_ universe $ \Identifier
id' -> Bool
-> RWS [Identifier] [String] DependencyState ()
-> RWS [Identifier] [String] DependencyState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Identifier
id' Identifier -> DependencyFacts -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` DependencyFacts
facts) (RWS [Identifier] [String] DependencyState ()
 -> RWS [Identifier] [String] DependencyState ())
-> RWS [Identifier] [String] DependencyState ()
-> RWS [Identifier] [String] DependencyState ()
forall a b. (a -> b) -> a -> b
$ do
        [String] -> RWS [Identifier] [String] DependencyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Identifier -> String
forall a. Show a => a -> String
show Identifier
id' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is out-of-date because it is new"]
        Identifier -> RWS [Identifier] [String] DependencyState ()
markOod Identifier
id'


--------------------------------------------------------------------------------
checkChangedPatterns :: DependencyM ()
checkChangedPatterns :: RWS [Identifier] [String] DependencyState ()
checkChangedPatterns = do
    facts <- DependencyFacts -> [(Identifier, [Dependency])]
forall k a. Map k a -> [(k, a)]
M.toList (DependencyFacts -> [(Identifier, [Dependency])])
-> (DependencyState -> DependencyFacts)
-> DependencyState
-> [(Identifier, [Dependency])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DependencyState -> DependencyFacts
dependencyFacts (DependencyState -> [(Identifier, [Dependency])])
-> RWST
     [Identifier] [String] DependencyState Identity DependencyState
-> RWST
     [Identifier]
     [String]
     DependencyState
     Identity
     [(Identifier, [Dependency])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST [Identifier] [String] DependencyState Identity DependencyState
forall s (m :: * -> *). MonadState s m => m s
State.get
    forM_ facts $ \(Identifier
id', [Dependency]
deps) -> do
        deps' <- ([Dependency]
 -> Dependency
 -> RWST
      [Identifier] [String] DependencyState Identity [Dependency])
-> [Dependency]
-> [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Identifier
-> [Dependency]
-> Dependency
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
go Identifier
id') [] [Dependency]
deps
        State.modify $ \DependencyState
s -> DependencyState
s
            {dependencyFacts = M.insert id' deps' $ dependencyFacts s}
  where
    go :: Identifier
-> [Dependency]
-> Dependency
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
go Identifier
_   [Dependency]
ds (IdentifierDependency Identifier
i) = [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
forall a.
a -> RWST [Identifier] [String] DependencyState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dependency]
 -> RWST
      [Identifier] [String] DependencyState Identity [Dependency])
-> [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
forall a b. (a -> b) -> a -> b
$ Identifier -> Dependency
IdentifierDependency Identifier
i Dependency -> [Dependency] -> [Dependency]
forall a. a -> [a] -> [a]
: [Dependency]
ds
    go Identifier
_   [Dependency]
ds Dependency
AlwaysOutOfDate          = [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
forall a.
a -> RWST [Identifier] [String] DependencyState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dependency]
 -> RWST
      [Identifier] [String] DependencyState Identity [Dependency])
-> [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
forall a b. (a -> b) -> a -> b
$ Dependency
AlwaysOutOfDate Dependency -> [Dependency] -> [Dependency]
forall a. a -> [a] -> [a]
: [Dependency]
ds
    go Identifier
id' [Dependency]
ds (PatternDependency Pattern
p Set Identifier
ls) = do
        universe <- RWST [Identifier] [String] DependencyState Identity [Identifier]
forall r (m :: * -> *). MonadReader r m => m r
ask
        let ls' = [Identifier] -> Set Identifier
forall a. Ord a => [a] -> Set a
S.fromList ([Identifier] -> Set Identifier) -> [Identifier] -> Set Identifier
forall a b. (a -> b) -> a -> b
$ Pattern -> [Identifier] -> [Identifier]
filterMatches Pattern
p [Identifier]
universe
        if ls == ls'
            then return $ PatternDependency p ls : ds
            else do
                tell [show id' ++ " is out-of-date because a pattern changed"]
                markOod id'
                return $ PatternDependency p ls' : ds


--------------------------------------------------------------------------------
bruteForce :: DependencyM ()
bruteForce :: RWS [Identifier] [String] DependencyState ()
bruteForce = do
    todo <- RWST [Identifier] [String] DependencyState Identity [Identifier]
forall r (m :: * -> *). MonadReader r m => m r
ask
    go todo
  where
    go :: [Identifier] -> RWS [Identifier] [String] DependencyState ()
go [Identifier]
todo = do
        (todo', changed) <- (([Identifier], Bool)
 -> Identifier
 -> RWST
      [Identifier]
      [String]
      DependencyState
      Identity
      ([Identifier], Bool))
-> ([Identifier], Bool)
-> [Identifier]
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Identifier], Bool)
-> Identifier
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
check ([], Bool
False) [Identifier]
todo
        when changed (go todo')

    check :: ([Identifier], Bool)
-> Identifier
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
check ([Identifier]
todo, Bool
changed) Identifier
id' = do
        deps <- Identifier -> DependencyM Dependencies
dependenciesFor Identifier
id'
        case deps of
          DependsOn [Identifier]
depList -> do
            ood  <- DependencyState -> Set Identifier
dependencyOod (DependencyState -> Set Identifier)
-> RWST
     [Identifier] [String] DependencyState Identity DependencyState
-> RWST
     [Identifier] [String] DependencyState Identity (Set Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST [Identifier] [String] DependencyState Identity DependencyState
forall s (m :: * -> *). MonadState s m => m s
State.get
            case find (`S.member` ood) depList of
                Maybe Identifier
Nothing -> ([Identifier], Bool)
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
forall a.
a -> RWST [Identifier] [String] DependencyState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier
id' Identifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
: [Identifier]
todo, Bool
changed)
                Just Identifier
d  -> do
                    [String] -> RWS [Identifier] [String] DependencyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Identifier -> String
forall a. Show a => a -> String
show Identifier
id' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is out-of-date because " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        Identifier -> String
forall a. Show a => a -> String
show Identifier
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is out-of-date"]
                    Identifier -> RWS [Identifier] [String] DependencyState ()
markOod Identifier
id'
                    ([Identifier], Bool)
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
forall a.
a -> RWST [Identifier] [String] DependencyState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Identifier]
todo, Bool
True)
          Dependencies
MustRebuild -> do
            [String] -> RWS [Identifier] [String] DependencyState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Identifier -> String
forall a. Show a => a -> String
show Identifier
id' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" will be forcibly rebuilt"]
            Identifier -> RWS [Identifier] [String] DependencyState ()
markOod Identifier
id'
            ([Identifier], Bool)
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
forall a.
a -> RWST [Identifier] [String] DependencyState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Identifier]
todo, Bool
True)