--------------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types                 #-}
module Hakyll.Core.Rules.Internal
    ( RulesRead (..)
    , RuleSet (..)
    , RulesState (..)
    , emptyRulesState
    , Rules (..)
    , runRules
    ) where


--------------------------------------------------------------------------------
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             (MonadFail)
#endif
import           Control.Monad.Reader           (ask)
import           Control.Monad.RWS              (RWST, runRWST)
import           Control.Monad.Trans            (liftIO)
import qualified Data.Map                       as M
import           Data.Set                       (Set)


--------------------------------------------------------------------------------
import           Hakyll.Core.Compiler.Internal
import           Hakyll.Core.Identifier
import           Hakyll.Core.Identifier.Pattern
import           Hakyll.Core.Item.SomeItem
import           Hakyll.Core.Metadata
import           Hakyll.Core.Provider
import           Hakyll.Core.Routes


--------------------------------------------------------------------------------
data RulesRead = RulesRead
    { RulesRead -> Provider
rulesProvider :: Provider
    , RulesRead -> [Identifier]
rulesMatches  :: [Identifier]
    , RulesRead -> Maybe String
rulesVersion  :: Maybe String
    }


--------------------------------------------------------------------------------
data RuleSet = RuleSet
    { -- | Accumulated routes
      RuleSet -> Routes
rulesRoutes    :: Routes
    , -- | Accumulated compilers
      RuleSet -> [(Identifier, Compiler SomeItem)]
rulesCompilers :: [(Identifier, Compiler SomeItem)]
    , -- | A set of the actually used files
      RuleSet -> Set Identifier
rulesResources :: Set Identifier
    , -- | A pattern we can use to check if a file *would* be used. This is
      -- needed for the preview server.
      RuleSet -> Pattern
rulesPattern   :: Pattern
    }


--------------------------------------------------------------------------------
instance Semigroup RuleSet where
    <> :: RuleSet -> RuleSet -> RuleSet
(<>) (RuleSet Routes
r1 [(Identifier, Compiler SomeItem)]
c1 Set Identifier
s1 Pattern
p1) (RuleSet Routes
r2 [(Identifier, Compiler SomeItem)]
c2 Set Identifier
s2 Pattern
p2) =
        Routes
-> [(Identifier, Compiler SomeItem)]
-> Set Identifier
-> Pattern
-> RuleSet
RuleSet (Routes -> Routes -> Routes
forall a. Monoid a => a -> a -> a
mappend Routes
r1 Routes
r2) ([(Identifier, Compiler SomeItem)]
-> [(Identifier, Compiler SomeItem)]
-> [(Identifier, Compiler SomeItem)]
forall a. Monoid a => a -> a -> a
mappend [(Identifier, Compiler SomeItem)]
c1 [(Identifier, Compiler SomeItem)]
c2) (Set Identifier -> Set Identifier -> Set Identifier
forall a. Monoid a => a -> a -> a
mappend Set Identifier
s1 Set Identifier
s2) (Pattern
p1 Pattern -> Pattern -> Pattern
.||. Pattern
p2)

instance Monoid RuleSet where
    mempty :: RuleSet
mempty  = Routes
-> [(Identifier, Compiler SomeItem)]
-> Set Identifier
-> Pattern
-> RuleSet
RuleSet Routes
forall a. Monoid a => a
mempty [(Identifier, Compiler SomeItem)]
forall a. Monoid a => a
mempty Set Identifier
forall a. Monoid a => a
mempty Pattern
forall a. Monoid a => a
mempty
    mappend :: RuleSet -> RuleSet -> RuleSet
mappend = RuleSet -> RuleSet -> RuleSet
forall a. Semigroup a => a -> a -> a
(<>)


--------------------------------------------------------------------------------
data RulesState = RulesState
    { RulesState -> Maybe Routes
rulesRoute    :: Maybe Routes
    , RulesState -> Maybe (Compiler SomeItem)
rulesCompiler :: Maybe (Compiler SomeItem)
    }


--------------------------------------------------------------------------------
emptyRulesState :: RulesState
emptyRulesState :: RulesState
emptyRulesState = Maybe Routes -> Maybe (Compiler SomeItem) -> RulesState
RulesState Maybe Routes
forall a. Maybe a
Nothing Maybe (Compiler SomeItem)
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
-- | The monad used to compose rules
newtype Rules a = Rules
    { forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules :: RWST RulesRead RuleSet RulesState IO a
    } deriving (Applicative Rules
Applicative Rules =>
(forall a b. Rules a -> (a -> Rules b) -> Rules b)
-> (forall a b. Rules a -> Rules b -> Rules b)
-> (forall a. a -> Rules a)
-> Monad Rules
forall a. a -> Rules a
forall a b. Rules a -> Rules b -> Rules b
forall a b. Rules a -> (a -> Rules b) -> Rules b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Rules a -> (a -> Rules b) -> Rules b
>>= :: forall a b. Rules a -> (a -> Rules b) -> Rules b
$c>> :: forall a b. Rules a -> Rules b -> Rules b
>> :: forall a b. Rules a -> Rules b -> Rules b
$creturn :: forall a. a -> Rules a
return :: forall a. a -> Rules a
Monad, Monad Rules
Monad Rules => (forall a. String -> Rules a) -> MonadFail Rules
forall a. String -> Rules a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> Rules a
fail :: forall a. String -> Rules a
MonadFail, (forall a b. (a -> b) -> Rules a -> Rules b)
-> (forall a b. a -> Rules b -> Rules a) -> Functor Rules
forall a b. a -> Rules b -> Rules a
forall a b. (a -> b) -> Rules a -> Rules b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Rules a -> Rules b
fmap :: forall a b. (a -> b) -> Rules a -> Rules b
$c<$ :: forall a b. a -> Rules b -> Rules a
<$ :: forall a b. a -> Rules b -> Rules a
Functor, Functor Rules
Functor Rules =>
(forall a. a -> Rules a)
-> (forall a b. Rules (a -> b) -> Rules a -> Rules b)
-> (forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c)
-> (forall a b. Rules a -> Rules b -> Rules b)
-> (forall a b. Rules a -> Rules b -> Rules a)
-> Applicative Rules
forall a. a -> Rules a
forall a b. Rules a -> Rules b -> Rules a
forall a b. Rules a -> Rules b -> Rules b
forall a b. Rules (a -> b) -> Rules a -> Rules b
forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Rules a
pure :: forall a. a -> Rules a
$c<*> :: forall a b. Rules (a -> b) -> Rules a -> Rules b
<*> :: forall a b. Rules (a -> b) -> Rules a -> Rules b
$cliftA2 :: forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
liftA2 :: forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
$c*> :: forall a b. Rules a -> Rules b -> Rules b
*> :: forall a b. Rules a -> Rules b -> Rules b
$c<* :: forall a b. Rules a -> Rules b -> Rules a
<* :: forall a b. Rules a -> Rules b -> Rules a
Applicative)


