--------------------------------------------------------------------------------
{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dependency] -> ShowS
$cshowList :: [Dependency] -> ShowS
show :: Dependency -> String
$cshow :: Dependency -> String
showsPrec :: Int -> Dependency -> ShowS
$cshowsPrec :: Int -> Dependency -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Binary Dependency where
    put :: Dependency -> Put
put (PatternDependency Pattern
p Set Identifier
is) = Word8 -> Put
putWord8 Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Pattern
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Set Identifier
is
    put (IdentifierDependency Identifier
i) = Word8 -> Put
putWord8 Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Identifier
i
    put Dependency
AlwaysOutOfDate = Word8 -> Put
putWord8 Word8
2
    get :: Get Dependency
get = Get Word8
getWord8 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
        Word8
1 -> Identifier -> Dependency
IdentifierDependency forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
        Word8
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Dependency
AlwaysOutOfDate
        Word8
_ -> 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) = forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS RWST [Identifier] [String] DependencyState Identity ()
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 :: RWST [Identifier] [String] DependencyState Identity ()
rws = do
        RWST [Identifier] [String] DependencyState Identity ()
checkNew
        RWST [Identifier] [String] DependencyState Identity ()
checkChangedPatterns
        RWST [Identifier] [String] DependencyState Identity ()
bruteForce


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


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


--------------------------------------------------------------------------------
markOod :: Identifier -> DependencyM ()
markOod :: Identifier
-> RWST [Identifier] [String] DependencyState Identity ()
markOod Identifier
id' = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \DependencyState
s ->
    DependencyState
s {dependencyOod :: Set Identifier
dependencyOod = forall a. Ord a => a -> Set a -> Set a
S.insert Identifier
id' forall a b. (a -> b) -> a -> b
$ DependencyState -> Set Identifier
dependencyOod DependencyState
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dependencies] -> ShowS
$cshowList :: [Dependencies] -> ShowS
show :: Dependencies -> String
$cshow :: Dependencies -> String
showsPrec :: Int -> Dependencies -> ShowS
$cshowsPrec :: Int -> Dependencies -> ShowS
Show)

instance Semigroup Dependencies where
  DependsOn [Identifier]
ids <> :: Dependencies -> Dependencies -> Dependencies
<> DependsOn [Identifier]
moreIds = [Identifier] -> Dependencies
DependsOn ([Identifier]
ids 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
    DependencyFacts
facts <- DependencyState -> DependencyFacts
dependencyFacts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
State.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Dependency -> Dependencies
dependenciesFor' forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
id' DependencyFacts
facts
  where
    dependenciesFor' :: Dependency -> Dependencies
dependenciesFor' (IdentifierDependency Identifier
i) = [Identifier] -> Dependencies
DependsOn [Identifier
i]
    dependenciesFor' (PatternDependency Pattern
_ Set Identifier
is) = [Identifier] -> Dependencies
DependsOn forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Identifier
is
    dependenciesFor' Dependency
AlwaysOutOfDate          = Dependencies
MustRebuild


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


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


--------------------------------------------------------------------------------
bruteForce :: DependencyM ()
bruteForce :: RWST [Identifier] [String] DependencyState Identity ()
bruteForce = do
    [Identifier]
todo <- forall r (m :: * -> *). MonadReader r m => m r
ask
    [Identifier]
-> RWST [Identifier] [String] DependencyState Identity ()
go [Identifier]
todo
  where
    go :: [Identifier]
-> RWST [Identifier] [String] DependencyState Identity ()
go [Identifier]
todo = do
        ([Identifier]
todo', Bool
changed) <- 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed ([Identifier]
-> RWST [Identifier] [String] DependencyState Identity ()
go [Identifier]
todo')

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