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


--------------------------------------------------------------------------------
import           Control.Monad.Fail             (MonadFail)
import           Control.Monad.Reader           (ask)
import           Control.Monad.RWS              (RWST, runRWST)
import           Control.Monad.Trans            (liftIO)
import qualified Data.Map                       as M
#if MIN_VERSION_base(4,9,0)
import           Data.Semigroup                 (Semigroup (..))
#endif
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
    }


--------------------------------------------------------------------------------
#if MIN_VERSION_base(4,9,0)
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
(<>)
#else
instance Monoid RuleSet where
    mempty = RuleSet mempty mempty mempty mempty
    mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =
        RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)
#endif


--------------------------------------------------------------------------------
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
    { Rules a -> RWST RulesRead RuleSet RulesState IO a
unRules :: RWST RulesRead RuleSet RulesState IO a
    } deriving (Applicative Rules
a -> Rules a
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
Rules a -> (a -> Rules b) -> Rules b
Rules a -> Rules b -> Rules b
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
return :: a -> Rules a
$creturn :: forall a. a -> Rules a
>> :: Rules a -> Rules b -> Rules b
$c>> :: forall a b. Rules a -> Rules b -> Rules b
>>= :: Rules a -> (a -> Rules b) -> Rules b
$c>>= :: forall a b. Rules a -> (a -> Rules b) -> Rules b
$cp1Monad :: Applicative Rules
Monad, Monad Rules
Monad Rules -> (forall a. String -> Rules a) -> MonadFail Rules
String -> Rules a
forall a. String -> Rules a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> Rules a
$cfail :: forall a. String -> Rules a
$cp1MonadFail :: Monad Rules
MonadFail, a -> Rules b -> Rules a
(a -> b) -> Rules a -> Rules b
(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
<$ :: a -> Rules b -> Rules a
$c<$ :: forall a b. a -> Rules b -> Rules a
fmap :: (a -> b) -> Rules a -> Rules b
$cfmap :: forall a b. (a -> b) -> Rules a -> Rules b
Functor, Functor Rules
a -> Rules a
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
Rules a -> Rules b -> Rules b
Rules a -> Rules b -> Rules a
Rules (a -> b) -> Rules a -> Rules b
(a -> b -> c) -> Rules a -> Rules b -> Rules c
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
<* :: Rules a -> Rules b -> Rules a
$c<* :: forall a b. Rules a -> Rules b -> Rules a
*> :: Rules a -> Rules b -> Rules b
$c*> :: forall a b. Rules a -> Rules b -> Rules b
liftA2 :: (a -> b -> c) -> Rules a -> Rules b -> Rules c
$cliftA2 :: forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
<*> :: Rules (a -> b) -> Rules a -> Rules b
$c<*> :: forall a b. Rules (a -> b) -> Rules a -> Rules b
pure :: a -> Rules a
$cpure :: forall a. a -> Rules a
$cp1Applicative :: Functor Rules
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 (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 (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 :: 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 :: [(Identifier, Compiler SomeItem)]
rulesCompilers = Map Identifier (Compiler SomeItem)
-> [(Identifier, Compiler SomeItem)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Identifier (Compiler SomeItem)
 -> [(Identifier, Compiler SomeItem)])
-> Map Identifier (Compiler SomeItem)
-> [(Identifier, Compiler SomeItem)]
forall a b. (a -> b) -> a -> b
$
                (Compiler SomeItem -> Compiler SomeItem -> Compiler SomeItem)
-> [(Identifier, Compiler SomeItem)]
-> Map Identifier (Compiler SomeItem)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith ((Compiler SomeItem -> Compiler SomeItem -> Compiler SomeItem)
-> Compiler SomeItem -> Compiler SomeItem -> Compiler SomeItem
forall a b c. (a -> b -> c) -> b -> a -> c
flip Compiler SomeItem -> Compiler SomeItem -> Compiler SomeItem
forall a b. a -> b -> a
const) (RuleSet -> [(Identifier, Compiler SomeItem)]
rulesCompilers RuleSet
ruleSet)
            }

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