--------------------------------------------------------------------------------
module Hakyll.Core.Compiler.Require
    ( Snapshot
    , save
    , saveSnapshot
    , load
    , loadSnapshot
    , loadBody
    , loadSnapshotBody
    , loadAll
    , loadAllSnapshots
    ) where


--------------------------------------------------------------------------------
import           Control.Monad                  (when)
import           Data.Binary                    (Binary)
import           Data.Foldable                  (toList, traverse_)
import           Data.Functor.Identity          (Identity(Identity, runIdentity))
import qualified Data.Set                       as S
import           Data.Typeable


--------------------------------------------------------------------------------
import           Hakyll.Core.Compiler.Internal
import           Hakyll.Core.Dependencies
import           Hakyll.Core.Identifier
import           Hakyll.Core.Identifier.Pattern
import           Hakyll.Core.Item
import           Hakyll.Core.Metadata
import           Hakyll.Core.Store              (Store)
import qualified Hakyll.Core.Store              as Store


--------------------------------------------------------------------------------
save :: (Binary a, Typeable a) => Store -> Item a -> IO ()
save :: Store -> Item a -> IO ()
save Store
store Item a
item = Store -> Snapshot -> Item a -> IO ()
forall a.
(Binary a, Typeable a) =>
Store -> Snapshot -> Item a -> IO ()
saveSnapshot Store
store Snapshot
final Item a
item


--------------------------------------------------------------------------------
-- | Save a specific snapshot of an item, so you can load it later using
-- 'loadSnapshot'.
saveSnapshot :: (Binary a, Typeable a)
             => Store -> Snapshot -> Item a -> IO ()
saveSnapshot :: Store -> Snapshot -> Item a -> IO ()
saveSnapshot Store
store Snapshot
snapshot Item a
item =
    Store -> [Snapshot] -> a -> IO ()
forall a.
(Binary a, Typeable a) =>
Store -> [Snapshot] -> a -> IO ()
Store.set Store
store (Identifier -> Snapshot -> [Snapshot]
key (Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item a
item) Snapshot
snapshot) (Item a -> a
forall a. Item a -> a
itemBody Item a
item)


--------------------------------------------------------------------------------
-- | Load an item compiled elsewhere. If the required item is not yet compiled,
-- the build system will take care of that automatically.
load :: (Binary a, Typeable a) => Identifier -> Compiler (Item a)
load :: Identifier -> Compiler (Item a)
load Identifier
id' = Identifier -> Snapshot -> Compiler (Item a)
forall a.
(Binary a, Typeable a) =>
Identifier -> Snapshot -> Compiler (Item a)
loadSnapshot Identifier
id' Snapshot
final


--------------------------------------------------------------------------------
-- | Require a specific snapshot of an item.
loadSnapshot :: (Binary a, Typeable a)
             => Identifier -> Snapshot -> Compiler (Item a)
loadSnapshot :: Identifier -> Snapshot -> Compiler (Item a)
loadSnapshot Identifier
id' Snapshot
snapshot =
    (Identity (Item a) -> Item a)
-> Compiler (Identity (Item a)) -> Compiler (Item a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity (Item a) -> Item a
forall a. Identity a -> a
runIdentity (Compiler (Identity (Item a)) -> Compiler (Item a))
-> Compiler (Identity (Item a)) -> Compiler (Item a)
forall a b. (a -> b) -> a -> b
$ Identity (Identifier, Snapshot) -> Compiler (Identity (Item a))
forall a (t :: * -> *).
(Binary a, Typeable a, Traversable t) =>
t (Identifier, Snapshot) -> Compiler (t (Item a))
loadSnapshotCollection ((Identifier, Snapshot) -> Identity (Identifier, Snapshot)
forall a. a -> Identity a
Identity (Identifier
id', Snapshot
snapshot))


--------------------------------------------------------------------------------
-- | A shortcut for only requiring the body of an item.
--
-- > loadBody = fmap itemBody . load
loadBody :: (Binary a, Typeable a) => Identifier -> Compiler a
loadBody :: Identifier -> Compiler a
loadBody Identifier
id' = Identifier -> Snapshot -> Compiler a
forall a.
(Binary a, Typeable a) =>
Identifier -> Snapshot -> Compiler a
loadSnapshotBody Identifier
id' Snapshot
final


--------------------------------------------------------------------------------
-- | A shortcut for only requiring the body for a specific snapshot of an item
loadSnapshotBody :: (Binary a, Typeable a)
                 => Identifier -> Snapshot -> Compiler a
loadSnapshotBody :: Identifier -> Snapshot -> Compiler a
loadSnapshotBody Identifier
id' Snapshot
snapshot = (Item a -> a) -> Compiler (Item a) -> Compiler a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item a -> a
forall a. Item a -> a
itemBody (Compiler (Item a) -> Compiler a)
-> Compiler (Item a) -> Compiler a
forall a b. (a -> b) -> a -> b
$ Identifier -> Snapshot -> Compiler (Item a)
forall a.
(Binary a, Typeable a) =>
Identifier -> Snapshot -> Compiler (Item a)
loadSnapshot Identifier
id' Snapshot
snapshot


--------------------------------------------------------------------------------
-- | This function allows you to 'load' a dynamic list of items
loadAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a]
loadAll :: Pattern -> Compiler [Item a]
loadAll Pattern
pattern = Pattern -> Snapshot -> Compiler [Item a]
forall a.
(Binary a, Typeable a) =>
Pattern -> Snapshot -> Compiler [Item a]
loadAllSnapshots Pattern
pattern Snapshot
final


