diff options
author | Jasper Van der Jeugt <jaspervdj@gmail.com> | 2011-04-05 22:02:40 +0200 |
---|---|---|
committer | Jasper Van der Jeugt <jaspervdj@gmail.com> | 2011-04-05 22:02:40 +0200 |
commit | 433f36e6f3efdf95276fe0a5f486db3be2824445 (patch) | |
tree | 4eba909cfe316224f49e5bc87d340cc98d1f670c /src/Hakyll/Core | |
parent | 041ec5c3096684d045637ddd72741192b9050e36 (diff) | |
parent | 19dc9f5f9fb8bda417e5b5dcc47b9cf83c541366 (diff) | |
download | hakyll-433f36e6f3efdf95276fe0a5f486db3be2824445.tar.gz |
Merge branch 'nested-rules'
Diffstat (limited to 'src/Hakyll/Core')
-rw-r--r-- | src/Hakyll/Core/Compiler.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Core/Identifier/Pattern.hs | 115 | ||||
-rw-r--r-- | src/Hakyll/Core/Routes.hs | 16 | ||||
-rw-r--r-- | src/Hakyll/Core/Rules.hs | 50 | ||||
-rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 16 |
5 files changed, 131 insertions, 68 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index bd78adf..7fe1754 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -245,7 +245,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/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index a1e36df..28e23ad 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,16 @@ -- -- * @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 , matches + , filterMatches + , capture , fromCapture , fromCaptureString , fromCaptures @@ -38,7 +47,7 @@ import Data.List (isPrefixOf, inits, tails) import Control.Arrow ((&&&), (>>>)) import Control.Monad (msum) import Data.Maybe (isJust) -import Data.Monoid (mempty, mappend) +import Data.Monoid (Monoid, mempty, mappend) import GHC.Exts (IsString, fromString) @@ -46,23 +55,29 @@ 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 +87,25 @@ 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: -- -match :: Pattern -> Identifier -> Maybe [Identifier] -match p (Identifier i) = fmap (map Identifier) $ match' (unPattern p) i +-- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i)) +-- +predicate :: (Identifier -> Bool) -> Pattern +predicate = Predicate -- | 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 +113,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 +-- +capture :: Pattern -> Identifier -> Maybe [Identifier] +capture (Glob p) (Identifier i) = fmap (map Identifier) $ capture' p i +capture (Predicate _) _ = Nothing + +-- | Internal verion of 'capture' -- -match' :: [PatternComponent] -> String -> Maybe [String] -match' [] [] = Just [] -- An empty match -match' [] _ = Nothing -- No match --- match' _ [] = Nothing -- No match -match' (Literal l : ms) str +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 +153,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 +166,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/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..19df85e 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,10 +28,10 @@ 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) @@ -63,21 +68,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 +107,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..592194d 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 @@ -19,6 +20,7 @@ import Data.Set (Set) import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Compiler.Internal import Hakyll.Core.Routes import Hakyll.Core.CompiledItem @@ -55,10 +57,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 +79,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 + } |