diff options
| -rw-r--r-- | src/Hakyll/Core/Identifier.hs | 87 | ||||
| -rw-r--r-- | src/Hakyll/Core/Identifier/Pattern.hs | 203 |
2 files changed, 163 insertions, 127 deletions
diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs index ade0405..4ea9c8e 100644 --- a/src/Hakyll/Core/Identifier.hs +++ b/src/Hakyll/Core/Identifier.hs @@ -1,3 +1,4 @@ +-------------------------------------------------------------------------------- -- | An identifier is a type used to uniquely identify a resource, target... -- -- One can think of an identifier as something similar to a file path. An @@ -28,82 +29,60 @@ -- function. -- -- If the @a@ type is not known, Hakyll traditionally uses @Identifier ()@. --- -{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Identifier - ( Identifier (..) - , castIdentifier - , parseIdentifier + ( Identifier , fromFilePath , toFilePath - , setGroup + , castIdentifier ) where -import Control.Applicative ((<$>), (<*>)) -import Control.DeepSeq (NFData (..)) -import Control.Monad (mplus) -import Data.Monoid (Monoid, mempty, mappend) -import Data.List (intercalate) -import System.FilePath (dropTrailingPathSeparator, splitPath) -import Data.Binary (Binary, get, put) -import GHC.Exts (IsString, fromString) -import Data.Typeable (Typeable) +-------------------------------------------------------------------------------- +import Control.DeepSeq (NFData) +import Data.List (intercalate) +import System.FilePath (dropTrailingPathSeparator, splitPath) --- | An identifier used to uniquely identify a value --- -data Identifier a = Identifier - { identifierGroup :: Maybe String - , identifierPath :: String - } deriving (Eq, Ord, Typeable) -instance Monoid (Identifier a) where - mempty = Identifier Nothing "" - Identifier g1 p1 `mappend` Identifier g2 p2 = - Identifier (g1 `mplus` g2) (p1 `mappend` p2) +-------------------------------------------------------------------------------- +import Data.Binary (Binary) +import Data.Typeable (Typeable) +import GHC.Exts (IsString, fromString) -instance Binary (Identifier a) where - put (Identifier g p) = put g >> put p - get = Identifier <$> get <*> get -instance Show (Identifier a) where - show i@(Identifier Nothing _) = toFilePath i - show i@(Identifier (Just g) _) = toFilePath i ++ " (" ++ g ++ ")" +-------------------------------------------------------------------------------- +-- | An identifier used to uniquely identify a value +newtype Identifier a = Identifier {unIdentifier :: String} + deriving (Binary, Eq, NFData, Ord, Typeable) -instance IsString (Identifier a) where - fromString = parseIdentifier -instance NFData (Identifier a) where - rnf (Identifier g p) = rnf g `seq` rnf p `seq` () +-------------------------------------------------------------------------------- +instance Show (Identifier a) where + show = toFilePath --- | Discard the phantom type parameter of an identifier --- -castIdentifier :: Identifier a -> Identifier b -castIdentifier (Identifier g p) = Identifier g p -{-# INLINE castIdentifier #-} + +-------------------------------------------------------------------------------- +instance IsString (Identifier a) where + fromString = fromFilePath -------------------------------------------------------------------------------- -- | Parse an identifier from a string -parseIdentifier :: String -> Identifier a -parseIdentifier = Identifier Nothing . - intercalate "/" . filter (not . null) . split' +fromFilePath :: String -> Identifier a +fromFilePath = Identifier . intercalate "/" . filter (not . null) . split' where split' = map dropTrailingPathSeparator . splitPath -------------------------------------------------------------------------------- --- | Create an identifier from a filepath -fromFilePath :: FilePath -> Identifier a -fromFilePath = parseIdentifier - - --------------------------------------------------------------------------------- -- | Convert an identifier to a relative 'FilePath' toFilePath :: Identifier a -> FilePath -toFilePath = identifierPath +toFilePath = unIdentifier --- | Set the identifier group for some identifier --- -setGroup :: Maybe String -> Identifier a -> Identifier a -setGroup g (Identifier _ p) = Identifier g p + +-------------------------------------------------------------------------------- +-- | Discard the phantom type parameter of an identifier +castIdentifier :: Identifier a -> Identifier b +castIdentifier (Identifier x) = Identifier x +{-# INLINE castIdentifier #-} diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index 5f97215..24aecbd 100644 --- a/src/Hakyll/Core/Identifier/Pattern.hs +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -1,3 +1,4 @@ +-------------------------------------------------------------------------------- -- | Module providing pattern matching and capturing on 'Identifier's. -- 'Pattern's come in two kinds: -- @@ -34,71 +35,116 @@ -- Like an 'Identifier', a 'Pattern' also has a type parameter. This is simply -- an extra layer of safety, and can be discarded using the 'castPattern' -- function. --- module Hakyll.Core.Identifier.Pattern ( -- * The pattern type Pattern - , castPattern -- * Creating patterns - , parseGlob - , predicate - , list - , regex - , inGroup + , fromGlob + , fromList + , fromRegex + + -- * Manipulating patterns , complement + , castPattern -- * Applying patterns , matches , filterMatches + + -- * Capturing strings , capture , fromCapture , fromCaptures ) where -import Data.List (isPrefixOf, inits, tails) -import Control.Arrow ((&&&), (>>>)) -import Control.Monad (msum) -import Data.Maybe (isJust, fromMaybe) -import Data.Monoid (Monoid, mempty, mappend) -import GHC.Exts (IsString, fromString) -import Text.Regex.TDFA ((=~~)) +-------------------------------------------------------------------------------- +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Arrow ((&&&), (>>>)) +import Control.Monad (msum) +import Data.Binary (Binary (..), getWord8, putWord8) +import Data.List (inits, isPrefixOf, tails) +import Data.Maybe (isJust) +import Data.Monoid (Monoid, mappend, mempty) -import Hakyll.Core.Identifier --- | One base element of a pattern --- -data GlobComponent = Capture - | CaptureMany - | Literal String - deriving (Eq, Show) +-------------------------------------------------------------------------------- +import GHC.Exts (IsString, fromString) +import Text.Regex.TDFA ((=~)) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier + + +-------------------------------------------------------------------------------- +-- | Elements of a glob pattern +data GlobComponent + = Capture + | CaptureMany + | Literal String + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +instance Binary GlobComponent where + put Capture = putWord8 0 + put CaptureMany = putWord8 1 + put (Literal s) = putWord8 2 >> put s + + get = getWord8 >>= \t -> case t of + 0 -> pure Capture + 1 -> pure CaptureMany + 2 -> Literal <$> get + _ -> error "Data.Binary.get: Invalid GlobComponent" + +-------------------------------------------------------------------------------- -- | Type that allows matching on identifiers --- -data Pattern a = Glob [GlobComponent] - | Predicate (Identifier a -> Bool) - | List [Identifier a] +data Pattern a + = Everything + | Complement (Pattern a) + | And (Pattern a) (Pattern a) + | Glob [GlobComponent] + | List [Identifier a] -- TODO Maybe use a set here + | Regex String + deriving (Show) + + +-------------------------------------------------------------------------------- +instance Binary (Pattern a) where + put Everything = putWord8 0 + put (Complement p) = putWord8 1 >> put p + put (And x y) = putWord8 2 >> put x >> put y + put (Glob g) = putWord8 3 >> put g + put (List is) = putWord8 4 >> put is + put (Regex r) = putWord8 5 >> put r + + get = getWord8 >>= \t -> case t of + 0 -> pure Everything + 1 -> Complement <$> get + 2 -> And <$> get <*> get + 3 -> Glob <$> get + 4 -> List <$> get + _ -> Regex <$> get + +-------------------------------------------------------------------------------- instance IsString (Pattern a) where - fromString = parseGlob + fromString = fromGlob + +-------------------------------------------------------------------------------- instance Monoid (Pattern a) where - mempty = Predicate (const True) - p1 `mappend` p2 = Predicate $ \i -> matches p1 i && matches p2 i + mempty = Everything + mappend = And --- | Discard the phantom type parameter --- -castPattern :: Pattern a -> Pattern b -castPattern (Glob g) = Glob g -castPattern (Predicate p) = Predicate $ p . castIdentifier -castPattern (List l) = List $ map castIdentifier l -{-# INLINE castPattern #-} +-------------------------------------------------------------------------------- -- | Parse a pattern from a string --- -parseGlob :: String -> Pattern a -parseGlob = Glob . parse' +fromGlob :: String -> Pattern a +fromGlob = Glob . parse' where parse' str = let (chunk, rest) = break (`elem` "\\*") str @@ -108,35 +154,24 @@ parseGlob = Glob . parse' ('*' : xs) -> Literal chunk : Capture : parse' xs xs -> Literal chunk : Literal xs : [] --- | Create a 'Pattern' from an arbitrary predicate --- --- Example: --- --- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i)) --- -predicate :: (Identifier a -> Bool) -> Pattern a -predicate = Predicate +-------------------------------------------------------------------------------- -- | Create a 'Pattern' from a list of 'Identifier's it should match --- -list :: [Identifier a] -> Pattern a -list = List +fromList :: [Identifier a] -> Pattern a +fromList = List + +-------------------------------------------------------------------------------- -- | Create a 'Pattern' from a regex -- -- Example: -- -- > regex "^foo/[^x]*$ --- -regex :: String -> Pattern a -regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath +fromRegex :: String -> Pattern a +fromRegex = Regex --- | Create a 'Pattern' which matches if the identifier is in a certain group --- (or in no group) --- -inGroup :: Maybe String -> Pattern a -inGroup group = predicate $ (== group) . identifierGroup +-------------------------------------------------------------------------------- -- | Inverts a pattern, e.g. -- -- > complement "foo/bar.html" @@ -144,34 +179,53 @@ inGroup group = predicate $ (== group) . identifierGroup -- will match /anything/ except @\"foo\/bar.html\"@ -- complement :: Pattern a -> Pattern a -complement p = predicate (not . matches p) +complement = Complement + +-------------------------------------------------------------------------------- +-- | Discard the phantom type parameter +castPattern :: Pattern a -> Pattern b +castPattern Everything = Everything +castPattern (Complement x) = Complement (castPattern x) +castPattern (And x y) = And (castPattern x) (castPattern y) +castPattern (Glob g) = Glob g +castPattern (List l) = List $ map castIdentifier l +castPattern (Regex r) = Regex r + + +-------------------------------------------------------------------------------- -- | Check if an identifier matches a pattern --- matches :: Pattern a -> Identifier a -> Bool -matches (Glob p) = isJust . capture (Glob p) -matches (Predicate p) = (p $) -matches (List l) = (`elem` l) +matches Everything _ = True +matches (Complement p) i = not $ matches p i +matches (And x y) i = matches x i && matches y i +matches (Glob p) i = isJust $ capture (Glob p) i +matches (List l) i = i `elem` l +matches (Regex r) i = toFilePath i =~ r + +-------------------------------------------------------------------------------- -- | Given a list of identifiers, retain only those who match the given pattern --- filterMatches :: Pattern a -> [Identifier a] -> [Identifier a] 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. --- splits :: [a] -> [([a], [a])] splits = inits &&& tails >>> uncurry zip >>> reverse + +-------------------------------------------------------------------------------- -- | Match a glob against a pattern, generating a list of captures --- capture :: Pattern a -> Identifier a -> Maybe [String] -capture (Glob p) (Identifier _ i) = capture' p i -capture _ _ = Nothing +capture (Glob p) i = capture' p (toFilePath i) +capture _ _ = Nothing + +-------------------------------------------------------------------------------- -- | Internal verion of 'capture' --- capture' :: [GlobComponent] -> String -> Maybe [String] capture' [] [] = Just [] -- An empty match capture' [] _ = Nothing -- No match @@ -186,7 +240,9 @@ capture' (Capture : ms) str = capture' (CaptureMany : ms) str = -- Match everything 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 -- @@ -197,21 +253,22 @@ capture' (CaptureMany : ms) str = -- Result: -- -- > "tags/foo" --- fromCapture :: Pattern a -> String -> Identifier a fromCapture pattern = fromCaptures pattern . repeat + +-------------------------------------------------------------------------------- -- | Create an identifier from a pattern by filling in the captures with the -- given list of strings --- fromCaptures :: Pattern a -> [String] -> Identifier a -fromCaptures (Glob p) = Identifier Nothing . fromCaptures' p +fromCaptures (Glob p) = fromFilePath . fromCaptures' p fromCaptures _ = error $ "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++ "on simple globs!" + +-------------------------------------------------------------------------------- -- | Internally used version of 'fromCaptures' --- fromCaptures' :: [GlobComponent] -> [String] -> String fromCaptures' [] _ = mempty fromCaptures' (m : ms) [] = case m of |