--------------------------------------------------------------------------------
instance MonadMetadata Rules where
    getMetadata :: Identifier -> Rules Metadata
getMetadata Identifier
identifier = RWST RulesRead RuleSet RulesState IO Metadata -> Rules Metadata
forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules (RWST RulesRead RuleSet RulesState IO Metadata -> Rules Metadata)
-> RWST RulesRead RuleSet RulesState IO Metadata -> Rules Metadata
forall a b. (a -> b) -> a -> b
$ do
        Provider
provider <- RulesRead -> Provider
rulesProvider (RulesRead -> Provider)
-> RWST RulesRead RuleSet RulesState IO RulesRead
-> RWST RulesRead RuleSet RulesState IO Provider
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST RulesRead RuleSet RulesState IO RulesRead
forall r (m :: * -> *). MonadReader r m => m r
ask
        IO Metadata -> RWST RulesRead RuleSet RulesState IO Metadata
forall a. IO a -> RWST RulesRead RuleSet RulesState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Metadata -> RWST RulesRead RuleSet RulesState IO Metadata)
-> IO Metadata -> RWST RulesRead RuleSet RulesState IO Metadata
forall a b. (a -> b) -> a -> b
$ Provider -> Identifier -> IO Metadata
resourceMetadata Provider
provider Identifier
identifier

    getMatches :: Pattern -> Rules [Identifier]
getMatches Pattern
pattern = RWST RulesRead RuleSet RulesState IO [Identifier]
-> Rules [Identifier]
forall a. RWST RulesRead RuleSet RulesState IO a -> Rules a
Rules (RWST RulesRead RuleSet RulesState IO [Identifier]
 -> Rules [Identifier])
-> RWST RulesRead RuleSet RulesState IO [Identifier]
-> Rules [Identifier]
forall a b. (a -> b) -> a -> b
$ do
        Provider
provider <- RulesRead -> Provider
rulesProvider (RulesRead -> Provider)
-> RWST RulesRead RuleSet RulesState IO RulesRead
-> RWST RulesRead RuleSet RulesState IO Provider
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST RulesRead RuleSet RulesState IO RulesRead
forall r (m :: * -> *). MonadReader r m => m r
ask
        [Identifier] -> RWST RulesRead RuleSet RulesState IO [Identifier]
forall a. a -> RWST RulesRead RuleSet RulesState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Identifier] -> RWST RulesRead RuleSet RulesState IO [Identifier])
-> [Identifier]
-> RWST RulesRead RuleSet RulesState IO [Identifier]
forall a b. (a -> b) -> a -> b
$ Pattern -> [Identifier] -> [Identifier]
filterMatches Pattern
pattern ([Identifier] -> [Identifier]) -> [Identifier] -> [Identifier]
forall a b. (a -> b) -> a -> b
$ Provider -> [Identifier]
resourceList Provider
provider


--------------------------------------------------------------------------------
-- | Run a Rules monad, resulting in a 'RuleSet'
runRules :: Rules a -> Provider -> IO RuleSet
runRules :: forall a. Rules a -> Provider -> IO RuleSet
runRules Rules a
rules Provider
provider = do
    (a
_, RulesState
_, RuleSet
ruleSet) <- RWST RulesRead RuleSet RulesState IO a
-> RulesRead -> RulesState -> IO (a, RulesState, RuleSet)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (Rules a -> RWST RulesRead RuleSet RulesState IO a
forall a. Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules Rules a
rules) RulesRead
env RulesState
emptyRulesState

    -- Ensure compiler uniqueness
    let ruleSet' :: RuleSet
ruleSet' = RuleSet
ruleSet
            { rulesCompilers = M.toList $
                M.fromListWith (flip const) (rulesCompilers ruleSet)
            }

    RuleSet -> IO RuleSet
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RuleSet
ruleSet'
  where
    env :: RulesRead
env = RulesRead
        { rulesProvider :: Provider
rulesProvider = Provider
provider
        , rulesMatches :: [Identifier]
rulesMatches  = []
        , rulesVersion :: Maybe String
rulesVersion  = Maybe String
forall a. Maybe a
Nothing
        }