summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core
diff options
context:
space:
mode:
authorJasper Van der Jeugt <m@jaspervdj.be>2012-11-12 16:10:06 +0100
committerJasper Van der Jeugt <m@jaspervdj.be>2012-11-12 16:10:06 +0100
commit760b4344377c81922ce5ab4ba05a41f88f45165d (patch)
treea2b7f45c61938879e4badce363f03c5abf85ae66 /src/Hakyll/Core
parentc7d3c60c54926b54847bfc691e27f24dc644dd65 (diff)
downloadhakyll-760b4344377c81922ce5ab4ba05a41f88f45165d.tar.gz
WIP
Diffstat (limited to 'src/Hakyll/Core')
-rw-r--r--src/Hakyll/Core/Compiler.hs38
-rw-r--r--src/Hakyll/Core/Compiler/Internal.hs243
-rw-r--r--src/Hakyll/Core/Identifier/Pattern.hs8
-rw-r--r--src/Hakyll/Core/ResourceProvider/Internal.hs8
-rw-r--r--src/Hakyll/Core/ResourceProvider/Modified.hs2
-rw-r--r--src/Hakyll/Core/Routes.hs40
-rw-r--r--src/Hakyll/Core/Rules.hs37
-rw-r--r--src/Hakyll/Core/Rules/Internal.hs6
8 files changed, 171 insertions, 211 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 31b25e3..ef9b03c 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -116,7 +116,7 @@ module Hakyll.Core.Compiler
import Prelude hiding ((.), id)
import Control.Arrow ((>>>), (&&&), arr, first)
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (*>))
import Control.Exception (SomeException, handle)
import Control.Monad.Reader (ask)
import Control.Monad.Trans (liftIO)
@@ -144,7 +144,7 @@ import qualified Hakyll.Core.Store as Store
-- | Run a compiler, yielding the resulting target and it's dependencies. This
-- version of 'runCompilerJob' also stores the result
--
-runCompiler :: Compiler () CompiledItem -- ^ Compiler to run
+runCompiler :: Compiler CompiledItem -- ^ Compiler to run
-> Identifier () -- ^ Target identifier
-> ResourceProvider -- ^ Resource provider
-> [Identifier ()] -- ^ Universe
@@ -174,18 +174,18 @@ runCompiler compiler id' provider universe routes store modified logger = do
-- | Get the identifier of the item that is currently being compiled
--
-getIdentifier :: Compiler a (Identifier b)
+getIdentifier :: Compiler (Identifier b)
getIdentifier = fromJob $ const $ CompilerM $
castIdentifier . compilerIdentifier <$> ask
-- | Get the route we are using for this item
--
-getRoute :: Compiler a (Maybe FilePath)
+getRoute :: Compiler (Maybe FilePath)
getRoute = getIdentifier >>> getRouteFor
-- | Get the route for a specified item
--
-getRouteFor :: Compiler (Identifier a) (Maybe FilePath)
+getRouteFor :: Compiler (Identifier a -> Maybe FilePath)
getRouteFor = fromJob $ \identifier -> CompilerM $ do
routes <- compilerRoutes <$> ask
return $ runRoutes routes identifier
@@ -193,27 +193,27 @@ getRouteFor = fromJob $ \identifier -> CompilerM $ do
--------------------------------------------------------------------------------
-- | Get the body of the underlying resource
-getResourceBody :: Compiler a String
+getResourceBody :: Compiler String
getResourceBody = getResourceWith resourceBody
--------------------------------------------------------------------------------
-- | Get the resource we are compiling as a string
-getResourceString :: Compiler a String
+getResourceString :: Compiler String
getResourceString = getResourceWith $ const resourceString
--------------------------------------------------------------------------------
-- | Get the resource we are compiling as a lazy bytestring
--
-getResourceLBS :: Compiler a ByteString
+getResourceLBS :: Compiler ByteString
getResourceLBS = getResourceWith $ const resourceLBS
--------------------------------------------------------------------------------
-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
-getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler c b
+getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler b
getResourceWith reader = fromJob $ \_ -> CompilerM $ do
provider <- compilerResourceProvider <$> ask
r <- compilerIdentifier <$> ask
@@ -251,13 +251,14 @@ getDependency id' = CompilerM $ do
--
require_ :: (Binary a, Typeable a, Writable a)
=> Identifier a
- -> Compiler b a
+ -> Compiler a
require_ identifier =
fromDependency identifier >>> fromJob (const $ getDependency identifier)
-- | Require another target. Using this function ensures automatic handling of
-- dependencies
--
+{-
require :: (Binary a, Typeable a, Writable a)
=> Identifier a
-> (b -> a -> c)
@@ -271,13 +272,14 @@ requireA :: (Binary a, Typeable a, Writable a)
-> Compiler (b, a) c
-> Compiler b c
requireA identifier = (id &&& require_ identifier >>>)
+-}
-- | Variant of 'requireAll' which drops the current value
--
requireAll_ :: (Binary a, Typeable a, Writable a)
=> Pattern a
- -> Compiler b [a]
-requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
+ -> Compiler [a]
+requireAll_ pattern = fromDependencies (const getDeps) *> fromJob requireAll_'
where
getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
requireAll_' = const $ CompilerM $ do
@@ -287,6 +289,7 @@ requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
-- | Require a number of targets. Using this function ensures automatic handling
-- of dependencies
--
+{-
requireAll :: (Binary a, Typeable a, Writable a)
=> Pattern a
-> (b -> [a] -> c)
@@ -300,12 +303,13 @@ requireAllA :: (Binary a, Typeable a, Writable a)
-> Compiler (b, [a]) c
-> Compiler b c
requireAllA pattern = (id &&& requireAll_ pattern >>>)
+-}
cached :: (Binary a, Typeable a, Writable a)
=> String
- -> Compiler () a
- -> Compiler () a
-cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
+ -> Compiler a
+ -> Compiler a
+cached name (Compiler d j) = Compiler d $ CompilerM $ do
logger <- compilerLogger <$> ask
identifier <- castIdentifier . compilerIdentifier <$> ask
store <- compilerStore <$> ask
@@ -326,8 +330,8 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
-- | Create an unsafe compiler from a function in IO
--
-unsafeCompiler :: (a -> IO b) -- ^ Function to lift
- -> Compiler a b -- ^ Resulting compiler
+unsafeCompiler :: (a -> IO b) -- ^ Function to lift
+ -> Compiler (a -> b) -- ^ Resulting compiler
unsafeCompiler f = fromJob $ CompilerM . liftIO . f
-- | Compiler for debugging purposes
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 16863f8..cac5948 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -1,63 +1,35 @@
--------------------------------------------------------------------------------
-- | Internally used compiler module
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Core.Compiler.Internal
- ( Dependencies
- , DependencyEnvironment (..)
- , CompilerEnvironment (..)
- , Throwing
- , CompilerM (..)
+ ( CompilerRead (..)
, Compiler (..)
- , runCompilerJob
- , runCompilerDependencies
- , fromJob
- , fromDependencies
- , fromDependency
+ , compilerTell
+ , compilerAsk
+ , compilerThrow
+ , compilerCatch
) where
--------------------------------------------------------------------------------
-import Control.Applicative (Alternative (..), Applicative,
- pure, (<$>), (<*>))
-import Control.Arrow
-import Control.Category (Category, id, (.))
-import Control.Monad (liftM2, (<=<))
-import Control.Monad.Error (ErrorT, catchError, runErrorT,
- throwError)
-import Control.Monad.Reader (Reader, ReaderT, ask, runReader,
- runReaderT)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Prelude hiding (id, (.))
+import Control.Applicative (Alternative (..),
+ Applicative (..))
+import Data.Monoid (mappend, mempty)
--------------------------------------------------------------------------------
+import Hakyll.Core.Dependencies
import Hakyll.Core.Identifier
import Hakyll.Core.Logger
import Hakyll.Core.ResourceProvider
import Hakyll.Core.Routes
import Hakyll.Core.Store
-import Hakyll.Core.Util.Arrow
-
-
---------------------------------------------------------------------------------
--- | A set of dependencies
-type Dependencies = Set (Identifier ())
-
-
---------------------------------------------------------------------------------
--- | Environment in which the dependency analyzer runs
-data DependencyEnvironment = DependencyEnvironment
- { -- | Target identifier
- dependencyIdentifier :: Identifier ()
- , -- | List of available identifiers we can depend upon
- dependencyUniverse :: [Identifier ()]
- }
--------------------------------------------------------------------------------
-- | Environment in which a compiler runs
-data CompilerEnvironment = CompilerEnvironment
+data CompilerRead = CompilerRead
{ -- | Target identifier
compilerIdentifier :: Identifier ()
, -- | Resource provider
@@ -76,164 +48,127 @@ data CompilerEnvironment = CompilerEnvironment
--------------------------------------------------------------------------------
--- | A calculation possibly throwing an error
-type Throwing a = Either String a
+type CompilerWrite = [Dependency]
--------------------------------------------------------------------------------
--- | The compiler monad
-newtype CompilerM a = CompilerM
- { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
- } deriving (Monad, Functor, Applicative)
+data CompilerResult a where
+ CompilerDone :: a -> CompilerWrite -> CompilerResult a
+ CompilerError :: String -> CompilerResult a
+ CompilerRequire :: Identifier b -> (b -> Compiler a) -> CompilerResult a
--------------------------------------------------------------------------------
--- | The compiler arrow
-data Compiler a b = Compiler
- { compilerDependencies :: Reader DependencyEnvironment Dependencies
- , compilerJob :: a -> CompilerM b
+newtype Compiler a = Compiler
+ { unCompiler :: CompilerRead -> IO (CompilerResult a)
}
--------------------------------------------------------------------------------
-instance Functor (Compiler a) where
- fmap f (Compiler d j) = Compiler d $ fmap f . j
+instance Functor Compiler where
+ fmap f (Compiler c) = Compiler $ \r -> do
+ res <- c r
+ return $ case res of
+ CompilerDone x w -> CompilerDone (f x) w
+ CompilerError e -> CompilerError e
+ CompilerRequire i g -> CompilerRequire i (\x -> fmap f (g x))
{-# INLINE fmap #-}
--------------------------------------------------------------------------------
-instance Applicative (Compiler a) where
- pure = fromJob . const . return
- {-# INLINE pure #-}
+instance Monad Compiler where
+ return x = Compiler $ \_ -> return $ CompilerDone x mempty
+ {-# INLINE return #-}
- Compiler d1 j1 <*> Compiler d2 j2 =
- Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x
- {-# INLINE (<*>) #-}
-
-
---------------------------------------------------------------------------------
-instance Alternative (Compiler a) where
- empty = fromJob $ const $ CompilerM $
- throwError "Hakyll.Core.Compiler.Internal: empty alternative"
+ Compiler c >>= f = Compiler $ \r -> do
+ res <- c r
+ case res of
+ CompilerDone x w -> do
+ res' <- unCompiler (f x) r
+ return $ case res' of
+ CompilerDone y w' -> CompilerDone y (w `mappend` w')
+ CompilerError e -> CompilerError e
+ CompilerRequire i g -> CompilerRequire i $ \z -> do
+ compilerTell w -- Save dependencies!
+ g z
- Compiler d1 j1 <|> Compiler d2 j2 =
- Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $
- catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x)
- {-# INLINE (<|>) #-}
+ CompilerError e -> return $ CompilerError e
+ CompilerRequire i g -> return $ CompilerRequire i $ \z -> g z >>= f
+ {-# INLINE (>>=) #-}
--------------------------------------------------------------------------------
-instance Category Compiler where
- id = Compiler (return S.empty) return
- {-# INLINE id #-}
+instance Applicative Compiler where
+ pure x = return x
+ {-# INLINE pure #-}
- Compiler d1 j1 . Compiler d2 j2 =
- Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
- {-# INLINE (.) #-}
+ f <*> x = f >>= \f' -> fmap f' x
+ {-# INLINE (<*>) #-}
--------------------------------------------------------------------------------
-instance Arrow Compiler where
- arr f = fromJob (return . f)
- {-# INLINE arr #-}
-
- first (Compiler d j) = Compiler d $ \(x, y) -> do
- x' <- j x
- return (x', y)
- {-# INLINE first #-}
-
- second (Compiler d j) = Compiler d $ \(x, y) -> do
- y' <- j y
- return (x, y')
- {-# INLINE second #-}
+instance Alternative Compiler where
+ empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
+ x <|> y = compilerCatch x (\_ -> y)
+ {-# INLINE (<|>) #-}
- Compiler d1 j1 *** Compiler d2 j2 =
- Compiler (liftM2 S.union d1 d2) $ \(x, y) -> do
- x' <- j1 x
- y' <- j2 y
- return (x', y')
- {-# INLINE (***) #-}
- Compiler d1 j1 &&& Compiler d2 j2 =
- Compiler (liftM2 S.union d1 d2) $ \x -> do
- y1 <- j1 x
- y2 <- j2 x
- return (y1, y2)
- {-# INLINE (&&&) #-}
+--------------------------------------------------------------------------------
+compilerAsk :: Compiler CompilerRead
+compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
+{-# INLINE compilerAsk #-}
--------------------------------------------------------------------------------
-instance ArrowChoice Compiler where
- left (Compiler d j) = Compiler d $ \e -> case e of
- Left l -> Left <$> j l
- Right r -> Right <$> return r
- {-# INLINE left #-}
-
- Compiler d1 j1 ||| Compiler d2 j2 = Compiler (liftM2 S.union d1 d2) $
- \e -> case e of Left x -> j1 x; Right y -> j2 y
- {-# INLINE (|||) #-}
+compilerTell :: [Dependency] -> Compiler ()
+compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
+{-# INLINE compilerTell #-}
--------------------------------------------------------------------------------
-instance ArrowMap Compiler where
- mapA (Compiler d j) = Compiler d $ mapM j
- {-# INLINE mapA #-}
+compilerThrow :: String -> Compiler a
+compilerThrow e = Compiler $ \_ -> return $ CompilerError e
+{-# INLINE compilerThrow #-}
--------------------------------------------------------------------------------
--- | Run a compiler, yielding the resulting target
-runCompilerJob :: Compiler () a -- ^ Compiler to run
- -> Identifier () -- ^ Target identifier
- -> ResourceProvider -- ^ Resource provider
- -> [Identifier ()] -- ^ Universe
- -> Routes -- ^ Route
- -> Store -- ^ Store
- -> Bool -- ^ Was the resource modified?
- -> Logger -- ^ Logger
- -> IO (Throwing a) -- ^ Result
-runCompilerJob compiler id' provider universe route store modified logger =
- runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env
- where
- env = CompilerEnvironment
- { compilerIdentifier = id'
- , compilerResourceProvider = provider
- , compilerUniverse = universe
- , compilerRoutes = route
- , compilerStore = store
- , compilerResourceModified = modified
- , compilerLogger = logger
- }
+compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
+compilerCatch (Compiler x) f = Compiler $ \r -> do
+ res <- x r
+ case res of
+ CompilerError e -> unCompiler (f e) r
+ _ -> return res
+{-# INLINE compilerCatch #-}
+{-
--------------------------------------------------------------------------------
-runCompilerDependencies :: Compiler () a
- -> Identifier ()
- -> [Identifier ()]
- -> Dependencies
-runCompilerDependencies compiler identifier universe =
- runReader (compilerDependencies compiler) env
- where
- env = DependencyEnvironment
- { dependencyIdentifier = identifier
- , dependencyUniverse = universe
- }
+-- | The compiler monad
+newtype CompilerM a = CompilerM
+ { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
+ } deriving (Monad, Functor, Applicative)
--------------------------------------------------------------------------------
-fromJob :: (a -> CompilerM b) -> Compiler a b
-fromJob = Compiler $ return S.empty
-{-# INLINE fromJob #-}
+-- | The compiler arrow
+data Compiler a = Compiler
+ { compilerDependencies :: Reader DependencyEnvironment Dependencies
+ , compilerJob :: CompilerM a
+ }
--------------------------------------------------------------------------------
-fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
- -> Compiler b b
-fromDependencies collectDeps = flip Compiler return $ do
- DependencyEnvironment identifier universe <- ask
- return $ S.fromList $ collectDeps identifier universe
+instance Functor Compiler where
+ fmap f (Compiler d j) = Compiler d $ fmap f j
+ {-# INLINE fmap #-}
--------------------------------------------------------------------------------
--- | Wait until another compiler has finished before running this compiler
-fromDependency :: Identifier a -> Compiler b b
-fromDependency = fromDependencies . const . const . return . castIdentifier
+instance Applicative Compiler where
+ pure = fromJob . return
+ {-# INLINE pure #-}
+
+ Compiler d1 j1 <*> Compiler d2 j2 =
+ Compiler (liftM2 S.union d1 d2) $ j1 <*> j2
+ {-# INLINE (<*>) #-}
+-}
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index 589bf6a..dc02be3 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -43,6 +43,7 @@ module Hakyll.Core.Identifier.Pattern
, fromGlob
, fromList
, fromRegex
+ , fromVersion
-- * Manipulating patterns
, complement
@@ -176,6 +177,11 @@ fromRegex = Regex
--------------------------------------------------------------------------------
+fromVersion :: Maybe String -> Pattern a
+fromVersion = Version
+
+
+--------------------------------------------------------------------------------
-- | Inverts a pattern, e.g.
--
-- > complement "foo/bar.html"
@@ -190,7 +196,7 @@ complement = Complement
--
-- > "foo/*.markdown" `withVersion` "pdf"
withVersion :: Pattern a -> String -> Pattern a
-withVersion p v = And p $ Version $ Just v
+withVersion p v = And p $ fromVersion $ Just v
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/ResourceProvider/Internal.hs b/src/Hakyll/Core/ResourceProvider/Internal.hs
index 1f8f776..02ff98c 100644
--- a/src/Hakyll/Core/ResourceProvider/Internal.hs
+++ b/src/Hakyll/Core/ResourceProvider/Internal.hs
@@ -48,7 +48,7 @@ newResourceProvider :: Store -- ^ Store to use
-> FilePath -- ^ Search directory
-> IO ResourceProvider -- ^ Resulting provider
newResourceProvider store ignore directory = do
- list <- map parseIdentifier . filter (not . ignore) <$>
+ list <- map fromFilePath . filter (not . ignore) <$>
getRecursiveContents False directory
cache <- newIORef M.empty
return $ ResourceProvider (S.fromList list) cache store
@@ -60,10 +60,10 @@ resourceList = S.toList . resourceSet
--------------------------------------------------------------------------------
--- | Check if a given resiyrce exists
+-- | Check if a given resource exists
resourceExists :: ResourceProvider -> Identifier a -> Bool
resourceExists provider =
- (`S.member` resourceSet provider) . setGroup Nothing . castIdentifier
+ (`S.member` resourceSet provider) . setVersion Nothing . castIdentifier
--------------------------------------------------------------------------------
@@ -71,7 +71,7 @@ resourceExists provider =
-- filename)
resourceMetadataResource :: Identifier a -> Identifier ()
resourceMetadataResource =
- parseIdentifier . flip addExtension "metadata" . toFilePath
+ fromFilePath . flip addExtension "metadata" . toFilePath
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/ResourceProvider/Modified.hs b/src/Hakyll/Core/ResourceProvider/Modified.hs
index 837bc8c..0da3d0f 100644
--- a/src/Hakyll/Core/ResourceProvider/Modified.hs
+++ b/src/Hakyll/Core/ResourceProvider/Modified.hs
@@ -47,7 +47,7 @@ resourceModified rp r
return m
where
- normalized = castIdentifier $ setGroup Nothing r
+ normalized = castIdentifier $ setVersion Nothing r
exists = resourceExists rp r
store = resourceStore rp
cacheRef = resourceModifiedCache rp
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index 25e3a14..63e32e7 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -1,3 +1,4 @@
+--------------------------------------------------------------------------------
-- | Once a target is compiled, the user usually wants to save it to the disk.
-- This is where the 'Routes' type comes in; it determines where a certain
-- target should be written.
@@ -24,7 +25,6 @@
-- not appear in your site directory.
--
-- * If an item matches multiple routes, the first rule will be chosen.
---
{-# LANGUAGE Rank2Types #-}
module Hakyll.Core.Routes
( Routes
@@ -38,33 +38,44 @@ module Hakyll.Core.Routes
, composeRoutes
) where
+
+--------------------------------------------------------------------------------
import Data.Monoid (Monoid, mempty, mappend)
import Control.Monad (mplus)
import System.FilePath (replaceExtension)
+
+--------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.Util.String
+
+--------------------------------------------------------------------------------
-- | Type used for a route
---
newtype Routes = Routes {unRoutes :: forall a. Identifier a -> Maybe FilePath}
+
+--------------------------------------------------------------------------------
instance Monoid Routes where
mempty = Routes $ const Nothing
mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'
+
+--------------------------------------------------------------------------------
-- | Apply a route to an identifier
---
runRoutes :: Routes -> Identifier a -> Maybe FilePath
runRoutes = unRoutes
+
+--------------------------------------------------------------------------------
-- | A route that uses the identifier as filepath. For example, the target with
-- ID @foo\/bar@ will be written to the file @foo\/bar@.
---
idRoute :: Routes
idRoute = Routes $ Just . toFilePath
+
+--------------------------------------------------------------------------------
-- | Set (or replace) the extension of a route.
--
-- Example:
@@ -82,29 +93,34 @@ idRoute = Routes $ Just . toFilePath
-- Result:
--
-- > Just "posts/the-art-of-trolling.html"
---
setExtension :: String -> Routes
-setExtension extension = Routes $ fmap (`replaceExtension` extension)
- . unRoutes idRoute
+setExtension extension = Routes $
+ fmap (`replaceExtension` extension) . unRoutes idRoute
+
+--------------------------------------------------------------------------------
-- | Apply the route if the identifier matches the given pattern, fail
-- otherwise
---
matchRoute :: Pattern a -> Routes -> Routes
matchRoute pattern (Routes route) = Routes $ \id' ->
if matches pattern (castIdentifier id') then route id' else Nothing
+
+--------------------------------------------------------------------------------
-- | Create a custom route. This should almost always be used with
-- 'matchRoute'
---
customRoute :: (Identifier a -> FilePath) -> Routes
customRoute f = Routes $ Just . f . castIdentifier
+
+--------------------------------------------------------------------------------
-- | A route that always gives the same result. Obviously, you should only use
-- this for a single compilation rule.
constRoute :: FilePath -> Routes
constRoute = customRoute . const
+
+--------------------------------------------------------------------------------
-- | Create a gsub route
--
-- Example:
@@ -114,13 +130,14 @@ constRoute = customRoute . const
-- Result:
--
-- > Just "tags/bar.xml"
---
gsubRoute :: String -- ^ Pattern
-> (String -> String) -- ^ Replacement
-> Routes -- ^ Resulting route
gsubRoute pattern replacement = customRoute $
replaceAll pattern replacement . toFilePath
+
+--------------------------------------------------------------------------------
-- | Compose routes so that @f `composeRoutes` g@ is more or less equivalent
-- with @f >>> g@.
--
@@ -134,10 +151,9 @@ gsubRoute pattern replacement = customRoute $
-- > Just "tags/bar.xml"
--
-- If the first route given fails, Hakyll will not apply the second route.
---
composeRoutes :: Routes -- ^ First route to apply
-> Routes -- ^ Second route to apply
-> Routes -- ^ Resulting route
composeRoutes (Routes f) (Routes g) = Routes $ \i -> do
p <- f i
- g $ parseIdentifier p
+ g $ fromFilePath p
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index ba89d75..c481977 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -31,7 +31,7 @@ module Hakyll.Core.Rules
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
-import Control.Arrow (arr, (***), (>>>))
+import Control.Arrow ((***))
import Control.Monad.Reader (ask, local)
import Control.Monad.State (get, put)
import Control.Monad.Writer (tell)
@@ -64,14 +64,12 @@ tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
--------------------------------------------------------------------------------
-- | Add a number of compilers
tellCompilers :: (Binary a, Typeable a, Writable a)
- => [(Identifier a, Compiler () a)]
+ => [(Identifier a, Compiler a)]
-> Rules
tellCompilers compilers = RulesM $ do
-- We box the compilers so they have a more simple type
- let compilers' = map (castIdentifier *** boxCompiler) compilers
+ let compilers' = map (castIdentifier *** fmap compiledItem) compilers
tell $ RuleSet mempty compilers' mempty
- where
- boxCompiler = (>>> arr compiledItem)
--------------------------------------------------------------------------------
@@ -123,9 +121,9 @@ match pattern = RulesM . local addPredicate . unRulesM
-- This will put the compiler for the raw content in a separate group
-- (@\"raw\"@), which causes it to be compiled as well.
group :: String -> RulesM a -> RulesM a
-group g = RulesM . local setGroup' . unRulesM
+group g = RulesM . local setVersion' . unRulesM
where
- setGroup' env = env { rulesGroup = Just g }
+ setVersion' env = env {rulesVersion = Just g}
--------------------------------------------------------------------------------
@@ -135,12 +133,12 @@ group g = RulesM . local setGroup' . unRulesM
-- no resources match the current selection, nothing will happen. In this case,
-- you might want to have a look at 'create'.
compile :: (Binary a, Typeable a, Writable a)
- => Compiler () a -> RulesM (Pattern a)
+ => Compiler a -> RulesM (Pattern a)
compile compiler = do
ids <- resources
tellCompilers [(castIdentifier id', compiler) | id' <- ids]
tellResources ids
- return $ list $ map castIdentifier ids
+ return $ fromList $ map castIdentifier ids
--------------------------------------------------------------------------------
@@ -153,10 +151,10 @@ compile compiler = do
-- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been
-- used).
create :: (Binary a, Typeable a, Writable a)
- => Identifier a -> Compiler () a -> RulesM (Identifier a)
+ => Identifier a -> Compiler a -> RulesM (Identifier a)
create id' compiler = RulesM $ do
- group' <- rulesGroup <$> ask
- let id'' = setGroup group' id'
+ version' <- rulesVersion <$> ask
+ let id'' = setVersion version' id'
unRulesM $ tellCompilers [(id'', compiler)]
return id''
@@ -168,10 +166,11 @@ create id' compiler = RulesM $ do
route :: Routes -> Rules
route route' = RulesM $ do
-- We want the route only to be applied if we match the current pattern and
- -- group
- pattern <- rulesPattern <$> ask
- group' <- rulesGroup <$> ask
- unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route'
+ -- version
+ pattern <- rulesPattern <$> ask
+ version' <- rulesVersion <$> ask
+ unRulesM $ tellRoute $ matchRoute
+ (pattern `mappend` fromVersion version') route'
--------------------------------------------------------------------------------
@@ -181,8 +180,8 @@ resources :: RulesM [Identifier ()]
resources = RulesM $ do
pattern <- rulesPattern <$> ask
provider <- rulesResourceProvider <$> ask
- g <- rulesGroup <$> ask
- return $ filterMatches pattern $ map (setGroup g) $ resourceList provider
+ g <- rulesVersion <$> ask
+ return $ filterMatches pattern $ map (setVersion g) $ resourceList provider
--------------------------------------------------------------------------------
@@ -193,6 +192,6 @@ freshIdentifier :: String -- ^ Prefix
freshIdentifier prefix = RulesM $ do
state <- get
let index = rulesNextIdentifier state
- id' = parseIdentifier $ prefix ++ "/" ++ show index
+ id' = fromFilePath $ prefix ++ "/" ++ show index
put $ state {rulesNextIdentifier = index + 1}
return id'
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index dc2badd..ec3714c 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -35,7 +35,7 @@ data RuleSet = RuleSet
{ -- | Routes used in the compilation structure
rulesRoutes :: Routes
, -- | Compilation rules
- rulesCompilers :: [(Identifier (), Compiler () CompiledItem)]
+ rulesCompilers :: [(Identifier (), Compiler CompiledItem)]
, -- | A set of the actually used files
rulesResources :: Set (Identifier ())
}
@@ -60,7 +60,7 @@ data RuleState = RuleState
data RuleEnvironment = RuleEnvironment
{ rulesResourceProvider :: ResourceProvider
, rulesPattern :: forall a. Pattern a
- , rulesGroup :: Maybe String
+ , rulesVersion :: Maybe String
}
@@ -88,7 +88,7 @@ runRules rules provider = do
env = RuleEnvironment
{ rulesResourceProvider = provider
, rulesPattern = mempty
- , rulesGroup = Nothing
+ , rulesVersion = Nothing
}