--------------------------------------------------------------------------------
-- | Load a specific snapshot for each of dynamic list of items
loadAllSnapshots :: (Binary a, Typeable a)
                 => Pattern -> Snapshot -> Compiler [Item a]
loadAllSnapshots :: Pattern -> Snapshot -> Compiler [Item a]
loadAllSnapshots Pattern
pattern Snapshot
snapshot = do
    [(Identifier, Snapshot)]
ids <- (Identifier -> (Identifier, Snapshot))
-> [Identifier] -> [(Identifier, Snapshot)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Identifier
id' -> (Identifier
id', Snapshot
snapshot)) ([Identifier] -> [(Identifier, Snapshot)])
-> Compiler [Identifier] -> Compiler [(Identifier, Snapshot)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> Compiler [Identifier]
forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern
    [(Identifier, Snapshot)] -> Compiler [Item a]
forall a (t :: * -> *).
(Binary a, Typeable a, Traversable t) =>
t (Identifier, Snapshot) -> Compiler (t (Item a))
loadSnapshotCollection [(Identifier, Snapshot)]
ids


--------------------------------------------------------------------------------
-- | Load a collection of snapshots.
-- Only the first NotFound or WrongType error will be reported.
loadSnapshotCollection :: (Binary a, Typeable a, Traversable t)
              => t (Identifier, Snapshot) -> Compiler (t (Item a))
loadSnapshotCollection :: t (Identifier, Snapshot) -> Compiler (t (Item a))
loadSnapshotCollection t (Identifier, Snapshot)
ids = do
    Store
store    <- CompilerRead -> Store
compilerStore (CompilerRead -> Store) -> Compiler CompilerRead -> Compiler Store
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler CompilerRead
compilerAsk
    Set Identifier
universe <- CompilerRead -> Set Identifier
compilerUniverse (CompilerRead -> Set Identifier)
-> Compiler CompilerRead -> Compiler (Set Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler CompilerRead
compilerAsk

    -- Quick check for better error messages
    let checkMember :: (Identifier, Snapshot) -> f ()
checkMember (Identifier
id', Snapshot
snap) =
            Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identifier
id' Identifier -> Set Identifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Identifier
universe) (Snapshot -> f ()
forall (m :: * -> *) a. MonadFail m => Snapshot -> m a
fail (Snapshot -> f ()) -> Snapshot -> f ()
forall a b. (a -> b) -> a -> b
$ Identifier -> Snapshot -> Snapshot
forall a. Show a => a -> Snapshot -> Snapshot
notFound Identifier
id' Snapshot
snap)
    ((Identifier, Snapshot) -> Compiler ())
-> t (Identifier, Snapshot) -> Compiler ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Identifier, Snapshot) -> Compiler ()
forall (f :: * -> *). MonadFail f => (Identifier, Snapshot) -> f ()
checkMember t (Identifier, Snapshot)
ids

    [Dependency] -> Compiler ()
compilerTellDependencies ([Dependency] -> Compiler ()) -> [Dependency] -> Compiler ()
forall a b. (a -> b) -> a -> b
$ Identifier -> Dependency
IdentifierDependency (Identifier -> Dependency)
-> ((Identifier, Snapshot) -> Identifier)
-> (Identifier, Snapshot)
-> Dependency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, Snapshot) -> Identifier
forall a b. (a, b) -> a
fst ((Identifier, Snapshot) -> Dependency)
-> [(Identifier, Snapshot)] -> [Dependency]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Identifier, Snapshot) -> [(Identifier, Snapshot)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Identifier, Snapshot)
ids
    let go :: (Identifier, Snapshot) -> Compiler (Item a)
go (Identifier
id', Snapshot
snap) = do
            Result a
