--------------------------------------------------------------------------------
{-# 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
    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
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 Put -> Put -> Put
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Identifier -> Put
forall t. Binary t => t -> Put
put Identifier
i
    get :: Get Dependency
get = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Dependency) -> Get Dependency
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 (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
_ -> 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
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 -> 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 :: Set Identifier
dependencyOod = Identifier -> Set Identifier -> Set Identifier
forall a. Ord a => a -> Set a -> Set a
S.insert Identifier
id' (Set Identifier -> Set Identifier)
-> Set Identifier -> Set Identifier
forall a b. (a -> b) -> a -> b
$ DependencyState -> Set Identifier
dependencyOod DependencyState
s}


--------------------------------------------------------------------------------
dependenciesFor :: Identifier -> DependencyM [Identifier]
dependenciesFor :: Identifier -> DependencyM [Identifier]
dependenciesFor Identifier
id' = do
    DependencyFacts
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
    [Identifier] -> DependencyM [Identifier]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Identifier] -> DependencyM [Identifier])
-> [Identifier] -> DependencyM [Identifier]
forall a b. (a -> b) -> a -> b
$ (Dependency -> [Identifier]) -> [Dependency] -> [Identifier]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dependency -> [Identifier]
dependenciesFor' ([Dependency] -> [Identifier]) -> [Dependency] -> [Identifier]
forall a b. (a -> b) -> a -> b
$ [Dependency] -> Maybe [Dependency] -> [Dependency]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Dependency] -> [Dependency])
-> Maybe [Dependency] -> [Dependency]
forall a b. (a -> b) -> a -> b
$ Identifier -> DependencyFacts -> Maybe [Dependency]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
id' DependencyFacts
facts
  where
    dependenciesFor' :: Dependency -> [Identifier]
dependenciesFor' (IdentifierDependency Identifier
i) = [Identifier
i]
    dependenciesFor' (PatternDependency Pattern
_ Set Identifier
is) = Set Identifier -> [Identifier]
forall a. Set a -> [a]
S.toList Set Identifier
is


--------------------------------------------------------------------------------
checkNew :: DependencyM ()
checkNew :: RWS [Identifier] [String] DependencyState ()
checkNew = do
    [Identifier]
universe <- DependencyM [Identifier]
forall r (m :: * -> *). MonadReader r m => m r
ask
    DependencyFacts
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
    [Identifier]
-> (Identifier -> RWS [Identifier] [String] DependencyState ())
-> RWS [Identifier] [String] DependencyState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Identifier]
universe ((Identifier -> RWS [Identifier] [String] DependencyState ())
 -> RWS [Identifier] [String] DependencyState ())
-> (Identifier -> RWS [Identifier] [String] DependencyState ())
-> RWS [Identifier] [String] DependencyState ()
forall a b. (a -> b) -> a -> b
$ \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
    [(Identifier, [Dependency])]
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
    [(Identifier, [Dependency])]
-> ((Identifier, [Dependency])
    -> RWS [Identifier] [String] DependencyState ())
-> RWS [Identifier] [String] DependencyState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Identifier, [Dependency])]
facts (((Identifier, [Dependency])
  -> RWS [Identifier] [String] DependencyState ())
 -> RWS [Identifier] [String] DependencyState ())
-> ((Identifier, [Dependency])
    -> RWS [Identifier] [String] DependencyState ())
-> RWS [Identifier] [String] DependencyState ()
forall a b. (a -> b) -> a -> b
$ \(Identifier
id', [Dependency]
deps) -> do
        [Dependency]
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
        (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
            {dependencyFacts :: DependencyFacts
dependencyFacts = Identifier -> [Dependency] -> DependencyFacts -> DependencyFacts
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Identifier
id' [Dependency]
deps' (DependencyFacts -> DependencyFacts)
-> DependencyFacts -> DependencyFacts
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) = [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
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
id' [Dependency]
ds (PatternDependency Pattern
p Set Identifier
ls) = do
        [Identifier]
universe <- DependencyM [Identifier]
forall r (m :: * -> *). MonadReader r m => m r
ask
        let ls' :: Set Identifier
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 Set Identifier
ls Set Identifier -> Set Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Set Identifier
ls'
            then [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
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
$ Pattern -> Set Identifier -> Dependency
PatternDependency Pattern
p Set Identifier
ls Dependency -> [Dependency] -> [Dependency]
forall a. a -> [a] -> [a]
: [Dependency]
ds
            else 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 a pattern changed"]
                Identifier -> RWS [Identifier] [String] DependencyState ()
markOod Identifier
id'
                [Dependency]
-> RWST [Identifier] [String] DependencyState Identity [Dependency]
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
$ Pattern -> Set Identifier -> Dependency
PatternDependency Pattern
p Set Identifier
ls' Dependency -> [Dependency] -> [Dependency]
forall a. a -> [a] -> [a]
: [Dependency]
ds


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

    check :: ([Identifier], Bool)
-> Identifier
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
check ([Identifier]
todo, Bool
changed) Identifier
id' = do
        [Identifier]
deps <- Identifier -> DependencyM [Identifier]
dependenciesFor Identifier
id'
        Set Identifier
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 (Identifier -> Bool) -> [Identifier] -> Maybe Identifier
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Identifier -> Set Identifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Identifier
ood) [Identifier]
deps of
            Maybe Identifier
Nothing -> ([Identifier], Bool)
-> RWST
     [Identifier] [String] DependencyState Identity ([Identifier], Bool)
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 (m :: * -> *) a. Monad m => a -> m a
return ([Identifier]
todo, Bool
True)