WIP

author: Jasper Van der Jeugt <m@jaspervdj.be> 2012-11-12 16:10:06 +0100
committer: Jasper Van der Jeugt <m@jaspervdj.be> 2012-11-12 16:10:06 +0100
commit: 760b4344377c81922ce5ab4ba05a41f88f45165d (patch)
tree: a2b7f45c61938879e4badce363f03c5abf85ae66 /src
parent: c7d3c60c54926b54847bfc691e27f24dc644dd65 (diff)
download: hakyll-760b4344377c81922ce5ab4ba05a41f88f45165d.tar.gz
8 files changed, 171 insertions, 211 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 31b25e3..ef9b03c 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -116,7 +116,7 @@ module Hakyll.Core.Compiler
 
 import Prelude hiding ((.), id)
 import Control.Arrow ((>>>), (&&&), arr, first)
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (*>))
 import Control.Exception (SomeException, handle)
 import Control.Monad.Reader (ask)
 import Control.Monad.Trans (liftIO)
@@ -144,7 +144,7 @@ import qualified Hakyll.Core.Store as Store
 -- | Run a compiler, yielding the resulting target and it's dependencies. This
 -- version of 'runCompilerJob' also stores the result
 --
-runCompiler :: Compiler () CompiledItem    -- ^ Compiler to run
+runCompiler :: Compiler CompiledItem       -- ^ Compiler to run
             -> Identifier ()               -- ^ Target identifier
             -> ResourceProvider            -- ^ Resource provider
             -> [Identifier ()]             -- ^ Universe
@@ -174,18 +174,18 @@ runCompiler compiler id' provider universe routes store modified logger = do
 
 -- | Get the identifier of the item that is currently being compiled
 --
-getIdentifier :: Compiler a (Identifier b)
+getIdentifier :: Compiler (Identifier b)
 getIdentifier = fromJob $ const $ CompilerM $
     castIdentifier . compilerIdentifier <$> ask
 
 -- | Get the route we are using for this item
 --
-getRoute :: Compiler a (Maybe FilePath)
+getRoute :: Compiler (Maybe FilePath)
 getRoute = getIdentifier >>> getRouteFor
 
 -- | Get the route for a specified item
 --
-getRouteFor :: Compiler (Identifier a) (Maybe FilePath)
+getRouteFor :: Compiler (Identifier a -> Maybe FilePath)
 getRouteFor = fromJob $ \identifier -> CompilerM $ do
     routes <- compilerRoutes <$> ask
     return $ runRoutes routes identifier
@@ -193,27 +193,27 @@ getRouteFor = fromJob $ \identifier -> CompilerM $ do
 
 --------------------------------------------------------------------------------
 -- | Get the body of the underlying resource
-getResourceBody :: Compiler a String
+getResourceBody :: Compiler String
 getResourceBody = getResourceWith resourceBody
 
 
 
 --------------------------------------------------------------------------------
 -- | Get the resource we are compiling as a string
-getResourceString :: Compiler a String
+getResourceString :: Compiler String
 getResourceString = getResourceWith $ const resourceString
 
 
 --------------------------------------------------------------------------------
 -- | Get the resource we are compiling as a lazy bytestring
 --
-getResourceLBS :: Compiler a ByteString
+getResourceLBS :: Compiler ByteString
 getResourceLBS = getResourceWith $ const resourceLBS
 
 
 --------------------------------------------------------------------------------
 -- | Overloadable function for 'getResourceString' and 'getResourceLBS'
-getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler c b
+getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler b
 getResourceWith reader = fromJob $ \_ -> CompilerM $ do
     provider <- compilerResourceProvider <$> ask
     r        <- compilerIdentifier <$> ask
@@ -251,13 +251,14 @@ getDependency id' = CompilerM $ do
 --
 require_ :: (Binary a, Typeable a, Writable a)
          => Identifier a
