Add identifier/pattern modules

5 files changed, 182 insertions, 12 deletions

diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs
new file mode 100644
index 0000000..609e722
--- /dev/null
+++ b/src/Hakyll/Core/Identifier.hs
@@ -0,0 +1,47 @@
+-- | 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
+-- identifier is a path as well, with the different elements in the path
+-- separated by @/@ characters. Examples of identifiers are:
+--
+-- * @posts/foo.markdown@
+--
+-- * @index@
+--
+-- * @error/404@
+--
+module Hakyll.Core.Identifier
+    ( Identifier (..)
+    , parseIdentifier
+    , toFilePath
+    ) where
+
+import Control.Arrow (second)
+
+import GHC.Exts (IsString, fromString)
+import System.FilePath (joinPath)
+
+-- | An identifier used to uniquely identify a value
+--
+newtype Identifier = Identifier {unIdentifier :: [String]}
+                   deriving (Eq, Ord)
+
+instance Show Identifier where
+    show = toFilePath
+
+instance IsString Identifier where
+    fromString = parseIdentifier
+
+-- | Parse an identifier from a string
+--
+parseIdentifier :: String -> Identifier
+parseIdentifier = Identifier . filter (not . null) . split'
+  where
+    split' [] = [[]]
+    split' str = let (pre, post) = second (drop 1) $ break (== '/') str
+                 in pre : split' post
+
+-- | Convert an identifier to a relative 'FilePath'
+--
+toFilePath :: Identifier -> FilePath
+toFilePath = joinPath . unIdentifier
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
new file mode 100644
index 0000000..02b023f
--- /dev/null
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -0,0 +1,91 @@
+-- | Module providing pattern matching and capturing on 'Identifier's.
+--
+-- TODO: Documentation
+--
+module Hakyll.Core.Identifier.Pattern
+    ( Pattern
+    , parsePattern
+    , match
+    , doesMatch
+    , matches
+    ) where
+
+import Data.List (intercalate)
+import Control.Monad (msum)
+import Data.Maybe (isJust)
+
+import GHC.Exts (IsString, fromString)
+
+import Hakyll.Core.Identifier
+
+-- | One base element of a pattern
+--
+data PatternComponent = CaptureOne
+                      | CaptureMany
+                      | Literal String
+                      deriving (Eq)
+
+instance Show PatternComponent where
+    show CaptureOne = "*"
+    show CaptureMany = "**"
+    show (Literal s) = s
+
+-- | Type that allows matching on identifiers
+--
+newtype Pattern = Pattern {unPattern :: [PatternComponent]}
+                deriving (Eq)
+
+instance Show Pattern where
+    show = intercalate "/" . map show . unPattern
+
+instance IsString Pattern where
+    fromString = parsePattern
+
+-- | Parse a pattern from a string
+--
+parsePattern :: String -> Pattern
+parsePattern = Pattern . map toPattern . unIdentifier . parseIdentifier
+  where
+    toPattern x | x == "*"  = CaptureOne
+                | x == "**" = CaptureMany
+                | otherwise = Literal x
+
+-- | Match an identifier against a pattern, generating a list of captures
+--
+match :: Pattern -> Identifier -> Maybe [[String]]
+match (Pattern p) (Identifier i) = match' p i
+
+-- | Check if an identifier matches a pattern
+--
+doesMatch :: Pattern -> Identifier -> Bool
+doesMatch p = isJust . match p
+
+-- | Given a list of identifiers, retain only those who match the given pattern
+--
+matches :: Pattern -> [Identifier] -> [Identifier]
+matches p = filter (doesMatch p)
+
+-- | Split a list at every possible point, generate a list of (init, tail) cases
+--
+splits :: [a] -> [([a], [a])]
+splits ls = reverse $ splits' [] ls
+  where
+    splits' lx ly = (lx, ly) : case ly of
+        []       -> []
+        (y : ys) -> splits' (lx ++ [y]) ys
+
+-- | Internal verion of 'match'
+--
+match' :: [PatternComponent] -> [String] -> Maybe [[String]]
+match' [] [] = Just []  -- An empty match
+match' [] _ = Nothing   -- No match
+match' _ [] = Nothing   -- No match
+match' (m : ms) (s : ss) = case m of
+    -- Take one string and one literal, fail on mismatch
+    Literal l -> if s == l then match' ms ss else Nothing
+    -- Take one string and one capture
+    CaptureOne -> fmap ([s] :) $ match' ms ss
+    -- Take one string, and one or many captures
+    CaptureMany ->
+        let take' (i, t) = fmap (i :) $ match' ms t
+        in msum $ map take' $ splits (s : ss)
diff --git a/tests/Hakyll/Core/DirectedGraph/Tests.hs b/tests/Hakyll/Core/DirectedGraph/Tests.hs
index 4ce5944..1a9b406 100644
--- a/tests/Hakyll/Core/DirectedGraph/Tests.hs
+++ b/tests/Hakyll/Core/DirectedGraph/Tests.hs
@@ -15,9 +15,9 @@ import Hakyll.Core.DirectedGraph.ObsoleteFilter
 
 tests :: [Test]
 tests =
