--------------------------------------------------------------------------------
-- | This module provides a declarative DSL in which the user can specify the
-- different rules used to run the compilers.
--
-- The convention is to just list all items in the 'Rules' monad, routes and
-- compilation rules.
--
-- A typical usage example would be:
--
-- > main = hakyll $ do
-- >     match "posts/*" $ do
-- >         route   (setExtension "html")
-- >         compile someCompiler
-- >     match "css/*" $ do
-- >         route   idRoute
-- >         compile compressCssCompiler
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
module Hakyll.Core.Rules
    ( Rules
    , match
    , matchMetadata
    , create
    , version
    , compile
    , route

      -- * Advanced usage
    , preprocess
    , Dependency (..)
    , rulesExtraDependencies
    ) where


--------------------------------------------------------------------------------
import           Control.Monad.Reader           (ask, local)
import           Control.Monad.State            (get, modify, put)
import           Control.Monad.Trans            (liftIO)
import           Control.Monad.Writer           (censor, tell)
import           Data.Maybe                     (fromMaybe)
import qualified Data.Set                       as S


--------------------------------------------------------------------------------
import           Data.Binary                    (Binary)
import           Data.Typeable                  (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.Item.SomeItem
import           Hakyll.Core.Metadata
import           Hakyll.Core.Routes
import           Hakyll.Core.Rules.Internal
import           Hakyll.Core.Writable


--------------------------------------------------------------------------------
-- | Add a route
tellRoute :: Routes -> Rules ()
tellRoute :: Routes -> Rules ()
tellRoute Routes
route' = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Routes
-> [(Identifier, Compiler SomeItem)]
-> Set Identifier
-> Pattern
-> RuleSet
RuleSet Routes
route' forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty


--------------------------------------------------------------------------------
-- | Add a number of compilers
tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()
tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()
tellCompilers [(Identifier, Compiler SomeItem)]
compilers = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Routes
-> [(Identifier, Compiler SomeItem)]
-> Set Identifier
-> Pattern
-> RuleSet
RuleSet forall a. Monoid a => a
mempty [(Identifier, Compiler SomeItem)]
compilers forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty


--------------------------------------------------------------------------------
-- | Add resources
tellResources :: [Identifier] -> Rules ()
tellResources :: [Identifier] -> Rules ()
tellResources [Identifier]
resources' = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$
    Routes
-> [(Identifier, Compiler SomeItem)]
-> Set Identifier
-> Pattern
-> RuleSet
RuleSet forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall a. Ord a => [a] -> Set a
S.fromList [Identifier]
resources') forall a. Monoid a => a
mempty


--------------------------------------------------------------------------------
-- | Add a pattern
tellPattern :: Pattern -> Rules ()
tellPattern :: Pattern -> Rules ()
tellPattern Pattern
pattern = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Routes
-> [(Identifier, Compiler SomeItem)]
-> Set Identifier
-> Pattern
-> RuleSet
RuleSet forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Pattern
pattern


--------------------------------------------------------------------------------
flush :: Rules ()
flush :: Rules ()
flush = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ do
    Maybe (Compiler SomeItem)
mcompiler <- RulesState -> Maybe (Compiler SomeItem)
rulesCompiler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
    case Maybe (Compiler SomeItem)
mcompiler of
        Maybe (Compiler SomeItem)
Nothing       -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Compiler SomeItem
compiler -> do
            [Identifier]
matches' <- RulesRead -> [Identifier]
rulesMatches                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
            Maybe String
version' <- RulesRead -> Maybe String
rulesVersion                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
            Routes
route'   <- forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. RulesState -> Maybe Routes
rulesRoute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get

            -- The version is possibly not set correctly at this point (yet)
            let ids :: [Identifier]
ids = forall a b. (a -> b) -> [a] -> [b]
map (Maybe String -> Identifier -> Identifier
setVersion Maybe String
version') [Identifier]
matches'

            {-
            ids      <- case fromLiteral pattern of
                Just id' -> return [setVersion version' id']
                Nothing  -> do
                    ids <- unRules $ getMatches pattern
                    unRules $ tellResources ids
                    return $ map (setVersion version') ids
            -}

            -- Create a fast pattern for routing that matches exactly the
            -- compilers created in the block given to match
            let fastPattern :: Pattern
fastPattern = [Identifier] -> Pattern
fromList [Identifier]
ids

            -- Write out the compilers and routes
            forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules forall a b. (a -> b) -> a -> b
$ Routes -> Rules ()
tellRoute forall a b. (a -> b) -> a -> b
$ Pattern -> Routes -> Routes
matchRoute Pattern
fastPattern Routes
route'
            forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules forall a b. (a -> b) -> a -> b
$ [(Identifier, Compiler SomeItem)] -> Rules ()
tellCompilers forall a b. (a -> b) -> a -> b
$ [(Identifier
id', Compiler SomeItem
compiler) | Identifier
id' <- [Identifier]
ids]

    forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ RulesState
emptyRulesState


--------------------------------------------------------------------------------
matchInternal :: Pattern -> Rules [Identifier] -> Rules () -> Rules ()
matchInternal :: Pattern -> Rules [Identifier] -> Rules () -> Rules ()
matchInternal Pattern
pattern Rules [Identifier]
getIDs Rules ()
rules = do
    Pattern -> Rules ()
tellPattern Pattern
pattern
    Rules ()
flush
    [Identifier]
ids <- Rules [Identifier]
getIDs
    [Identifier] -> Rules ()
tellResources [Identifier]
ids
    forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ([Identifier] -> RulesRead -> RulesRead
setMatches [Identifier]
ids) forall a b. (a -> b) -> a -> b
$ forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules forall a b. (a -> b) -> a -> b
$ Rules ()
rules forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rules ()
flush
  where
    setMatches :: [Identifier] -> RulesRead -> RulesRead
setMatches [Identifier]
ids RulesRead
env = RulesRead
env {rulesMatches :: [Identifier]
rulesMatches = [Identifier]
ids}

--------------------------------------------------------------------------------
match :: Pattern -> Rules () -> Rules ()
match :: Pattern -> Rules () -> Rules ()
match Pattern
pattern = Pattern -> Rules [Identifier] -> Rules () -> Rules ()
matchInternal Pattern
pattern forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern


--------------------------------------------------------------------------------
matchMetadata :: Pattern -> (Metadata -> Bool) -> Rules () -> Rules ()
matchMetadata :: Pattern -> (Metadata -> Bool) -> Rules () -> Rules ()
matchMetadata Pattern
pattern Metadata -> Bool
metadataPred = Pattern -> Rules [Identifier] -> Rules () -> Rules ()
matchInternal Pattern
pattern forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Metadata -> Bool
metadataPred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadMetadata m =>
Pattern -> m [(Identifier, Metadata)]
getAllMetadata Pattern
pattern


--------------------------------------------------------------------------------
create :: [Identifier] -> Rules () -> Rules ()
create :: [Identifier] -> Rules () -> Rules ()
create [Identifier]
ids Rules ()
rules = do
    Rules ()
flush
    -- TODO Maybe check if the resources exist and call tellResources on that
    forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RulesRead -> RulesRead
setMatches forall a b. (a -> b) -> a -> b
$ forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules forall a b. (a -> b) -> a -> b
$ Rules ()
rules forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rules ()
flush
  where
    setMatches :: RulesRead -> RulesRead
setMatches RulesRead
env = RulesRead
env {rulesMatches :: [Identifier]
rulesMatches = [Identifier]
ids}


--------------------------------------------------------------------------------
version :: String -> Rules () -> Rules ()
version :: String -> Rules () -> Rules ()
version String
v Rules ()
rules = do
    Rules ()
flush
    forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RulesRead -> RulesRead
setVersion' forall a b. (a -> b) -> a -> b
$ forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules forall a b. (a -> b) -> a -> b
$ Rules ()
rules forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rules ()
flush
  where
    setVersion' :: RulesRead -> RulesRead
setVersion' RulesRead
env = RulesRead
env {rulesVersion :: Maybe String
rulesVersion = forall a. a -> Maybe a
Just String
v}


--------------------------------------------------------------------------------
-- | Add a compilation rule to the rules.
--
-- This instructs all resources to be compiled using the given compiler.
compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -> Rules ()
compile :: forall a.
(Binary a, Typeable a, Writable a) =>
Compiler (Item a) -> Rules ()
compile Compiler (Item a)
compiler = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RulesState
s ->
    RulesState
s {rulesCompiler :: Maybe (Compiler SomeItem)
rulesCompiler = forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. (Binary a, Typeable a, Writable a) => Item a -> SomeItem
SomeItem Compiler (Item a)
compiler)}


--------------------------------------------------------------------------------
-- | Add a route.
--
-- This adds a route for all items matching the current pattern.
route :: Routes -> Rules ()
route :: Routes -> Rules ()
route Routes
route' = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RulesState
s -> RulesState
s {rulesRoute :: Maybe Routes
rulesRoute = forall a. a -> Maybe a
Just Routes
route'}


--------------------------------------------------------------------------------
-- | Execute an 'IO' action immediately while the rules are being evaluated.
-- This should be avoided if possible, but occasionally comes in useful.
preprocess :: IO a -> Rules a
preprocess :: forall a. IO a -> Rules a
preprocess = forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO


--------------------------------------------------------------------------------
-- | Advanced usage: add extra dependencies to compilers. Basically this is
-- needed when you're doing unsafe tricky stuff in the rules monad, but you
-- still want correct builds.
--
-- A useful utility for this purpose is 'makePatternDependency'.
rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a
rulesExtraDependencies :: forall a. [Dependency] -> Rules a -> Rules a
rulesExtraDependencies [Dependency]
deps Rules a
rules =
    -- Note that we add the dependencies seemingly twice here. However, this is
    -- done so that 'rulesExtraDependencies' works both if we have something
    -- like:
    --
    -- > match "*.css" $ rulesExtraDependencies [foo] $ ...
    --
    -- and something like:
    --
    -- > rulesExtraDependencies [foo] $ match "*.css" $ ...
    --
    -- (1) takes care of the latter and (2) of the former.
    forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor RuleSet -> RuleSet
fixRuleSet forall a b. (a -> b) -> a -> b
$ do
        a
x <- forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules Rules a
rules
        RWST RulesRead RuleSet RulesState IO ()
fixCompiler
        forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where
    -- (1) Adds the dependencies to the compilers we are yet to create
    fixCompiler :: RWST RulesRead RuleSet RulesState IO ()
fixCompiler = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RulesState
s -> case RulesState -> Maybe (Compiler SomeItem)
rulesCompiler RulesState
s of
        Maybe (Compiler SomeItem)
Nothing -> RulesState
s
        Just Compiler SomeItem
c  -> RulesState
s
            { rulesCompiler :: Maybe (Compiler SomeItem)
rulesCompiler = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Dependency] -> Compiler ()
compilerTellDependencies [Dependency]
deps forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Compiler SomeItem
c
            }

    -- (2) Adds the dependencies to the compilers that are already in the ruleset
    fixRuleSet :: RuleSet -> RuleSet
fixRuleSet RuleSet
ruleSet = RuleSet
ruleSet
        { rulesCompilers :: [(Identifier, Compiler SomeItem)]
rulesCompilers =
            [ (Identifier
i, [Dependency] -> Compiler ()
compilerTellDependencies [Dependency]
deps forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Compiler SomeItem
c)
            | (Identifier
i, Compiler SomeItem
c) <- RuleSet -> [(Identifier, Compiler SomeItem)]
rulesCompilers RuleSet
ruleSet
            ]
        }