-         -> Compiler b a
+         -> Compiler a
 require_ identifier =
     fromDependency identifier >>> fromJob (const $ getDependency identifier)
 
 -- | Require another target. Using this function ensures automatic handling of
 -- dependencies
 --
+{-
 require :: (Binary a, Typeable a, Writable a)
         => Identifier a
         -> (b -> a -> c)
@@ -271,13 +272,14 @@ requireA :: (Binary a, Typeable a, Writable a)
          -> Compiler (b, a) c
          -> Compiler b c
 requireA identifier = (id &&& require_ identifier >>>)
+-}
 
 -- | Variant of 'requireAll' which drops the current value
 --
 requireAll_ :: (Binary a, Typeable a, Writable a)
             => Pattern a
-            -> Compiler b [a]
-requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
+            -> Compiler [a]
+requireAll_ pattern = fromDependencies (const getDeps) *> fromJob requireAll_'
   where
     getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
     requireAll_' = const $ CompilerM $ do
@@ -287,6 +289,7 @@ requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
 -- | Require a number of targets. Using this function ensures automatic handling
 -- of dependencies
 --
+{-
 requireAll :: (Binary a, Typeable a, Writable a)
            => Pattern a
            -> (b -> [a] -> c)
@@ -300,12 +303,13 @@ requireAllA :: (Binary a, Typeable a, Writable a)
             -> Compiler (b, [a]) c
             -> Compiler b c
 requireAllA pattern = (id &&& requireAll_ pattern >>>)
+-}
 
 cached :: (Binary a, Typeable a, Writable a)
        => String
-       -> Compiler () a
-       -> Compiler () a
-cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
+       -> Compiler a
+       -> Compiler a
+cached name (Compiler d j) = Compiler d $ CompilerM $ do
     logger     <- compilerLogger <$> ask
     identifier <- castIdentifier . compilerIdentifier <$> ask
     store      <- compilerStore <$> ask
@@ -326,8 +330,8 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
 
 -- | Create an unsafe compiler from a function in IO
 --
-unsafeCompiler :: (a -> IO b)   -- ^ Function to lift
-               -> Compiler a b  -- ^ Resulting compiler
+unsafeCompiler :: (a -> IO b)        -- ^ Function to lift
+               -> Compiler (a -> b)  -- ^ Resulting compiler
 unsafeCompiler f = fromJob $ CompilerM . liftIO . f
 
 -- | Compiler for debugging purposes
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 16863f8..cac5948 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -1,63 +1,35 @@
 --------------------------------------------------------------------------------
 -- | Internally used compiler module