-    [ testCase "solveDependencies01" solveDependencies01
-    , testCase "filterObsolete01"    filterObsolete01
-    , testCase "filterObsolete02"    filterObsolete02
+    [ testCase "solveDependencies [1]" solveDependencies1
+    , testCase "filterObsolete [1]"    filterObsolete1
+    , testCase "filterObsolete [2]"    filterObsolete2
     ]
 
 node :: Ord a => a -> [a] -> (a, Set a)
@@ -32,17 +32,17 @@ testGraph01 = fromList
     , node 3 []
     ]
 
-solveDependencies01 :: Assertion
-solveDependencies01 =  result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8]
-                    @? "solveDependencies01"
+solveDependencies1 :: Assertion
+solveDependencies1 =  result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8]
+                    @? "solveDependencies1"
   where
     result = solveDependencies testGraph01
 
-filterObsolete01 :: Assertion
-filterObsolete01 =  nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8]
-                 @? "filterObsolete01"
+filterObsolete1 :: Assertion
+filterObsolete1 =  nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8]
+                 @? "filterObsolete1"
 
-filterObsolete02 :: Assertion
-filterObsolete02 =
+filterObsolete2 :: Assertion
+filterObsolete2 =
     nodes (filterObsolete [4] testGraph01) == S.fromList [4, 2, 6, 8]
-        @? "filterObsolete02"
+        @? "filterObsolete2"
diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs
new file mode 100644
index 0000000..910bca3
--- /dev/null
+++ b/tests/Hakyll/Core/Identifier/Tests.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Core.Identifier.Tests
+    ( tests
+    ) where
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+
+import Hakyll.Core.Identifier.Pattern
+
+tests :: [Test]
+tests = zipWith testCase names matchCases 
+  where
+    names = map (\n -> "match [" ++ show n ++ "]") [1 :: Int ..]
+
+-- | Collection of simple cases
+--
+matchCases :: [Assertion]
+matchCases =
+    [ Just [["bar"]]                 @=? match "foo/**" "foo/bar"
+    , Just [["foo", "bar"]]          @=? match "**" "foo/bar"
+    , Nothing                        @=? match "*" "foo/bar"
+    , Just []                        @=? match "foo" "foo"
+    , Just [["foo"]]                 @=? match "*/bar" "foo/bar"
+    , Just [["foo", "bar"]]          @=? match "**/qux" "foo/bar/qux"
+    , Just [["foo", "bar"], ["qux"]] @=? match "**/*" "foo/bar/qux"
+    , Just [["foo"], ["bar", "qux"]] @=? match "*/**" "foo/bar/qux"
+    ]
diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs
index 26b26f0..f75001f 100644
--- a/tests/TestSuite.hs
+++ b/tests/TestSuite.hs
@@ -3,9 +3,12 @@ module TestSuite where
 import Test.Framework (defaultMain, testGroup)
 
 import qualified Hakyll.Core.DirectedGraph.Tests
+import qualified Hakyll.Core.Identifier.Tests
 
 main :: IO ()
 main = defaultMain
     [ testGroup "Hakyll.Core.DirectedGraph.Tests"
         Hakyll.Core.DirectedGraph.Tests.tests
+    , testGroup "Hakyll.Core.Identifier.Tests"
+        Hakyll.Core.Identifier.Tests.tests
     ]