{-# 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
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
put Dependency
AlwaysOutOfDate = Word8 -> Put
putWord8 Word8
2
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
2 -> Dependency -> Get Dependency
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]
-> Set Identifier
-> DependencyFacts
-> (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}
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
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 [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
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
Dependencies -> DependencyM Dependencies
forall (m :: * -> *) a. Monad m => a -> m a
return (Dependencies -> DependencyM Dependencies)
-> Dependencies -> DependencyM Dependencies
forall a b. (a -> b) -> a -> b
$ (Dependency -> Dependencies) -> [Dependency] -> Dependencies
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Dependency -> Dependencies
dependenciesFor' ([Dependency] -> Dependencies) -> [Dependency] -> Dependencies
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 -> 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
[Identifier]
universe <- RWST [Identifier] [String] DependencyState Identity [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
_ [Dependency]
ds Dependency
AlwaysOutOfDate = [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
$ Dependency
AlwaysOutOfDate Dependency -> [Dependency] -> [Dependency]
forall a. a -> [a] -> [a]
: [Dependency]
ds
go Identifier
id' [Dependency]
ds (PatternDependency Pattern
p Set Identifier
ls) = do
[Identifier]
universe <- RWST [Identifier] [String] DependencyState Identity [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 <- RWST [Identifier] [String] DependencyState Identity [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
Dependencies
deps <- Identifier -> DependencyM Dependencies
dependenciesFor Identifier
id'
case Dependencies
deps of
DependsOn [Identifier]
depList -> do
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]
depList 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)
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 (m :: * -> *) a. Monad m => a -> m a
return ([Identifier]
todo, Bool
True)