result <- IO (Result a) -> Compiler (Result a)
forall a. IO a -> Compiler a
compilerUnsafeIO (IO (Result a) -> Compiler (Result a))
-> IO (Result a) -> Compiler (Result a)
forall a b. (a -> b) -> a -> b
$ Store -> [Snapshot] -> IO (Result a)
forall a.
(Binary a, Typeable a) =>
Store -> [Snapshot] -> IO (Result a)
Store.get Store
store (Identifier -> Snapshot -> [Snapshot]
key Identifier
id' Snapshot
snap)
            case Result a
result of
                Result a
Store.NotFound      -> Snapshot -> Compiler (Item a)
forall (m :: * -> *) a. MonadFail m => Snapshot -> m a
fail (Snapshot -> Compiler (Item a)) -> Snapshot -> Compiler (Item a)
forall a b. (a -> b) -> a -> b
$ Identifier -> Snapshot -> Snapshot
forall a. Show a => a -> Snapshot -> Snapshot
notFound Identifier
id' Snapshot
snap
                Store.WrongType TypeRep
e TypeRep
r -> Snapshot -> Compiler (Item a)
forall (m :: * -> *) a. MonadFail m => Snapshot -> m a
fail (Snapshot -> Compiler (Item a)) -> Snapshot -> Compiler (Item a)
forall a b. (a -> b) -> a -> b
$ Identifier -> Snapshot -> TypeRep -> TypeRep -> Snapshot
forall a a a.
(Show a, Show a, Show a) =>
a -> Snapshot -> a -> a -> Snapshot
wrongType Identifier
id' Snapshot
snap TypeRep
e TypeRep
r
                Store.Found a
x       -> Item a -> Compiler (Item a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Item a -> Compiler (Item a)) -> Item a -> Compiler (Item a)
forall a b. (a -> b) -> a -> b
$ Identifier -> a -> Item a
forall a. Identifier -> a -> Item a
Item Identifier
id' a
x
    CompilerResult (t (Item a)) -> Compiler (t (Item a))
forall a. CompilerResult a -> Compiler a
compilerResult (CompilerResult (t (Item a)) -> Compiler (t (Item a)))
-> CompilerResult (t (Item a)) -> Compiler (t (Item a))
forall a b. (a -> b) -> a -> b
$ [(Identifier, Snapshot)]
-> Compiler (t (Item a)) -> CompilerResult (t (Item a))
forall a.
[(Identifier, Snapshot)] -> Compiler a -> CompilerResult a
CompilerRequire (t (Identifier, Snapshot) -> [(Identifier, Snapshot)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Identifier, Snapshot)
ids) (Compiler (t (Item a)) -> CompilerResult (t (Item a)))
-> Compiler (t (Item a)) -> CompilerResult (t (Item a))
forall a b. (a -> b) -> a -> b
$ ((Identifier, Snapshot) -> Compiler (Item a))
-> t (Identifier, Snapshot) -> Compiler (t (Item a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Identifier, Snapshot) -> Compiler (Item a)
forall a.
(Binary a, Typeable a) =>
(Identifier, Snapshot) -> Compiler (Item a)
go t (Identifier, Snapshot)
ids
  where
    notFound :: a -> Snapshot -> Snapshot
notFound a
id' Snapshot
snapshot =
        Snapshot
"Hakyll.Core.Compiler.Require.load: " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ a -> Snapshot
forall a. Show a => a -> Snapshot
show a
id' Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++
        Snapshot
" (snapshot " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ Snapshot
snapshot Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ Snapshot
") was not found in the cache, " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++
        Snapshot
"the cache might be corrupted or " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++
        Snapshot
"the item you are referring to might not exist"
    wrongType :: a -> Snapshot -> a -> a -> Snapshot
wrongType a
id' Snapshot
snapshot a
e a
r =
        Snapshot
"Hakyll.Core.Compiler.Require.load: " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ a -> Snapshot
forall a. Show a => a -> Snapshot
show a
id' Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++
        Snapshot
" (snapshot " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ Snapshot
snapshot Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ Snapshot
") was found in the cache, " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++
        Snapshot
"but does not have the right type: expected " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ a -> Snapshot
forall a. Show a => a -> Snapshot
show a
e Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++
        Snapshot
" but got " Snapshot -> Snapshot -> Snapshot
forall a. [a] -> [a] -> [a]
++ a -> Snapshot
forall a. Show a => a -> Snapshot
show a
r


--------------------------------------------------------------------------------
key :: Identifier -> String -> [String]
key :: Identifier -> Snapshot -> [Snapshot]
key Identifier
identifier Snapshot
snapshot =
    [Snapshot
"Hakyll.Core.Compiler.Require", Identifier -> Snapshot
forall a. Show a => a -> Snapshot
show Identifier
identifier, Snapshot
snapshot]


--------------------------------------------------------------------------------
final :: Snapshot
final :: Snapshot
final = Snapshot
"_final"