+{-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Hakyll.Core.Compiler.Internal
-    ( Dependencies
-    , DependencyEnvironment (..)
-    , CompilerEnvironment (..)
-    , Throwing
-    , CompilerM (..)
+    ( CompilerRead (..)
     , Compiler (..)
-    , runCompilerJob
-    , runCompilerDependencies
-    , fromJob
-    , fromDependencies
-    , fromDependency
+    , compilerTell
+    , compilerAsk
+    , compilerThrow
+    , compilerCatch
     ) where
 
 
 --------------------------------------------------------------------------------
-import           Control.Applicative          (Alternative (..), Applicative,
-                                               pure, (<$>), (<*>))
-import           Control.Arrow
-import           Control.Category             (Category, id, (.))
-import           Control.Monad                (liftM2, (<=<))
-import           Control.Monad.Error          (ErrorT, catchError, runErrorT,
-                                               throwError)
-import           Control.Monad.Reader         (Reader, ReaderT, ask, runReader,
-                                               runReaderT)
-import           Data.Set                     (Set)
-import qualified Data.Set                     as S
-import           Prelude                      hiding (id, (.))
+import           Control.Applicative          (Alternative (..),
+                                               Applicative (..))
+import           Data.Monoid                  (mappend, mempty)
 
 
 --------------------------------------------------------------------------------
+import           Hakyll.Core.Dependencies
 import           Hakyll.Core.Identifier
 import           Hakyll.Core.Logger
 import           Hakyll.Core.ResourceProvider
 import           Hakyll.Core.Routes
 import           Hakyll.Core.Store
-import           Hakyll.Core.Util.Arrow
-
-
---------------------------------------------------------------------------------
--- | A set of dependencies
-type Dependencies = Set (Identifier ())
-
-
---------------------------------------------------------------------------------
--- | Environment in which the dependency analyzer runs
-data DependencyEnvironment = DependencyEnvironment
-    { -- | Target identifier
-      dependencyIdentifier :: Identifier ()
-    , -- | List of available identifiers we can depend upon
-      dependencyUniverse   :: [Identifier ()]
-    }
 
 
 --------------------------------------------------------------------------------
 -- | Environment in which a compiler runs
-data CompilerEnvironment = CompilerEnvironment
+data CompilerRead = CompilerRead
     { -- | Target identifier
       compilerIdentifier       :: Identifier ()
     , -- | Resource provider
@@ -76,164 +48,127 @@ data CompilerEnvironment = CompilerEnvironment
 
 
 --------------------------------------------------------------------------------
--- | A calculation possibly throwing an error
-type Throwing a = Either String a
+type CompilerWrite = [Dependency]
 
 
 --------------------------------------------------------------------------------
--- | The compiler monad
-newtype CompilerM a = CompilerM
-    { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
-    } deriving (Monad, Functor, Applicative)
+data CompilerResult a where
+    CompilerDone    :: a -> CompilerWrite -> CompilerResult a
+    CompilerError   :: String -> CompilerResult a
+    CompilerRequire :: Identifier b -> (b -> Compiler a) -> CompilerResult a
 
 
 --------------------------------------------------------------------------------
--- | The compiler arrow
-data Compiler a b = Compiler
-    { compilerDependencies :: Reader DependencyEnvironment Dependencies
-    , compilerJob          :: a -> CompilerM b
+newtype Compiler a = Compiler
+    { unCompiler :: CompilerRead -> IO (CompilerResult a)
     }
 
 
 --------------------------------------------------------------------------------
-instance Functor (Compiler a) where
-    fmap f (Compiler d j) = Compiler d $ fmap f . j
+instance Functor Compiler where
+    fmap f (Compiler c) = Compiler $ \r -> do
+        res <- c r
+        return $ case res of
+            CompilerDone x w    -> CompilerDone (f x) w
+            CompilerError e     -> CompilerError e
+            CompilerRequire i g -> CompilerRequire i (\x -> fmap f (g x))
     {-# INLINE fmap #-}
 
 
 --------------------------------------------------------------------------------
-instance Applicative (Compiler a) where
-    pure = fromJob . const . return
-    {-# INLINE pure #-}
+instance Monad Compiler where
+    return x = Compiler $ \_ -> return $ CompilerDone x mempty
+    {-# INLINE return #-}
 
-    Compiler d1 j1 <*> Compiler d2 j2 =
-        Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x
-    {-# INLINE (<*>) #-}
-
-
---------------------------------------------------------------------------------
-instance Alternative (Compiler a) where
-    empty = fromJob $ const $ CompilerM $
-        throwError "Hakyll.Core.Compiler.Internal: empty alternative"
+    Compiler c >>= f = Compiler $ \r -> do
+        res <- c r
+        case res of
+            CompilerDone x w    -> do
+                res' <- unCompiler (f x) r
+                return $ case res' of
+                    CompilerDone y w'   -> CompilerDone y (w `mappend` w')
+                    CompilerError e     -> CompilerError e
+                    CompilerRequire i g -> CompilerRequire i $ \z -> do
+                        compilerTell w  -- Save dependencies!
+                        g z
 
-    Compiler d1 j1 <|> Compiler d2 j2 =
-        Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $
-            catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x)
-    {-# INLINE (<|>) #-}
+            CompilerError e     -> return $ CompilerError e
+            CompilerRequire i g -> return $ CompilerRequire i $ \z -> g z >>= f
+    {-# INLINE (>>=) #-}
 
 
 --------------------------------------------------------------------------------
-instance Category Compiler where
-    id = Compiler (return S.empty) return
-    {-# INLINE id #-}
+instance Applicative Compiler where
+    pure x = return x
+    {-# INLINE pure #-}
 
-    Compiler d1 j1 . Compiler d2 j2 =
-        Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
-    {-# INLINE (.) #-}
+    f <*> x = f >>= \f' -> fmap f' x
+    {-# INLINE (<*>) #-}
 
 
 --------------------------------------------------------------------------------
-instance Arrow Compiler where
-    arr f = fromJob (return . f)
-    {-# INLINE arr #-}
-
-    first (Compiler d j) = Compiler d $ \(x, y) -> do
-        x' <- j x
-        return (x', y)
-    {-# INLINE first #-}
-
-    second (Compiler d j) = Compiler d $ \(x, y) -> do
-        y' <- j y
-        return (x, y')
-    {-# INLINE second #-}
+instance Alternative Compiler where
+    empty   = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
+    x <|> y = compilerCatch x (\_ -> y)
+    {-# INLINE (<|>) #-}
 
-    Compiler d1 j1 *** Compiler d2 j2 =
-        Compiler (liftM2 S.union d1 d2) $ \(x, y) -> do
-            x' <- j1 x
-            y' <- j2 y
-            return (x', y')
-    {-# INLINE (***) #-}
 
-    Compiler d1 j1 &&& Compiler d2 j2 =
-        Compiler (liftM2 S.union d1 d2) $ \x -> do
-            y1 <- j1 x
-            y2 <- j2 x
-            return (y1, y2)
-    {-# INLINE (&&&) #-}
+--------------------------------------------------------------------------------
+compilerAsk :: Compiler CompilerRead
+compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
+{-# INLINE compilerAsk #-}
 
 
 --------------------------------------------------------------------------------
-instance ArrowChoice Compiler where
-    left (Compiler d j) = Compiler d $ \e -> case e of
-        Left l  -> Left  <$> j l
-        Right r -> Right <$> return r
-    {-# INLINE left #-}
-
-    Compiler d1 j1 ||| Compiler d2 j2 = Compiler (liftM2 S.union d1 d2) $
-        \e -> case e of Left x  -> j1 x; Right y -> j2 y
-    {-# INLINE (|||) #-}
+compilerTell :: [Dependency] -> Compiler ()
+compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
+{-# INLINE compilerTell #-}
 
 
 --------------------------------------------------------------------------------
-instance ArrowMap Compiler where
-    mapA (Compiler d j) = Compiler d $ mapM j
-    {-# INLINE mapA #-}
+compilerThrow :: String -> Compiler a
+compilerThrow e = Compiler $ \_ -> return $ CompilerError e
+{-# INLINE compilerThrow #-}
 
 
 --------------------------------------------------------------------------------
--- | Run a compiler, yielding the resulting target
-runCompilerJob :: Compiler () a     -- ^ Compiler to run
-               -> Identifier ()     -- ^ Target identifier
-               -> ResourceProvider  -- ^ Resource provider
-               -> [Identifier ()]   -- ^ Universe
-               -> Routes            -- ^ Route
-               -> Store             -- ^ Store
-               -> Bool              -- ^ Was the resource modified?
-               -> Logger            -- ^ Logger
-               -> IO (Throwing a)   -- ^ Result
-runCompilerJob compiler id' provider universe route store modified logger =
-    runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env
-  where
-    env = CompilerEnvironment
-            { compilerIdentifier       = id'
-            , compilerResourceProvider = provider
-            , compilerUniverse         = universe
-            , compilerRoutes           = route
-            , compilerStore            = store
-            , compilerResourceModified = modified
-            , compilerLogger           = logger
-            }
+compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
+compilerCatch (Compiler x) f = Compiler $ \r -> do
+    res <- x r
+    case res of
+        CompilerError e -> unCompiler (f e) r
+        _               -> return res
+{-# INLINE compilerCatch #-}
 
 
+{-
 --------------------------------------------------------------------------------
-runCompilerDependencies :: Compiler () a
-                        -> Identifier ()
-                        -> [Identifier ()]
-                        -> Dependencies
-runCompilerDependencies compiler identifier universe =
-    runReader (compilerDependencies compiler) env
-  where
-    env = DependencyEnvironment
-            { dependencyIdentifier = identifier
-            , dependencyUniverse   = universe
-            }
+-- | The compiler monad
+newtype CompilerM a = CompilerM
+    { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
+    } deriving (Monad, Functor, Applicative)
 
 
 --------------------------------------------------------------------------------
-fromJob :: (a -> CompilerM b) -> Compiler a b
-fromJob = Compiler $ return S.empty
-{-# INLINE fromJob #-}
+-- | The compiler arrow
+data Compiler a = Compiler
+    { compilerDependencies :: Reader DependencyEnvironment Dependencies
+    , compilerJob          :: CompilerM a
+    }
 
 
 --------------------------------------------------------------------------------
-fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
-                 -> Compiler b b
-fromDependencies collectDeps = flip Compiler return $ do
-    DependencyEnvironment identifier universe <- ask
-    return $ S.fromList $ collectDeps identifier universe
+instance Functor Compiler where
+    fmap f (Compiler d j) = Compiler d $ fmap f j
+    {-# INLINE fmap #-}
 
 
 --------------------------------------------------------------------------------
--- | Wait until another compiler has finished before running this compiler
-fromDependency :: Identifier a -> Compiler b b
-fromDependency = fromDependencies . const . const . return . castIdentifier
+instance Applicative Compiler where
+    pure = fromJob . return
+    {-# INLINE pure #-}
+
+    Compiler d1 j1 <*> Compiler d2 j2 =
+        Compiler (liftM2 S.union d1 d2) $ j1 <*> j2
+    {-# INLINE (<*>) #-}
+-}
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index 589bf6a..dc02be3 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -43,6 +43,7 @@ module Hakyll.Core.Identifier.Pattern
     , fromGlob
     , fromList
     , fromRegex
+    , fromVersion
 
       -- * Manipulating patterns
     , complement
@@ -176,6 +177,11 @@ fromRegex = Regex
 
 
 --------------------------------------------------------------------------------
+fromVersion :: Maybe String -> Pattern a
+fromVersion = Version
+
+
+--------------------------------------------------------------------------------
 -- | Inverts a pattern, e.g.
 --
 -- > complement "foo/bar.html"
@@ -190,7 +196,7 @@ complement = Complement
 --
 -- > "foo/*.markdown" `withVersion` "pdf"
 withVersion :: Pattern a -> String -> Pattern a
-withVersion p v = And p $ Version $ Just v
+withVersion p v = And p $ fromVersion $ Just v
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/ResourceProvider/Internal.hs b/src/Hakyll/Core/ResourceProvider/Internal.hs
index 1f8f776..02ff98c 100644
--- a/src/Hakyll/Core/ResourceProvider/Internal.hs
+++ b/src/Hakyll/Core/ResourceProvider/Internal.hs
@@ -48,7 +48,7 @@ newResourceProvider :: Store                -- ^ Store to use
                     -> FilePath             -- ^ Search directory
                     -> IO ResourceProvider  -- ^ Resulting provider
 newResourceProvider store ignore directory = do
-    list  <- map parseIdentifier . filter (not . ignore) <$>
+    list  <- map fromFilePath . filter (not . ignore) <$>
         getRecursiveContents False directory
     cache <- newIORef M.empty
     return $ ResourceProvider (S.fromList list) cache store
@@ -60,10 +60,10 @@ resourceList = S.toList . resourceSet
 
 
 --------------------------------------------------------------------------------
--- | Check if a given resiyrce exists
+-- | Check if a given resource exists
 resourceExists :: ResourceProvider -> Identifier a -> Bool
 resourceExists provider =
-    (`S.member` resourceSet provider) . setGroup Nothing . castIdentifier
+    (`S.member` resourceSet provider) . setVersion Nothing . castIdentifier
 
 
 --------------------------------------------------------------------------------
@@ -71,7 +71,7 @@ resourceExists provider =
 -- filename)
 resourceMetadataResource :: Identifier a -> Identifier ()
 resourceMetadataResource =
-    parseIdentifier . flip addExtension "metadata" . toFilePath
+    fromFilePath . flip addExtension "metadata" . toFilePath
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/ResourceProvider/Modified.hs b/src/Hakyll/Core/ResourceProvider/Modified.hs
index 837bc8c..0da3d0f 100644
--- a/src/Hakyll/Core/ResourceProvider/Modified.hs
+++ b/src/Hakyll/Core/ResourceProvider/Modified.hs
@@ -47,7 +47,7 @@ resourceModified rp r
 
                 return m
   where
-    normalized = castIdentifier $ setGroup Nothing r
+    normalized = castIdentifier $ setVersion Nothing r
     exists     = resourceExists rp r
     store      = resourceStore rp
     cacheRef   = resourceModifiedCache rp
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index 25e3a14..63e32e7 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -1,3 +1,4 @@
+--------------------------------------------------------------------------------
 -- | Once a target is compiled, the user usually wants to save it to the disk.
 -- This is where the 'Routes' type comes in; it determines where a certain
 -- target should be written.
@@ -24,7 +25,6 @@
 --   not appear in your site directory.
 --
 -- * If an item matches multiple routes, the first rule will be chosen.
---
 {-# LANGUAGE Rank2Types #-}
 module Hakyll.Core.Routes
     ( Routes
@@ -38,33 +38,44 @@ module Hakyll.Core.Routes
     , composeRoutes
     ) where
 
+
+--------------------------------------------------------------------------------
 import Data.Monoid (Monoid, mempty, mappend)
 import Control.Monad (mplus)
 import System.FilePath (replaceExtension)
 
+
+--------------------------------------------------------------------------------
 import Hakyll.Core.Identifier
 import Hakyll.Core.Identifier.Pattern
 import Hakyll.Core.Util.String
 
+
+--------------------------------------------------------------------------------
 -- | Type used for a route
---
 newtype Routes = Routes {unRoutes :: forall a. Identifier a -> Maybe FilePath}
 
+
+--------------------------------------------------------------------------------
 instance Monoid Routes where
     mempty = Routes $ const Nothing
     mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'
 
+
+--------------------------------------------------------------------------------
 -- | Apply a route to an identifier
---
 runRoutes :: Routes -> Identifier a -> Maybe FilePath
 runRoutes = unRoutes
 
+
+--------------------------------------------------------------------------------
 -- | A route that uses the identifier as filepath. For example, the target with
 -- ID @foo\/bar@ will be written to the file @foo\/bar@.
---
 idRoute :: Routes
 idRoute = Routes $ Just . toFilePath
 
+
+--------------------------------------------------------------------------------
 -- | Set (or replace) the extension of a route.
 --
 -- Example:
@@ -82,29 +93,34 @@ idRoute = Routes $ Just . toFilePath
 -- Result:
 --
 -- > Just "posts/the-art-of-trolling.html"
---
 setExtension :: String -> Routes
-setExtension extension = Routes $ fmap (`replaceExtension` extension)
-                                . unRoutes idRoute
+setExtension extension = Routes $
+    fmap (`replaceExtension` extension) . unRoutes idRoute
+
 
+--------------------------------------------------------------------------------
 -- | Apply the route if the identifier matches the given pattern, fail
 -- otherwise
---
 matchRoute :: Pattern a -> Routes -> Routes
 matchRoute pattern (Routes route) = Routes $ \id' ->
     if matches pattern (castIdentifier id') then route id' else Nothing
 
+
+--------------------------------------------------------------------------------
 -- | Create a custom route. This should almost always be used with
 -- 'matchRoute'
---
 customRoute :: (Identifier a -> FilePath) -> Routes
 customRoute f = Routes $ Just . f . castIdentifier
 
+
+--------------------------------------------------------------------------------
 -- | A route that always gives the same result. Obviously, you should only use
 -- this for a single compilation rule.
 constRoute :: FilePath -> Routes
 constRoute = customRoute . const
 
+
+--------------------------------------------------------------------------------
 -- | Create a gsub route
 --
 -- Example:
@@ -114,13 +130,14 @@ constRoute = customRoute . const
 -- Result:
 --
 -- > Just "tags/bar.xml"
---
 gsubRoute :: String              -- ^ Pattern
           -> (String -> String)  -- ^ Replacement
           -> Routes              -- ^ Resulting route
 gsubRoute pattern replacement = customRoute $
     replaceAll pattern replacement . toFilePath
 
+
+--------------------------------------------------------------------------------
 -- | Compose routes so that @f `composeRoutes` g@ is more or less equivalent
 -- with @f >>> g@.
 --
@@ -134,10 +151,9 @@ gsubRoute pattern replacement = customRoute $
 -- > Just "tags/bar.xml"
 --
 -- If the first route given fails, Hakyll will not apply the second route.
---
 composeRoutes :: Routes  -- ^ First route to apply
               -> Routes  -- ^ Second route to apply
               -> Routes  -- ^ Resulting route
 composeRoutes (Routes f) (Routes g) = Routes $ \i -> do
     p <- f i
-    g $ parseIdentifier p
+    g $ fromFilePath p
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index ba89d75..c481977 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -31,7 +31,7 @@ module Hakyll.Core.Rules
 
 --------------------------------------------------------------------------------
 import           Control.Applicative            ((<$>))
-import           Control.Arrow                  (arr, (***), (>>>))
+import           Control.Arrow                  ((***))
 import           Control.Monad.Reader           (ask, local)
 import           Control.Monad.State            (get, put)
 import           Control.Monad.Writer           (tell)
@@ -64,14 +64,12 @@ tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
 --------------------------------------------------------------------------------
 -- | Add a number of compilers
 tellCompilers :: (Binary a, Typeable a, Writable a)
-             => [(Identifier a, Compiler () a)]
+             => [(Identifier a, Compiler a)]
              -> Rules
 tellCompilers compilers = RulesM $ do
     -- We box the compilers so they have a more simple type
-    let compilers' = map (castIdentifier *** boxCompiler) compilers
+    let compilers' = map (castIdentifier *** fmap compiledItem) compilers
     tell $ RuleSet mempty compilers' mempty
-  where
-    boxCompiler = (>>> arr compiledItem)
 
 
 --------------------------------------------------------------------------------
@@ -123,9 +121,9 @@ match pattern = RulesM . local addPredicate . unRulesM
 -- This will put the compiler for the raw content in a separate group
 -- (@\"raw\"@), which causes it to be compiled as well.
 group :: String -> RulesM a -> RulesM a
-group g = RulesM . local setGroup' . unRulesM
+group g = RulesM . local setVersion' . unRulesM
   where
-    setGroup' env = env { rulesGroup = Just g }
+    setVersion' env = env {rulesVersion = Just g}
 
 
 --------------------------------------------------------------------------------
@@ -135,12 +133,12 @@ group g = RulesM . local setGroup' . unRulesM
 -- 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)
-        => Compiler () a -> RulesM (Pattern a)
+        => Compiler a -> RulesM (Pattern a)
 compile compiler = do
     ids <- resources
     tellCompilers [(castIdentifier id', compiler) | id' <- ids]
     tellResources ids
-    return $ list $ map castIdentifier ids
+    return $ fromList $ map castIdentifier ids
 
 
 --------------------------------------------------------------------------------
@@ -153,10 +151,10 @@ compile compiler = do
 -- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been
 -- used).
 create :: (Binary a, Typeable a, Writable a)
-       => Identifier a -> Compiler () a -> RulesM (Identifier a)
+       => Identifier a -> Compiler a -> RulesM (Identifier a)
 create id' compiler = RulesM $ do
-    group' <- rulesGroup <$> ask
-    let id'' = setGroup group' id'
+    version' <- rulesVersion <$> ask
+    let id'' = setVersion version' id'
     unRulesM $ tellCompilers [(id'', compiler)]
     return id''
 
@@ -168,10 +166,11 @@ create id' compiler = RulesM $ do
 route :: Routes -> Rules
 route route' = RulesM $ do
     -- We want the route only to be applied if we match the current pattern and
-    -- group
-    pattern <- rulesPattern <$> ask
-    group' <- rulesGroup <$> ask
-    unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route'
+    -- version
+    pattern  <- rulesPattern <$> ask
+    version' <- rulesVersion <$> ask
+    unRulesM $ tellRoute $ matchRoute
+        (pattern `mappend` fromVersion version') route'
 
 
 --------------------------------------------------------------------------------
@@ -181,8 +180,8 @@ resources :: RulesM [Identifier ()]
 resources = RulesM $ do
     pattern  <- rulesPattern <$> ask
     provider <- rulesResourceProvider <$> ask
-    g        <- rulesGroup <$> ask
-    return $ filterMatches pattern $ map (setGroup g) $ resourceList provider
+    g        <- rulesVersion <$> ask
+    return $ filterMatches pattern $ map (setVersion g) $ resourceList provider
 
 
 --------------------------------------------------------------------------------
@@ -193,6 +192,6 @@ freshIdentifier :: String                 -- ^ Prefix
 freshIdentifier prefix = RulesM $ do
     state <- get
     let index = rulesNextIdentifier state
-        id'   = parseIdentifier $ prefix ++ "/" ++ show index
+        id'   = fromFilePath $ prefix ++ "/" ++ show index
     put $ state {rulesNextIdentifier = index + 1}
     return id'
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index dc2badd..ec3714c 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -35,7 +35,7 @@ data RuleSet = RuleSet
     { -- | Routes used in the compilation structure
       rulesRoutes    :: Routes
     , -- | Compilation rules
-      rulesCompilers :: [(Identifier (), Compiler () CompiledItem)]
+      rulesCompilers :: [(Identifier (), Compiler CompiledItem)]
     , -- | A set of the actually used files
       rulesResources :: Set (Identifier ())
     }
@@ -60,7 +60,7 @@ data RuleState = RuleState
 data RuleEnvironment = RuleEnvironment
     { rulesResourceProvider :: ResourceProvider
     , rulesPattern          :: forall a. Pattern a
-    , rulesGroup            :: Maybe String
+    , rulesVersion          :: Maybe String
     }
 
 
@@ -88,7 +88,7 @@ runRules rules provider = do
     env   = RuleEnvironment
         { rulesResourceProvider = provider
         , rulesPattern          = mempty
-        , rulesGroup            = Nothing
+        , rulesVersion          = Nothing
         }
author	Jasper Van der Jeugt <m@jaspervdj.be>	2012-11-12 16:10:06 +0100
committer	Jasper Van der Jeugt <m@jaspervdj.be>	2012-11-12 16:10:06 +0100
commit	760b4344377c81922ce5ab4ba05a41f88f45165d (patch)
tree	a2b7f45c61938879e4badce363f03c5abf85ae66 /src
parent	c7d3c60c54926b54847bfc691e27f24dc644dd65 (diff)
download	hakyll-760b4344377c81922ce5ab4ba05a41f88f45165d.tar.gz