diff options
author | Jasper Van der Jeugt <jaspervdj@gmail.com> | 2011-04-06 14:05:29 +0200 |
---|---|---|
committer | Jasper Van der Jeugt <jaspervdj@gmail.com> | 2011-04-06 14:05:29 +0200 |
commit | 80596b1f56b7d6f2d4ff64d566ae845b7c7a01f6 (patch) | |
tree | bf6b02d68833821f7b57f40edc8dd8a60543fa09 /src | |
parent | c3dbb0ca77f65461e60cb801b867fff18afda2be (diff) | |
parent | ce444a426ac037c2b32568d8e6325aa5762bf913 (diff) | |
download | hakyll-80596b1f56b7d6f2d4ff64d566ae845b7c7a01f6.tar.gz |
Merge branch 'master' into dependency-analyzer
Diffstat (limited to 'src')
-rw-r--r-- | src/Hakyll.hs | 6 | ||||
-rw-r--r-- | src/Hakyll/Core/Compiler.hs | 5 | ||||
-rw-r--r-- | src/Hakyll/Core/Compiler/Internal.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Core/Identifier/Pattern.hs | 128 | ||||
-rw-r--r-- | src/Hakyll/Core/Resource.hs | 14 | ||||
-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.hs | 16 | ||||
-rw-r--r-- | src/Hakyll/Core/Rules.hs | 53 | ||||
-rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 19 | ||||
-rw-r--r-- | src/Hakyll/Core/Run.hs | 9 | ||||
-rw-r--r-- | src/Hakyll/Core/Util/File.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Core/Writable/CopyFile.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Web/CompressCss.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Web/Page.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Web/Tags.hs | 88 | ||||
-rw-r--r-- | src/Hakyll/Web/Template.hs | 2 |
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 |