summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJasper Van der Jeugt <jaspervdj@gmail.com>2011-04-06 14:05:29 +0200
committerJasper Van der Jeugt <jaspervdj@gmail.com>2011-04-06 14:05:29 +0200
commit80596b1f56b7d6f2d4ff64d566ae845b7c7a01f6 (patch)
treebf6b02d68833821f7b57f40edc8dd8a60543fa09 /src
parentc3dbb0ca77f65461e60cb801b867fff18afda2be (diff)
parentce444a426ac037c2b32568d8e6325aa5762bf913 (diff)
downloadhakyll-80596b1f56b7d6f2d4ff64d566ae845b7c7a01f6.tar.gz
Merge branch 'master' into dependency-analyzer
Diffstat (limited to 'src')
-rw-r--r--src/Hakyll.hs6
-rw-r--r--src/Hakyll/Core/Compiler.hs5
-rw-r--r--src/Hakyll/Core/Compiler/Internal.hs2
-rw-r--r--src/Hakyll/Core/Identifier/Pattern.hs128
-rw-r--r--src/Hakyll/Core/Resource.hs14
-rw-r--r--src/Hakyll/Core/Resource/Provider.hs (renamed from src/Hakyll/Core/ResourceProvider.hs)38
-rw-r--r--src/Hakyll/Core/Resource/Provider/File.hs (renamed from src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs)11
-rw-r--r--src/Hakyll/Core/Routes.hs16
-rw-r--r--src/Hakyll/Core/Rules.hs53
-rw-r--r--src/Hakyll/Core/Rules/Internal.hs19
-rw-r--r--src/Hakyll/Core/Run.hs9
-rw-r--r--src/Hakyll/Core/Util/File.hs2
-rw-r--r--src/Hakyll/Core/Writable/CopyFile.hs2
-rw-r--r--src/Hakyll/Web/CompressCss.hs2
-rw-r--r--src/Hakyll/Web/Page.hs2
-rw-r--r--src/Hakyll/Web/Tags.hs88
-rw-r--r--src/Hakyll/Web/Template.hs2
17 files changed, 269 insertions, 130 deletions
diff --git a/src/Hakyll.hs b/src/Hakyll.hs
index 5fe1f26..341bb53 100644
--- a/src/Hakyll.hs
+++ b/src/Hakyll.hs
@@ -5,7 +5,8 @@ module Hakyll
, module Hakyll.Core.Configuration
, module Hakyll.Core.Identifier
, module Hakyll.Core.Identifier.Pattern
- , module Hakyll.Core.ResourceProvider
+ , module Hakyll.Core.Resource
+ , module Hakyll.Core.Resource.Provider
, module Hakyll.Core.Routes
, module Hakyll.Core.Rules
, module Hakyll.Core.UnixFilter
@@ -34,7 +35,8 @@ import Hakyll.Core.Compiler
import Hakyll.Core.Configuration
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
+import Hakyll.Core.Resource.Provider
import Hakyll.Core.Routes
import Hakyll.Core.Rules
import Hakyll.Core.UnixFilter
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 371594f..db51131 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -124,7 +124,8 @@ import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.CompiledItem
import Hakyll.Core.Writable
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
+import Hakyll.Core.Resource.Provider
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Store
import Hakyll.Core.Rules.Internal
@@ -237,7 +238,7 @@ requireAll_ :: (Binary a, Typeable a, Writable a)
-> Compiler b [a]
requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
where
- getDeps = matches pattern . map unResource . resourceList
+ getDeps = filterMatches pattern . map unResource . resourceList
requireAll_' = const $ CompilerM $ do
deps <- getDeps . compilerResourceProvider <$> ask
mapM (unCompilerM . getDependency) deps
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 4eef91c..1a3c4c3 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -26,7 +26,7 @@ import Control.Category (Category, (.), id)
import Control.Arrow (Arrow, ArrowChoice, arr, first, left)
import Hakyll.Core.Identifier
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource.Provider
import Hakyll.Core.Store
import Hakyll.Core.Routes
import Hakyll.Core.Logger
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index a1e36df..8f3ac01 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -1,4 +1,12 @@
-- | Module providing pattern matching and capturing on 'Identifier's.
+-- 'Pattern's come in two kinds:
+--
+-- * Simple glob patterns, like @foo\/*@;
+--
+-- * Custom, arbitrary predicates of the type @Identifier -> Bool@.
+--
+-- They both have advantages and disadvantages. By default, globs are used,
+-- unless you construct your 'Pattern' using the 'predicate' function.
--
-- A very simple pattern could be, for example, @foo\/bar@. This pattern will
-- only match the exact @foo\/bar@ identifier.
@@ -20,15 +28,17 @@
--
-- * @foo\/*.html@ will match all HTML files in the @foo\/@ directory.
--
--- The 'match' function allows the user to get access to the elements captured
+-- The 'capture' function allows the user to get access to the elements captured
-- by the capture elements in the pattern.
--
module Hakyll.Core.Identifier.Pattern
( Pattern
- , parsePattern
- , match
- , doesMatch
+ , parseGlob
+ , predicate
+ , regex
, matches
+ , filterMatches
+ , capture
, fromCapture
, fromCaptureString
, fromCaptures
@@ -37,32 +47,39 @@ module Hakyll.Core.Identifier.Pattern
import Data.List (isPrefixOf, inits, tails)
import Control.Arrow ((&&&), (>>>))
import Control.Monad (msum)
-import Data.Maybe (isJust)
-import Data.Monoid (mempty, mappend)
+import Data.Maybe (isJust, fromMaybe)
+import Data.Monoid (Monoid, mempty, mappend)
import GHC.Exts (IsString, fromString)
+import Text.Regex.PCRE ((=~~))
import Hakyll.Core.Identifier
-- | One base element of a pattern
--
-data PatternComponent = Capture
- | CaptureMany
- | Literal String
- deriving (Eq, Show)
+data GlobComponent = Capture
+ | CaptureMany
+ | Literal String
+ deriving (Eq, Show)
-- | Type that allows matching on identifiers
--
-newtype Pattern = Pattern {unPattern :: [PatternComponent]}
- deriving (Eq, Show)
+data Pattern = Glob [GlobComponent]
+ | Predicate (Identifier -> Bool)
instance IsString Pattern where
- fromString = parsePattern
+ fromString = parseGlob
+
+instance Monoid Pattern where
+ mempty = Predicate (const True)
+ g@(Glob _) `mappend` x = Predicate (matches g) `mappend` x
+ x `mappend` g@(Glob _) = x `mappend` Predicate (matches g)
+ Predicate f `mappend` Predicate g = Predicate $ \i -> f i && g i
-- | Parse a pattern from a string
--
-parsePattern :: String -> Pattern
-parsePattern = Pattern . parse' -- undefined -- Pattern . map toPattern . unIdentifier . parseIdentifier
+parseGlob :: String -> Pattern
+parseGlob = Glob . parse'
where
parse' str =
let (chunk, rest) = break (`elem` "\\*") str
@@ -72,20 +89,34 @@ parsePattern = Pattern . parse' -- undefined -- Pattern . map toPattern . unIden
('*' : xs) -> Literal chunk : Capture : parse' xs
xs -> Literal chunk : Literal xs : []
--- | Match an identifier against a pattern, generating a list of captures
+-- | Create a 'Pattern' from an arbitrary predicate
+--
+-- Example:
+--
+-- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i))
+--
+predicate :: (Identifier -> Bool) -> Pattern
+predicate = Predicate
+
+-- | Create a 'Pattern' from a regex
+--
+-- Example:
+--
+-- > regex "^foo/[^x]*$
--
-match :: Pattern -> Identifier -> Maybe [Identifier]
-match p (Identifier i) = fmap (map Identifier) $ match' (unPattern p) i
+regex :: String -> Pattern
+regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
-- | Check if an identifier matches a pattern
--
-doesMatch :: Pattern -> Identifier -> Bool
-doesMatch p = isJust . match p
+matches :: Pattern -> Identifier -> Bool
+matches (Glob p) = isJust . capture (Glob p)
+matches (Predicate p) = (p $)
-- | Given a list of identifiers, retain only those who match the given pattern
--
-matches :: Pattern -> [Identifier] -> [Identifier]
-matches p = filter (doesMatch p)
+filterMatches :: Pattern -> [Identifier] -> [Identifier]
+filterMatches = filter . matches
-- | Split a list at every possible point, generate a list of (init, tail)
-- cases. The result is sorted with inits decreasing in length.
@@ -93,30 +124,35 @@ matches p = filter (doesMatch p)
splits :: [a] -> [([a], [a])]
splits = inits &&& tails >>> uncurry zip >>> reverse
--- | Internal verion of 'match'
+-- | Match a glob against a pattern, generating a list of captures
--
-match' :: [PatternComponent] -> String -> Maybe [String]
-match' [] [] = Just [] -- An empty match
-match' [] _ = Nothing -- No match
--- match' _ [] = Nothing -- No match
-match' (Literal l : ms) str
+capture :: Pattern -> Identifier -> Maybe [Identifier]
+capture (Glob p) (Identifier i) = fmap (map Identifier) $ capture' p i
+capture (Predicate _) _ = Nothing
+
+-- | Internal verion of 'capture'
+--
+capture' :: [GlobComponent] -> String -> Maybe [String]
+capture' [] [] = Just [] -- An empty match
+capture' [] _ = Nothing -- No match
+capture' (Literal l : ms) str
-- Match the literal against the string
- | l `isPrefixOf` str = match' ms $ drop (length l) str
+ | l `isPrefixOf` str = capture' ms $ drop (length l) str
| otherwise = Nothing
-match' (Capture : ms) str =
+capture' (Capture : ms) str =
-- Match until the next /
let (chunk, rest) = break (== '/') str
- in msum $ [ fmap (i :) (match' ms (t ++ rest)) | (i, t) <- splits chunk ]
-match' (CaptureMany : ms) str =
+ in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]
+capture' (CaptureMany : ms) str =
-- Match everything
- msum $ [ fmap (i :) (match' ms t) | (i, t) <- splits str ]
+ msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
-- | Create an identifier from a pattern by filling in the captures with a given
-- string
--
-- Example:
--
--- > fromCapture (parsePattern "tags/*") (parseIdentifier "foo")
+-- > fromCapture (parseGlob "tags/*") (parseIdentifier "foo")
--
-- Result:
--
@@ -128,7 +164,7 @@ fromCapture pattern = fromCaptures pattern . repeat
-- | Simplified version of 'fromCapture' which takes a 'String' instead of an
-- 'Identifier'
--
--- > fromCaptureString (parsePattern "tags/*") "foo"
+-- > fromCaptureString (parseGlob "tags/*") "foo"
--
-- Result:
--
@@ -141,11 +177,19 @@ fromCaptureString pattern = fromCapture pattern . parseIdentifier
-- given list of strings
--
fromCaptures :: Pattern -> [Identifier] -> Identifier
-fromCaptures (Pattern []) _ = mempty
-fromCaptures (Pattern (m : ms)) [] = case m of
- Literal l -> Identifier l `mappend` fromCaptures (Pattern ms) []
- _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures: "
+fromCaptures (Glob p) = fromCaptures' p
+fromCaptures (Predicate _) = error $
+ "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures called on a " ++
+ "predicate instead of a glob"
+
+-- | Internally used version of 'fromCaptures'
+--
+fromCaptures' :: [GlobComponent] -> [Identifier] -> Identifier
+fromCaptures' [] _ = mempty
+fromCaptures' (m : ms) [] = case m of
+ Literal l -> Identifier l `mappend` fromCaptures' ms []
+ _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "
++ "identifier list exhausted"
-fromCaptures (Pattern (m : ms)) ids@(i : is) = case m of
- Literal l -> Identifier l `mappend` fromCaptures (Pattern ms) ids
- _ -> i `mappend` fromCaptures (Pattern ms) is
+fromCaptures' (m : ms) ids@(i : is) = case m of
+ Literal l -> Identifier l `mappend` fromCaptures' ms ids
+ _ -> i `mappend` fromCaptures' ms is
diff --git a/src/Hakyll/Core/Resource.hs b/src/Hakyll/Core/Resource.hs
new file mode 100644
index 0000000..d60fda9
--- /dev/null
+++ b/src/Hakyll/Core/Resource.hs
@@ -0,0 +1,14 @@
+-- | Module exporting the simple 'Resource' type
+--
+module Hakyll.Core.Resource
+ ( Resource (..)
+ ) where
+
+import Hakyll.Core.Identifier
+
+-- | A resource
+--
+-- Invariant: the resource specified by the given identifier must exist
+--
+newtype Resource = Resource {unResource :: Identifier}
+ deriving (Eq, Show, Ord)
diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/Resource/Provider.hs
index dcd4af0..90e93f8 100644
--- a/src/Hakyll/Core/ResourceProvider.hs
+++ b/src/Hakyll/Core/Resource/Provider.hs
@@ -10,16 +10,18 @@
-- Therefore, it is not recommended to read files directly -- you should use the
-- provided 'Resource' methods.
--
-module Hakyll.Core.ResourceProvider
- ( Resource (..)
- , ResourceProvider (..)
+module Hakyll.Core.Resource.Provider
+ ( ResourceProvider (..)
, resourceExists
, resourceDigest
, resourceModified
) where
+import Control.Concurrent (MVar, readMVar, modifyMVar_)
import Control.Monad ((<=<))
import Data.Word (Word8)
+import Data.Map (Map)
+import qualified Data.Map as M
import qualified Data.ByteString.Lazy as LB
import OpenSSL.Digest.ByteString.Lazy (digest)
@@ -27,13 +29,7 @@ import OpenSSL.Digest (MessageDigest (MD5))
import Hakyll.Core.Identifier
import Hakyll.Core.Store
-
--- | A resource
---
--- Invariant: the resource specified by the given identifier must exist
---
-newtype Resource = Resource {unResource :: Identifier}
- deriving (Eq, Show, Ord)
+import Hakyll.Core.Resource
-- | A value responsible for retrieving and listing resources
--
@@ -44,6 +40,8 @@ data ResourceProvider = ResourceProvider
resourceString :: Resource -> IO String
, -- | Retrieve a certain resource as lazy bytestring
resourceLazyByteString :: Resource -> IO LB.ByteString
+ , -- | Cache keeping track of modified items
+ resourceModifiedCache :: MVar (Map Resource Bool)
}
-- | Check if a given identifier has a resource
@@ -60,6 +58,24 @@ resourceDigest provider = digest MD5 <=< resourceLazyByteString provider
--
resourceModified :: ResourceProvider -> Resource -> Store -> IO Bool
resourceModified provider resource store = do
+ cache <- readMVar mvar
+ case M.lookup resource cache of
+ -- Already in the cache
+ Just m -> return m
+ -- Not yet in the cache, check digests (if it exists)
+ Nothing -> do
+ m <- if resourceExists provider (unResource resource)
+ then digestModified provider resource store
+ else return False
+ modifyMVar_ mvar (return . M.insert resource m)
+ return m
+ where
+ mvar = resourceModifiedCache provider
+
+-- | Check if a resource digest was modified
+--
+digestModified :: ResourceProvider -> Resource -> Store -> IO Bool
+digestModified provider resource store = do
-- Get the latest seen digest from the store
lastDigest <- storeGet store itemName $ unResource resource
-- Calculate the digest for the resource
@@ -72,4 +88,4 @@ resourceModified provider resource store = do
else do storeSet store itemName (unResource resource) newDigest
return True
where
- itemName = "Hakyll.Core.ResourceProvider.resourceModified"
+ itemName = "Hakyll.Core.ResourceProvider.digestModified"
diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/Resource/Provider/File.hs
index 0d89b21..953d61c 100644
--- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs
+++ b/src/Hakyll/Core/Resource/Provider/File.hs
@@ -1,14 +1,17 @@
-- | A concrete 'ResourceProvider' that gets it's resources from the filesystem
--
-module Hakyll.Core.ResourceProvider.FileResourceProvider
+module Hakyll.Core.Resource.Provider.File
( fileResourceProvider
) where
import Control.Applicative ((<$>))
+import Control.Concurrent (newMVar)
+import qualified Data.Map as M
import qualified Data.ByteString.Lazy as LB
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
+import Hakyll.Core.Resource.Provider
import Hakyll.Core.Identifier
import Hakyll.Core.Util.File
import Hakyll.Core.Configuration
@@ -21,9 +24,13 @@ fileResourceProvider configuration = do
list <- map parseIdentifier . filter (not . ignoreFile configuration) <$>
getRecursiveContents False "."
+ -- MVar for the cache
+ mvar <- newMVar M.empty
+
-- Construct a resource provider
return ResourceProvider
{ resourceList = map Resource list
, resourceString = readFile . toFilePath . unResource
, resourceLazyByteString = LB.readFile . toFilePath . unResource
+ , resourceModifiedCache = mvar
}
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index fcab28d..abbd0a7 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -30,7 +30,7 @@ module Hakyll.Core.Routes
, runRoutes
, idRoute
, setExtension
- , ifMatch
+ , matchRoute
, customRoute
, gsubRoute
, composeRoutes
@@ -85,15 +85,15 @@ setExtension :: String -> Routes
setExtension extension = Routes $ fmap (`replaceExtension` extension)
. unRoutes idRoute
--- | Modify a route: apply the route if the identifier matches the given
--- pattern, fail otherwise.
+-- | Apply the route if the identifier matches the given pattern, fail
+-- otherwise
--
-ifMatch :: Pattern -> Routes -> Routes
-ifMatch pattern (Routes route) = Routes $ \id' ->
- if doesMatch pattern id' then route id'
- else Nothing
+matchRoute :: Pattern -> Routes -> Routes
+matchRoute pattern (Routes route) = Routes $ \id' ->
+ if matches pattern id' then route id' else Nothing
--- | Create a custom route. This should almost always be used with 'ifMatch'.
+-- | Create a custom route. This should almost always be used with
+-- 'matchRoute'
--
customRoute :: (Identifier -> FilePath) -> Routes
customRoute f = Routes $ Just . f
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index eba3fb9..892cf7c 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -7,13 +7,18 @@
-- A typical usage example would be:
--
-- > main = hakyll $ do
--- > route "posts/*" (setExtension "html")
--- > compile "posts/*" someCompiler
+-- > match "posts/*" $ do
+-- > route (setExtension "html")
+-- > compile someCompiler
+-- > match "css/*" $ do
+-- > route idRoute
+-- > compile compressCssCompiler
--
{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
module Hakyll.Core.Rules
( RulesM
, Rules
+ , match
, compile
, create
, route
@@ -23,16 +28,17 @@ module Hakyll.Core.Rules
import Control.Applicative ((<$>))
import Control.Monad.Writer (tell)
-import Control.Monad.Reader (ask)
+import Control.Monad.Reader (ask, local)
import Control.Arrow (second, (>>>), arr, (>>^))
import Control.Monad.State (get, put)
-import Data.Monoid (mempty)
+import Data.Monoid (mempty, mappend)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Data.Binary (Binary)
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
+import Hakyll.Core.Resource.Provider
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.Compiler.Internal
@@ -63,21 +69,32 @@ tellResources :: [Resource]
-> Rules
tellResources resources = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources
+-- | Only compile/route items satisfying the given predicate
+--
+match :: Pattern -> Rules -> Rules
+match pattern = RulesM . local addPredicate . unRulesM
+ where
+ addPredicate env = env
+ { rulesPattern = rulesPattern env `mappend` pattern
+ }
+
-- | Add a compilation rule to the rules.
--
--- This instructs all resources matching the given pattern to be compiled using
--- the given compiler. When no resources match the given pattern, nothing will
--- happen. In this case, you might want to have a look at 'create'.
+-- This instructs all resources to be compiled using the given compiler. When
+-- 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)
- => Pattern -> Compiler Resource a -> Rules
-compile pattern compiler = RulesM $ do
- identifiers <- matches pattern . map unResource . resourceList <$> ask
+ => Compiler Resource a -> Rules
+compile compiler = RulesM $ do
+ pattern <- rulesPattern <$> ask
+ provider <- rulesResourceProvider <$> ask
+ let ids = filterMatches pattern $ map unResource $ resourceList provider
unRulesM $ do
- tellCompilers $ flip map identifiers $ \identifier ->
+ tellCompilers $ flip map ids $ \identifier ->
(identifier, constA (Resource identifier) >>> compiler)
- tellResources $ map Resource identifiers
-
+ tellResources $ map Resource ids
+
-- | Add a compilation rule
--
-- This sets a compiler for the given identifier. No resource is needed, since
@@ -91,10 +108,12 @@ create identifier compiler = tellCompilers [(identifier, compiler)]
-- | Add a route.
--
--- This adds a route for all items matching the given pattern.
+-- This adds a route for all items matching the current pattern.
--
-route :: Pattern -> Routes -> Rules
-route pattern route' = tellRoute $ ifMatch pattern route'
+route :: Routes -> Rules
+route route' = RulesM $ do
+ pattern <- rulesPattern <$> ask
+ unRulesM $ tellRoute $ matchRoute pattern route'
-- | Apart from regular compilers, one is also able to specify metacompilers.
-- Metacompilers are a special class of compilers: they are compilers which
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 2895257..0e117ec 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -5,6 +5,7 @@ module Hakyll.Core.Rules.Internal
( CompileRule (..)
, RuleSet (..)
, RuleState (..)
+ , RuleEnvironment (..)
, RulesM (..)
, Rules
, runRules
@@ -17,8 +18,10 @@ import Control.Monad.State (State, evalState)
import Data.Monoid (Monoid, mempty, mappend)
import Data.Set (Set)
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
+import Hakyll.Core.Resource.Provider
import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Routes
import Hakyll.Core.CompiledItem
@@ -55,10 +58,17 @@ data RuleState = RuleState
{ rulesMetaCompilerIndex :: Int
} deriving (Show)
+-- | Rule environment
+--
+data RuleEnvironment = RuleEnvironment
+ { rulesResourceProvider :: ResourceProvider
+ , rulesPattern :: Pattern
+ }
+
-- | The monad used to compose rules
--
newtype RulesM a = RulesM
- { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) a
+ { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a
} deriving (Monad, Functor, Applicative)
-- | Simplification of the RulesM type; usually, it will not return any
@@ -70,6 +80,9 @@ type Rules = RulesM ()
--
runRules :: Rules -> ResourceProvider -> RuleSet
runRules rules provider =
- evalState (execWriterT $ runReaderT (unRulesM rules) provider) state
+ evalState (execWriterT $ runReaderT (unRulesM rules) env) state
where
state = RuleState {rulesMetaCompilerIndex = 0}
+ env = RuleEnvironment { rulesResourceProvider = provider
+ , rulesPattern = mempty
+ }
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index 58fd49a..c2cc21b 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -25,8 +25,9 @@ import Hakyll.Core.Identifier
import Hakyll.Core.Util.File
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.ResourceProvider
-import Hakyll.Core.ResourceProvider.FileResourceProvider
+import Hakyll.Core.Resource
+import Hakyll.Core.Resource.Provider
+import Hakyll.Core.Resource.Provider.File
import Hakyll.Core.Rules.Internal
import Hakyll.Core.DirectedGraph
import Hakyll.Core.DirectedGraph.Dot
@@ -108,9 +109,7 @@ modified :: ResourceProvider -- ^ Resource provider
-> [Identifier] -- ^ Identifiers to check
-> IO (Set Identifier) -- ^ Modified resources
modified provider store ids = fmap S.fromList $ flip filterM ids $ \id' ->
- if resourceExists provider id'
- then resourceModified provider (Resource id') store
- else return False
+ resourceModified provider (Resource id') store
-- | Add a number of compilers and continue using these compilers
--
diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs
index 9babc8b..24814ae 100644
--- a/src/Hakyll/Core/Util/File.hs
+++ b/src/Hakyll/Core/Util/File.hs
@@ -47,7 +47,7 @@ getRecursiveContents includeDirs topdir = do
return $ if includeDirs then topdir : concat paths
else concat paths
where
- isProper = not . (== ".") . take 1
+ isProper = (`notElem` [".", ".."])
-- | Check if a timestamp is obsolete compared to the timestamps of a number of
-- files. When they are no files, it is never obsolete.
diff --git a/src/Hakyll/Core/Writable/CopyFile.hs b/src/Hakyll/Core/Writable/CopyFile.hs
index 1cd5fd2..ab9c698 100644
--- a/src/Hakyll/Core/Writable/CopyFile.hs
+++ b/src/Hakyll/Core/Writable/CopyFile.hs
@@ -12,7 +12,7 @@ import System.Directory (copyFile)
import Data.Typeable (Typeable)
import Data.Binary (Binary)
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
import Hakyll.Core.Writable
import Hakyll.Core.Compiler
import Hakyll.Core.Identifier
diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs
index 2df08fd..090fe10 100644
--- a/src/Hakyll/Web/CompressCss.hs
+++ b/src/Hakyll/Web/CompressCss.hs
@@ -11,7 +11,7 @@ import Data.List (isPrefixOf)
import Control.Arrow ((>>^))
import Hakyll.Core.Compiler
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
import Hakyll.Core.Util.String
-- | Compiler form of 'compressCss'
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index c41647b..5146bdc 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -67,7 +67,7 @@ import Data.Ord (comparing)
import Hakyll.Core.Identifier
import Hakyll.Core.Compiler
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
import Hakyll.Web.Page.Internal
import Hakyll.Web.Page.Read
import Hakyll.Web.Page.Metadata
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 328ae8b..32076a0 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -32,6 +32,7 @@ module Hakyll.Web.Tags
, readTags
, readCategory
, renderTagCloud
+ , renderTagList
, renderTagsField
, renderCategoryField
) where
@@ -39,9 +40,8 @@ module Hakyll.Web.Tags
import Prelude hiding (id)
import Control.Category (id)
import Control.Applicative ((<$>))
-import Data.Map (Map)
import qualified Data.Map as M
-import Data.List (intersperse)
+import Data.List (intersperse, intercalate)
import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mconcat)
@@ -64,7 +64,7 @@ import Hakyll.Core.Util.String
-- | Data about tags
--
data Tags a = Tags
- { tagsMap :: Map String [Page a]
+ { tagsMap :: [(String, [Page a])]
} deriving (Show, Typeable)
instance Binary a => Binary (Tags a) where
@@ -90,7 +90,8 @@ readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
-> [Page a] -- ^ Pages
-> Tags a -- ^ Resulting tags
readTagsWith f pages = Tags
- { tagsMap = foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
+ { tagsMap = M.toList $
+ foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
}
where
-- Create a tag map for one page
@@ -108,41 +109,64 @@ readTags = readTagsWith getTags
readCategory :: [Page a] -> Tags a
readCategory = readTagsWith getCategory
--- | Render a tag cloud in HTML
+-- | Render tags in HTML
--
-renderTagCloud :: (String -> Identifier) -- ^ Produce a link for a tag
- -> Double -- ^ Smallest font size, in percent
- -> Double -- ^ Biggest font size, in percent
- -> Compiler (Tags a) String -- ^ Tag cloud renderer
-renderTagCloud makeUrl minSize maxSize = proc (Tags tags) -> do
+renderTags :: (String -> Identifier)
+ -- ^ Produce a link
+ -> (String -> String -> Int -> Int -> Int -> String)
+ -- ^ Produce a tag item: tag, url, count, min count, max count
+ -> ([String] -> String)
+ -- ^ Join items
+ -> Compiler (Tags a) String
+ -- ^ Tag cloud renderer
+renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
-- In tags' we create a list: [((tag, route), count)]
tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
- -< M.toList tags
+ -< tags
let -- Absolute frequencies of the pages
freqs = map snd tags'
- -- Find out the relative count of a tag: on a scale from 0 to 1
- relative count = (fromIntegral count - min') / (1 + max' - min')
-
- -- Show the relative size of one 'count' in percent
- size count =
- let size' = floor $ minSize + relative count * (maxSize - minSize)
- in show (size' :: Int) ++ "%"
-
- -- The minimum and maximum count found, as doubles
+ -- The minimum and maximum count found
(min', max')
| null freqs = (0, 1)
- | otherwise = (minimum &&& maximum) $ map fromIntegral freqs
+ | otherwise = (minimum &&& maximum) freqs
-- Create a link for one item
- makeLink ((tag, url), count) =
- H.a ! A.style (toValue $ "font-size: " ++ size count)
- ! A.href (toValue $ toUrl $ fromMaybe "/" url)
- $ toHtml tag
+ makeItem' ((tag, url), count) =
+ makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
-- Render and return the HTML
- returnA -< renderHtml $ mconcat $ intersperse " " $ map makeLink tags'
+ returnA -< concatItems $ map makeItem' tags'
+
+-- | Render a tag cloud in HTML
+--
+renderTagCloud :: (String -> Identifier) -- ^ Produce a link for a tag
+ -> Double -- ^ Smallest font size, in percent
+ -> Double -- ^ Biggest font size, in percent
+ -> Compiler (Tags a) String -- ^ Tag cloud renderer
+renderTagCloud makeUrl minSize maxSize =
+ renderTags makeUrl makeLink (intercalate " ")
+ where
+ makeLink tag url count min' max' = renderHtml $
+ H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
+ ! A.href (toValue url)
+ $ toHtml tag
+
+ -- Show the relative size of one 'count' in percent
+ size count min' max' =
+ let diff = 1 + fromIntegral max' - fromIntegral min'
+ relative = (fromIntegral count - fromIntegral min') / diff
+ size' = floor $ minSize + relative * (maxSize - minSize)
+ in show (size' :: Int) ++ "%"
+
+-- | Render a simple tag list in HTML, with the tag count next to the item
+--
+renderTagList :: (String -> Identifier) -> Compiler (Tags a) (String)
+renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
+ where
+ makeLink tag url count _ _ = renderHtml $
+ H.a ! A.href (toValue url) $ toHtml (tag ++ "(" ++ show count ++ ")")
-- | Render tags with links
--
@@ -151,14 +175,14 @@ renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
-> (String -> Identifier) -- ^ Create a link for a tag
-> Compiler (Page a) (Page a) -- ^ Resulting compiler
renderTagsFieldWith tags destination makeUrl =
- id &&& arr tags >>> setFieldA destination renderTags
+ id &&& arr tags >>> setFieldA destination renderTags'
where
-- Compiler creating a comma-separated HTML string for a list of tags
- renderTags :: Compiler [String] String
- renderTags = arr (map $ id &&& makeUrl)
- >>> mapCompiler (id *** getRouteFor)
- >>> arr (map $ uncurry renderLink)
- >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
+ renderTags' :: Compiler [String] String
+ renderTags' = arr (map $ id &&& makeUrl)
+ >>> mapCompiler (id *** getRouteFor)
+ >>> arr (map $ uncurry renderLink)
+ >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
-- Render one tag link
renderLink _ Nothing = Nothing
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 9c49278..33e7a9b 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -59,7 +59,7 @@ import Text.Hamlet (HamletSettings, defaultHamletSettings)
import Hakyll.Core.Compiler
import Hakyll.Core.Identifier
-import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Resource
import Hakyll.Web.Template.Internal
import Hakyll.Web.Template.Read
import Hakyll.Web.Page.Internal