diff options
31 files changed, 840 insertions, 488 deletions
diff --git a/hakyll.cabal b/hakyll.cabal index 69a72a1..6589838 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -99,10 +99,8 @@ Library Hakyll.Core.Identifier Hakyll.Core.Identifier.Pattern Hakyll.Core.Logger - Hakyll.Core.Resource - Hakyll.Core.Resource.Provider - Hakyll.Core.Resource.Provider.Dummy - Hakyll.Core.Resource.Provider.File + Hakyll.Core.Metadata + Hakyll.Core.ResourceProvider Hakyll.Core.Routes Hakyll.Core.Rules Hakyll.Core.Run @@ -126,6 +124,7 @@ Library Hakyll.Web.Pandoc.FileType Hakyll.Web.Tags Hakyll.Web.Template + Hakyll.Web.Template.Context Hakyll.Web.Template.Read Hakyll.Web.Urls Hakyll.Web.Urls.Relativize @@ -134,6 +133,10 @@ Library Other-Modules: Hakyll.Core.Compiler.Internal Hakyll.Core.DirectedGraph.Internal + Hakyll.Core.ResourceProvider.Internal + Hakyll.Core.ResourceProvider.Metadata + Hakyll.Core.ResourceProvider.MetadataCache + Hakyll.Core.ResourceProvider.Modified Hakyll.Core.Rules.Internal Hakyll.Web.Page.Internal Hakyll.Web.Template.Internal diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 249d3a8..1b05df0 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -6,8 +6,8 @@ module Hakyll , module Hakyll.Core.Configuration , module Hakyll.Core.Identifier , module Hakyll.Core.Identifier.Pattern - , module Hakyll.Core.Resource - , module Hakyll.Core.Resource.Provider + , module Hakyll.Core.Metadata + , module Hakyll.Core.ResourceProvider , module Hakyll.Core.Routes , module Hakyll.Core.Rules #ifdef UNIX_FILTER @@ -42,8 +42,8 @@ import Hakyll.Core.Compiler import Hakyll.Core.Configuration import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider +import Hakyll.Core.Metadata +import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes import Hakyll.Core.Rules #ifdef UNIX_FILTER diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 3c62a3a..840f3bd 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -93,7 +93,6 @@ module Hakyll.Core.Compiler ( Compiler , runCompiler , getIdentifier - , getResource , getRoute , getRouteFor , getResourceString @@ -109,7 +108,6 @@ module Hakyll.Core.Compiler , cached , unsafeCompiler , traceShowCompiler - , mapCompiler , timedCompiler , byPattern , byExtension @@ -135,8 +133,7 @@ import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.CompiledItem import Hakyll.Core.Writable -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider +import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal import Hakyll.Core.Store (Store) import Hakyll.Core.Rules.Internal @@ -181,11 +178,6 @@ getIdentifier :: Compiler a (Identifier b) getIdentifier = fromJob $ const $ CompilerM $ castIdentifier . compilerIdentifier <$> ask --- | Get the resource that is currently being compiled --- -getResource :: Compiler a Resource -getResource = getIdentifier >>> arr fromIdentifier - -- | Get the route we are using for this item -- getRoute :: Compiler a (Maybe FilePath) @@ -200,23 +192,23 @@ getRouteFor = fromJob $ \identifier -> CompilerM $ do -- | Get the resource we are compiling as a string -- -getResourceString :: Compiler Resource String +getResourceString :: Compiler a String getResourceString = getResourceWith resourceString -- | Get the resource we are compiling as a lazy bytestring -- -getResourceLBS :: Compiler Resource ByteString +getResourceLBS :: Compiler a ByteString getResourceLBS = getResourceWith resourceLBS -- | Overloadable function for 'getResourceString' and 'getResourceLBS' -- -getResourceWith :: (ResourceProvider -> Resource -> IO a) - -> Compiler Resource a -getResourceWith reader = fromJob $ \r -> CompilerM $ do - let filePath = unResource r +getResourceWith :: (Identifier a -> IO b) -> Compiler c b +getResourceWith reader = fromJob $ \_ -> CompilerM $ do provider <- compilerResourceProvider <$> ask + r <- compilerIdentifier <$> ask + let filePath = toFilePath r if resourceExists provider r - then liftIO $ reader provider r + then liftIO $ reader $ castIdentifier r else throwError $ error' filePath where error' id' = "Hakyll.Core.Compiler.getResourceWith: resource " @@ -300,17 +292,17 @@ requireAllA pattern = (id &&& requireAll_ pattern >>>) cached :: (Binary a, Typeable a, Writable a) => String - -> Compiler Resource a - -> Compiler Resource a + -> Compiler () a + -> Compiler () a cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do - logger <- compilerLogger <$> ask + logger <- compilerLogger <$> ask identifier <- castIdentifier . compilerIdentifier <$> ask - store <- compilerStore <$> ask - modified <- compilerResourceModified <$> ask - progName <- liftIO getProgName + store <- compilerStore <$> ask + modified <- compilerResourceModified <$> ask + progName <- liftIO getProgName report logger $ "Checking cache: " ++ if modified then "modified" else "OK" if modified - then do v <- unCompilerM $ j $ fromIdentifier identifier + then do v <- unCompilerM $ j () liftIO $ Store.set store [name, show identifier] v return v else do v <- liftIO $ Store.get store [name, show identifier] @@ -335,12 +327,6 @@ traceShowCompiler = fromJob $ \x -> CompilerM $ do report logger $ show x return x --- | Map over a compiler --- -mapCompiler :: Compiler a b - -> Compiler [a] [b] -mapCompiler (Compiler d j) = Compiler d $ mapM j - -- | Log and time a compiler -- timedCompiler :: String -- ^ Message diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 8ed822d..16863f8 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -1,5 +1,5 @@ +-------------------------------------------------------------------------------- -- | Internally used compiler module --- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal ( Dependencies @@ -15,28 +15,38 @@ module Hakyll.Core.Compiler.Internal , fromDependency ) where -import Prelude hiding ((.), id) -import Control.Applicative (Applicative, pure, (<*>), (<$>)) -import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) -import Control.Monad.Error (ErrorT, runErrorT) -import Control.Monad ((<=<), liftM2) -import Data.Set (Set) -import qualified Data.Set as S -import Control.Category (Category, (.), id) -import Control.Arrow (Arrow, ArrowChoice, arr, first, left) - -import Hakyll.Core.Identifier -import Hakyll.Core.Resource.Provider -import Hakyll.Core.Store -import Hakyll.Core.Routes -import Hakyll.Core.Logger +-------------------------------------------------------------------------------- +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 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 () @@ -44,8 +54,9 @@ data DependencyEnvironment = DependencyEnvironment dependencyUniverse :: [Identifier ()] } + +-------------------------------------------------------------------------------- -- | Environment in which a compiler runs --- data CompilerEnvironment = CompilerEnvironment { -- | Target identifier compilerIdentifier :: Identifier () @@ -63,49 +74,114 @@ data CompilerEnvironment = CompilerEnvironment compilerLogger :: Logger } + +-------------------------------------------------------------------------------- -- | A calculation possibly throwing an error --- type Throwing a = Either String a + +-------------------------------------------------------------------------------- -- | The compiler monad --- newtype CompilerM a = CompilerM { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a } deriving (Monad, Functor, Applicative) + +-------------------------------------------------------------------------------- -- | The compiler arrow --- data Compiler a b = Compiler { compilerDependencies :: Reader DependencyEnvironment Dependencies , compilerJob :: a -> CompilerM b } + +-------------------------------------------------------------------------------- instance Functor (Compiler a) where - fmap f ~(Compiler d j) = Compiler d $ fmap f . j + fmap f (Compiler d j) = Compiler d $ fmap f . j + {-# INLINE fmap #-} + +-------------------------------------------------------------------------------- instance Applicative (Compiler a) where - pure = Compiler (return S.empty) . const . return - ~(Compiler d1 f) <*> ~(Compiler d2 j) = - Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x + pure = fromJob . const . return + {-# INLINE pure #-} + + 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 d1 j1 <|> Compiler d2 j2 = + Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $ + catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x) + {-# INLINE (<|>) #-} + +-------------------------------------------------------------------------------- instance Category Compiler where id = Compiler (return S.empty) return - ~(Compiler d1 j1) . ~(Compiler d2 j2) = + {-# INLINE id #-} + + Compiler d1 j1 . Compiler d2 j2 = Compiler (liftM2 S.union d1 d2) (j1 <=< j2) + {-# INLINE (.) #-} + +-------------------------------------------------------------------------------- instance Arrow Compiler where - arr f = Compiler (return S.empty) (return . f) - first ~(Compiler d j) = Compiler d $ \(x, y) -> do + 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 #-} + 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 (&&&) #-} + + +-------------------------------------------------------------------------------- instance ArrowChoice Compiler where - left ~(Compiler d j) = Compiler d $ \e -> case e of + 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 (|||) #-} + +-------------------------------------------------------------------------------- +instance ArrowMap Compiler where + mapA (Compiler d j) = Compiler d $ mapM j + {-# INLINE mapA #-} + + +-------------------------------------------------------------------------------- -- | Run a compiler, yielding the resulting target --- runCompilerJob :: Compiler () a -- ^ Compiler to run -> Identifier () -- ^ Target identifier -> ResourceProvider -- ^ Resource provider @@ -128,6 +204,8 @@ runCompilerJob compiler id' provider universe route store modified logger = , compilerLogger = logger } + +-------------------------------------------------------------------------------- runCompilerDependencies :: Compiler () a -> Identifier () -> [Identifier ()] @@ -140,17 +218,22 @@ runCompilerDependencies compiler identifier universe = , dependencyUniverse = universe } -fromJob :: (a -> CompilerM b) - -> Compiler a b -fromJob = Compiler (return S.empty) +-------------------------------------------------------------------------------- +fromJob :: (a -> CompilerM b) -> Compiler a b +fromJob = Compiler $ return S.empty +{-# INLINE fromJob #-} + + +-------------------------------------------------------------------------------- fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()]) -> Compiler b b fromDependencies collectDeps = flip Compiler return $ do DependencyEnvironment identifier universe <- ask return $ S.fromList $ collectDeps identifier universe + +-------------------------------------------------------------------------------- -- | Wait until another compiler has finished before running this compiler --- fromDependency :: Identifier a -> Compiler b b fromDependency = fromDependencies . const . const . return . castIdentifier diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs index 90f0eea..d7bb8c6 100644 --- a/src/Hakyll/Core/Identifier.hs +++ b/src/Hakyll/Core/Identifier.hs @@ -34,6 +34,7 @@ module Hakyll.Core.Identifier ( Identifier (..) , castIdentifier , parseIdentifier + , fromFilePath , toFilePath , setGroup ) where @@ -77,16 +78,24 @@ castIdentifier :: Identifier a -> Identifier b castIdentifier (Identifier g p) = Identifier g p {-# INLINE castIdentifier #-} + +-------------------------------------------------------------------------------- -- | Parse an identifier from a string --- parseIdentifier :: String -> Identifier a -parseIdentifier = Identifier Nothing - . intercalate "/" . filter (not . null) . split' +parseIdentifier = Identifier Nothing . + 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 diff --git a/src/Hakyll/Core/Metadata.hs b/src/Hakyll/Core/Metadata.hs new file mode 100644 index 0000000..79922e1 --- /dev/null +++ b/src/Hakyll/Core/Metadata.hs @@ -0,0 +1,24 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Metadata + ( Metadata + , MonadMetadata (..) + ) where + + +-------------------------------------------------------------------------------- +import Data.Map (Map) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier + + +-------------------------------------------------------------------------------- +type Metadata = Map String String + + +-------------------------------------------------------------------------------- +class MonadMetadata m where + identifierMetadata :: Identifier a -> m Metadata + -- allMetadata :: m [(Resource, Metadata)] + -- patternMetadata :: Pattern a -> m [(Resource, Metadata)] diff --git a/src/Hakyll/Core/Resource.hs b/src/Hakyll/Core/Resource.hs deleted file mode 100644 index 566bb26..0000000 --- a/src/Hakyll/Core/Resource.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | Module exporting the simple 'Resource' type --- -module Hakyll.Core.Resource - ( Resource - , unResource - , resource - , fromIdentifier - , toIdentifier - ) where - -import Hakyll.Core.Identifier - --- | A resource --- -newtype Resource = Resource {unResource :: FilePath} - deriving (Eq, Show, Ord) - --- | Smart constructor to ensure we have @/@ as path separator --- -resource :: FilePath -> Resource -resource = fromIdentifier . parseIdentifier - --- | Create a resource from an identifier --- -fromIdentifier :: Identifier a -> Resource -fromIdentifier = Resource . toFilePath - --- | Map the resource to an identifier. Note that the group will not be set! --- -toIdentifier :: Resource -> Identifier a -toIdentifier = parseIdentifier . unResource diff --git a/src/Hakyll/Core/Resource/Provider.hs b/src/Hakyll/Core/Resource/Provider.hs deleted file mode 100644 index 2ed7797..0000000 --- a/src/Hakyll/Core/Resource/Provider.hs +++ /dev/null @@ -1,125 +0,0 @@ --------------------------------------------------------------------------------- --- | This module provides an API for resource providers. Resource providers --- allow Hakyll to get content from resources; the type of resource depends on --- the concrete instance. --- --- A resource is represented by the 'Resource' type. This is basically just a --- newtype wrapper around 'Identifier' -- but it has an important effect: it --- guarantees that a resource with this identifier can be provided by one or --- more resource providers. --- --- Therefore, it is not recommended to read files directly -- you should use the --- provided 'Resource' methods. --- -module Hakyll.Core.Resource.Provider - ( ResourceProvider (..) - , resourceList - , makeResourceProvider - , resourceExists - , resourceDigest - , resourceModified - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Control.Concurrent (MVar, readMVar, modifyMVar_, newMVar) -import Data.Map (Map) -import qualified Data.Map as M -import qualified Data.Set as S - - --------------------------------------------------------------------------------- -import Data.Time (UTCTime) -import qualified Crypto.Hash.MD5 as MD5 -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB - - --------------------------------------------------------------------------------- -import Hakyll.Core.Store (Store) -import Hakyll.Core.Resource -import qualified Hakyll.Core.Store as Store - - --------------------------------------------------------------------------------- --- | A value responsible for retrieving and listing resources -data ResourceProvider = ResourceProvider - { -- | A set of all resources this provider is able to provide - resourceSet :: S.Set Resource - , -- | Retrieve a certain resource as string - resourceString :: Resource -> IO String - , -- | Retrieve a certain resource as lazy bytestring - resourceLBS :: Resource -> IO LB.ByteString - , -- | Check when a resource was last modified - resourceModificationTime :: Resource -> IO UTCTime - , -- | Cache keeping track of modified items - resourceModifiedCache :: MVar (Map Resource Bool) - } - - --------------------------------------------------------------------------------- --- | Create a resource provider -makeResourceProvider :: [Resource] -- ^ Resource list - -> (Resource -> IO String) -- ^ String reader - -> (Resource -> IO LB.ByteString) -- ^ ByteString reader - -> (Resource -> IO UTCTime) -- ^ Time checker - -> IO ResourceProvider -- ^ Resulting provider -makeResourceProvider l s b t = - ResourceProvider (S.fromList l) s b t <$> newMVar M.empty - - --------------------------------------------------------------------------------- --- | Get the list of all resources -resourceList :: ResourceProvider -> [Resource] -resourceList = S.toList . resourceSet - - --------------------------------------------------------------------------------- --- | Check if a given identifier has a resource -resourceExists :: ResourceProvider -> Resource -> Bool -resourceExists provider = flip S.member $ resourceSet provider - - --------------------------------------------------------------------------------- --- | Retrieve a digest for a given resource -resourceDigest :: ResourceProvider -> Resource -> IO B.ByteString -resourceDigest provider = fmap MD5.hashlazy . resourceLBS provider - - --------------------------------------------------------------------------------- --- | Check if a resource was modified -resourceModified :: ResourceProvider -> Store -> Resource -> IO Bool -resourceModified provider store r = do - cache <- readMVar mvar - case M.lookup r 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 r - then digestModified provider store r - else return False - modifyMVar_ mvar (return . M.insert r m) - return m - where - mvar = resourceModifiedCache provider - - --------------------------------------------------------------------------------- --- | Check if a resource digest was modified -digestModified :: ResourceProvider -> Store -> Resource -> IO Bool -digestModified provider store r = do - -- Get the latest seen digest from the store - lastDigest <- Store.get store key - -- Calculate the digest for the resource - newDigest <- resourceDigest provider r - -- Check digests - if Store.Found newDigest == lastDigest - -- All is fine, not modified - then return False - -- Resource modified; store new digest - else do Store.set store key newDigest - return True - where - key = ["Hakyll.Core.ResourceProvider.digestModified", unResource r] diff --git a/src/Hakyll/Core/Resource/Provider/Dummy.hs b/src/Hakyll/Core/Resource/Provider/Dummy.hs deleted file mode 100644 index 548f845..0000000 --- a/src/Hakyll/Core/Resource/Provider/Dummy.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Dummy resource provider for testing purposes --- -module Hakyll.Core.Resource.Provider.Dummy - ( dummyResourceProvider - ) where - -import Data.Map (Map) -import qualified Data.Map as M - -import Data.Time (getCurrentTime) -import Data.ByteString.Lazy (ByteString) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL - -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider - --- | Create a dummy 'ResourceProvider' --- -dummyResourceProvider :: Map String ByteString -> IO ResourceProvider -dummyResourceProvider vfs = makeResourceProvider - (map resource (M.keys vfs)) - (return . TL.unpack . TL.decodeUtf8 . (vfs M.!) . unResource) - (return . (vfs M.!) . unResource) - (const getCurrentTime) diff --git a/src/Hakyll/Core/Resource/Provider/File.hs b/src/Hakyll/Core/Resource/Provider/File.hs deleted file mode 100644 index 3a67817..0000000 --- a/src/Hakyll/Core/Resource/Provider/File.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | A concrete 'ResourceProvider' that gets it's resources from the filesystem --- -{-# LANGUAGE CPP #-} -module Hakyll.Core.Resource.Provider.File - ( fileResourceProvider - ) where - -import Control.Applicative ((<$>)) - -import Data.Time (readTime) -import System.Directory (getModificationTime) -import System.Locale (defaultTimeLocale) -import System.Time (formatCalendarTime, toCalendarTime) -import qualified Data.ByteString.Lazy as LB - -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider -import Hakyll.Core.Util.File -import Hakyll.Core.Configuration - --- | Create a filesystem-based 'ResourceProvider' --- -fileResourceProvider :: HakyllConfiguration -> IO ResourceProvider -fileResourceProvider configuration = do - -- Retrieve a list of paths - list <- map resource . filter (not . shouldIgnoreFile configuration) <$> - getRecursiveContents False "." - makeResourceProvider list (readFile . unResource) - (LB.readFile . unResource) - (mtime . unResource) - where - mtime r = do -#if MIN_VERSION_directory(1,2,0) - getModificationTime r -#else - ct <- toCalendarTime =<< getModificationTime r - let str = formatCalendarTime defaultTimeLocale "%s" ct - return $ readTime defaultTimeLocale "%s" str -#endif diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs new file mode 100644 index 0000000..f18d462 --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -0,0 +1,46 @@ +-------------------------------------------------------------------------------- +-- | This module provides an wrapper API around the file system which does some +-- caching. +module Hakyll.Core.ResourceProvider + ( -- * Constructing resource providers + ResourceProvider + , newResourceProvider + + -- * Querying resource properties + , resourceList + , resourceExists + , resourceModified + , resourceModificationTime + + -- * Access to raw resource content + , resourceString + , resourceLBS + + -- * Access to metadata and body content + , resourceMetadata + , resourceBody + ) where + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.ResourceProvider.Internal +import qualified Hakyll.Core.ResourceProvider.MetadataCache as Internal +import Hakyll.Core.ResourceProvider.Modified + + +-------------------------------------------------------------------------------- +-- | Wrapper to ensure metadata cache is invalidated if necessary +resourceMetadata :: ResourceProvider -> Identifier a -> IO Metadata +resourceMetadata rp r = do + _ <- resourceModified rp r + Internal.resourceMetadata rp r + + +-------------------------------------------------------------------------------- +-- | Wrapper to ensure metadata cache is invalidated if necessary +resourceBody :: ResourceProvider -> Identifier a -> IO String +resourceBody rp r = do + _ <- resourceModified rp r + Internal.resourceBody rp r diff --git a/src/Hakyll/Core/ResourceProvider/Internal.hs b/src/Hakyll/Core/ResourceProvider/Internal.hs new file mode 100644 index 0000000..1f8f776 --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/Internal.hs @@ -0,0 +1,86 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.ResourceProvider.Internal + ( ResourceProvider (..) + , newResourceProvider + + , resourceList + , resourceExists + , resourceMetadataResource + + , resourceString + , resourceLBS + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy as BL +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import System.FilePath (addExtension) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Store +import Hakyll.Core.Util.File +import Hakyll.Core.Identifier + + +-------------------------------------------------------------------------------- +-- | Responsible for retrieving and listing resources +data ResourceProvider = ResourceProvider + { -- | A list of all files found + resourceSet :: Set (Identifier ()) + , -- | Cache keeping track of modified files + resourceModifiedCache :: IORef (Map (Identifier ()) Bool) + , -- | Underlying persistent store for caching + resourceStore :: Store + } + + +-------------------------------------------------------------------------------- +-- | Create a resource provider +newResourceProvider :: Store -- ^ Store to use + -> (FilePath -> Bool) -- ^ Should we ignore this file? + -> FilePath -- ^ Search directory + -> IO ResourceProvider -- ^ Resulting provider +newResourceProvider store ignore directory = do + list <- map parseIdentifier . filter (not . ignore) <$> + getRecursiveContents False directory + cache <- newIORef M.empty + return $ ResourceProvider (S.fromList list) cache store + + +-------------------------------------------------------------------------------- +resourceList :: ResourceProvider -> [Identifier ()] +resourceList = S.toList . resourceSet + + +-------------------------------------------------------------------------------- +-- | Check if a given resiyrce exists +resourceExists :: ResourceProvider -> Identifier a -> Bool +resourceExists provider = + (`S.member` resourceSet provider) . setGroup Nothing . castIdentifier + + +-------------------------------------------------------------------------------- +-- | Each resource may have an associated metadata resource (with a @.metadata@ +-- filename) +resourceMetadataResource :: Identifier a -> Identifier () +resourceMetadataResource = + parseIdentifier . flip addExtension "metadata" . toFilePath + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource as string +resourceString :: Identifier a -> IO String +resourceString = readFile . toFilePath + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource of a lazy bytestring +resourceLBS :: Identifier a -> IO BL.ByteString +resourceLBS = BL.readFile . toFilePath diff --git a/src/Hakyll/Core/ResourceProvider/Metadata.hs b/src/Hakyll/Core/ResourceProvider/Metadata.hs new file mode 100644 index 0000000..e297f2c --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/Metadata.hs @@ -0,0 +1,119 @@ +-------------------------------------------------------------------------------- +-- | Internal module to parse metadata +module Hakyll.Core.ResourceProvider.Metadata + ( loadMetadata + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*), (<*>)) +import Control.Arrow (second) +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map as M +import System.IO as IO +import Text.Parsec ((<?>)) +import qualified Text.Parsec as P +import Text.Parsec.String (Parser) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.ResourceProvider.Internal +import Hakyll.Core.Util.String + + +-------------------------------------------------------------------------------- +loadMetadata :: ResourceProvider -> Identifier a -> IO (Metadata, Maybe String) +loadMetadata rp identifier = do + hasHeader <- probablyHasMetadataHeader fp + (md, body) <- if hasHeader + then second Just <$> loadMetadataHeader fp + else return (M.empty, Nothing) + + emd <- if resourceExists rp mi then loadMetadataFile mfp else return M.empty + + return (M.union md emd, body) + where + fp = toFilePath identifier + mi = resourceMetadataResource identifier + mfp = toFilePath mi + + +-------------------------------------------------------------------------------- +loadMetadataHeader :: FilePath -> IO (Metadata, String) +loadMetadataHeader fp = do + contents <- readFile fp + case P.parse page fp contents of + Left err -> error (show err) + Right (md, b) -> return (M.fromList md, b) + + +-------------------------------------------------------------------------------- +loadMetadataFile :: FilePath -> IO Metadata +loadMetadataFile fp = do + contents <- readFile fp + case P.parse metadata fp contents of + Left err -> error (show err) + Right md -> return $ M.fromList md + + +-------------------------------------------------------------------------------- +-- | Check if a file "probably" has a metadata header. The main goal of this is +-- to exclude binary files (which are unlikely to start with "---"). +probablyHasMetadataHeader :: FilePath -> IO Bool +probablyHasMetadataHeader fp = do + handle <- IO.openFile fp IO.ReadMode + bs <- BC.hGet handle 1024 + IO.hClose handle + return $ isMetadataHeader bs + where + isMetadataHeader bs = + let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs + in BC.length pre >= 3 && BC.all (== '-') pre + + +-------------------------------------------------------------------------------- +-- | Space or tab, no newline +inlineSpace :: Parser Char +inlineSpace = P.oneOf ['\t', ' '] <?> "space" + + +-------------------------------------------------------------------------------- +-- | Parse a single metadata field +metadataField :: Parser (String, String) +metadataField = do + key <- P.manyTill P.alphaNum $ P.char ':' + P.skipMany1 inlineSpace <?> "space followed by metadata for: " ++ key + value <- P.manyTill P.anyChar P.newline + trailing' <- P.many trailing + return (key, trim $ value ++ concat trailing') + where + trailing = (++) <$> P.many1 inlineSpace <*> P.manyTill P.anyChar P.newline + + +-------------------------------------------------------------------------------- +-- | Parse a metadata block +metadata :: Parser [(String, String)] +metadata = P.many metadataField + + +-------------------------------------------------------------------------------- +-- | Parse a metadata block, including delimiters and trailing newlines +metadataBlock :: Parser [(String, String)] +metadataBlock = do + open <- P.many1 (P.char '-') <* P.many inlineSpace <* P.newline + metadata' <- metadata + _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.'] + P.skipMany inlineSpace + P.skipMany1 P.newline + return metadata' + + +-------------------------------------------------------------------------------- +-- | Parse a page consisting of a metadata header and a body +page :: Parser ([(String, String)], String) +page = do + metadata' <- P.option [] metadataBlock + body <- P.many P.anyChar + return (metadata', body) diff --git a/src/Hakyll/Core/ResourceProvider/MetadataCache.hs b/src/Hakyll/Core/ResourceProvider/MetadataCache.hs new file mode 100644 index 0000000..85062a0 --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/MetadataCache.hs @@ -0,0 +1,62 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.ResourceProvider.MetadataCache + ( resourceMetadata + , resourceBody + , resourceInvalidateMetadataCache + ) where + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.ResourceProvider.Internal +import Hakyll.Core.ResourceProvider.Metadata +import qualified Hakyll.Core.Store as Store + + +-------------------------------------------------------------------------------- +resourceMetadata :: ResourceProvider -> Identifier a -> IO Metadata +resourceMetadata rp r = do + load rp r + Store.Found md <- Store.get (resourceStore rp) + [name, toFilePath r, "metadata"] + return md + + +-------------------------------------------------------------------------------- +resourceBody :: ResourceProvider -> Identifier a -> IO String +resourceBody rp r = do + load rp r + Store.Found bd <- Store.get (resourceStore rp) + [name, toFilePath r, "body"] + maybe (resourceString r) return bd + + +-------------------------------------------------------------------------------- +resourceInvalidateMetadataCache :: ResourceProvider -> Identifier a -> IO () +resourceInvalidateMetadataCache rp r = do + Store.delete (resourceStore rp) [name, toFilePath r, "metadata"] + Store.delete (resourceStore rp) [name, toFilePath r, "body"] + + +-------------------------------------------------------------------------------- +load :: ResourceProvider -> Identifier a -> IO () +load rp r = do + mmd <- Store.get store mdk :: IO (Store.Result Metadata) + case mmd of + -- Already loaded + Store.Found _ -> return () + -- Not yet loaded + _ -> do + (metadata, body) <- loadMetadata rp r + Store.set store mdk metadata + Store.set store bk body + where + store = resourceStore rp + mdk = [name, toFilePath r, "metadata"] + bk = [name, toFilePath r, "body"] + + +-------------------------------------------------------------------------------- +name :: String +name = "Hakyll.Core.Resource.Provider.MetadataCache" diff --git a/src/Hakyll/Core/ResourceProvider/Modified.hs b/src/Hakyll/Core/ResourceProvider/Modified.hs new file mode 100644 index 0000000..837bc8c --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/Modified.hs @@ -0,0 +1,83 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.ResourceProvider.Modified + ( resourceModified + , resourceModificationTime + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (when) +import qualified Crypto.Hash.MD5 as MD5 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.IORef +import qualified Data.Map as M +import Data.Time (UTCTime) +import System.Directory (getModificationTime) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.ResourceProvider.Internal +import Hakyll.Core.ResourceProvider.MetadataCache +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store + + +-------------------------------------------------------------------------------- +-- | A resource is modified if it or its metadata has changed +resourceModified :: ResourceProvider -> Identifier a -> IO Bool +resourceModified rp r + | not exists = return False + | otherwise = do + cache <- readIORef cacheRef + case M.lookup normalized cache of + Just m -> return m + Nothing -> do + -- Check if the actual file was modified, and do a recursive + -- call to check if the metadata file was modified + m <- (||) + <$> fileDigestModified store (toFilePath r) + <*> resourceModified rp (resourceMetadataResource r) + modifyIORef cacheRef (M.insert normalized m) + + -- Important! (But ugly) + when m $ resourceInvalidateMetadataCache rp r + + return m + where + normalized = castIdentifier $ setGroup Nothing r + exists = resourceExists rp r + store = resourceStore rp + cacheRef = resourceModifiedCache rp + + +-------------------------------------------------------------------------------- +-- | Utility: Check if a the digest of a file was modified +fileDigestModified :: Store -> FilePath -> IO Bool +fileDigestModified store fp = do + -- Get the latest seen digest from the store, and calculate the current + -- digest for the + lastDigest <- Store.get store key + newDigest <- fileDigest fp + if Store.Found newDigest == lastDigest + -- All is fine, not modified + then return False + -- Resource modified; store new digest + else do + Store.set store key newDigest + return True + where + key = ["Hakyll.Core.Resource.Provider.fileModified", fp] + + +-------------------------------------------------------------------------------- +-- | Utility: Retrieve a digest for a given file +fileDigest :: FilePath -> IO B.ByteString +fileDigest = fmap MD5.hashlazy . BL.readFile + + +-------------------------------------------------------------------------------- +resourceModificationTime :: Identifier a -> IO UTCTime +resourceModificationTime = getModificationTime . toFilePath diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index bef480a..5ac63bc 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -1,3 +1,4 @@ +-------------------------------------------------------------------------------- -- | This module provides a declarative DSL in which the user can specify the -- different rules used to run the compilers. -- @@ -13,8 +14,8 @@ -- > match "css/*" $ do -- > route idRoute -- > compile compressCssCompiler --- -{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Rules ( RulesM , Rules @@ -29,35 +30,41 @@ module Hakyll.Core.Rules , freshIdentifier ) where -import Control.Applicative ((<$>)) -import Control.Monad.Writer (tell) -import Control.Monad.Reader (ask, local) -import Control.Arrow ((>>>), arr, (>>^), (***)) -import Control.Monad.State (get, put) -import Data.Monoid (mempty, mappend) -import qualified Data.Set as S - -import Data.Typeable (Typeable) -import Data.Binary (Binary) - -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 -import Hakyll.Core.Writable -import Hakyll.Core.Rules.Internal -import Hakyll.Core.Util.Arrow +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Arrow (arr, (***), (>>>), (>>^)) +import Control.Monad.Reader (ask, local) +import Control.Monad.State (get, put) +import Control.Monad.Writer (tell) +import Data.Monoid (mappend, mempty) +import qualified Data.Set as S + + +-------------------------------------------------------------------------------- +import Data.Binary (Binary) +import Data.Typeable (Typeable) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.CompiledItem +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Routes +import Hakyll.Core.Rules.Internal +import Hakyll.Core.Writable + + +-------------------------------------------------------------------------------- -- | Add a route --- tellRoute :: Routes -> Rules tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty + +-------------------------------------------------------------------------------- -- | Add a number of compilers --- tellCompilers :: (Binary a, Typeable a, Writable a) => [(Identifier a, Compiler () a)] -> Rules @@ -68,15 +75,17 @@ tellCompilers compilers = RulesM $ do where boxCompiler = (>>> arr compiledItem >>> arr CompileRule) + +-------------------------------------------------------------------------------- -- | Add resources --- -tellResources :: [Resource] +tellResources :: [Identifier a] -> Rules tellResources resources' = RulesM $ tell $ - RuleSet mempty mempty $ S.fromList resources' + RuleSet mempty mempty $ S.fromList $ map castIdentifier resources' + +-------------------------------------------------------------------------------- -- | Only compile/route items satisfying the given predicate --- match :: Pattern a -> RulesM b -> RulesM b match pattern = RulesM . local addPredicate . unRulesM where @@ -84,8 +93,9 @@ match pattern = RulesM . local addPredicate . unRulesM { rulesPattern = rulesPattern env `mappend` castPattern pattern } + +-------------------------------------------------------------------------------- -- | Greate a group of compilers --- -- Imagine you have a page that you want to render, but you also want the raw -- content available on your site. -- @@ -114,27 +124,28 @@ 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 where setGroup' env = env { rulesGroup = Just g } + +-------------------------------------------------------------------------------- -- | Add a compilation rule to the rules. -- -- 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) - => Compiler Resource a -> RulesM (Pattern a) + => Compiler () a -> RulesM (Pattern a) compile compiler = do ids <- resources - tellCompilers $ flip map ids $ \identifier -> - (identifier, constA (fromIdentifier identifier) >>> compiler) - tellResources $ map fromIdentifier ids - return $ list ids - + tellCompilers [(castIdentifier id', compiler) | id' <- ids] + tellResources ids + return $ list $ map castIdentifier ids + + +-------------------------------------------------------------------------------- -- | Add a compilation rule -- -- This sets a compiler for the given identifier. No resource is needed, since @@ -143,7 +154,6 @@ compile compiler = do -- actual content itself. Note that the group of the given identifier is -- 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) create id' compiler = RulesM $ do @@ -152,10 +162,11 @@ create id' compiler = RulesM $ do unRulesM $ tellCompilers [(id'', compiler)] return id'' + +-------------------------------------------------------------------------------- -- | Add a route. -- -- This adds a route for all items matching the current pattern. --- route :: Routes -> Rules route route' = RulesM $ do -- We want the route only to be applied if we match the current pattern and @@ -164,18 +175,19 @@ route route' = RulesM $ do group' <- rulesGroup <$> ask unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route' + +-------------------------------------------------------------------------------- -- | Get a list of resources matching the current pattern. This will also set -- the correct group to the identifiers. --- -resources :: RulesM [Identifier a] +resources :: RulesM [Identifier ()] resources = RulesM $ do - pattern <- rulesPattern <$> ask + pattern <- rulesPattern <$> ask provider <- rulesResourceProvider <$> ask - group' <- rulesGroup <$> ask - return $ filterMatches pattern $ map (toId group') $ resourceList provider - where - toId g = setGroup g . toIdentifier + g <- rulesGroup <$> ask + return $ filterMatches pattern $ map (setGroup g) $ resourceList provider + +-------------------------------------------------------------------------------- -- | Apart from regular compilers, one is also able to specify metacompilers. -- Metacompilers are a special class of compilers: they are compilers which -- produce other compilers. @@ -205,9 +217,8 @@ resources = RulesM $ do -- For simple hakyll systems, it is no need for this construction. More -- formally, it is only needed when the content of one or more items determines -- which items must be rendered. --- metaCompile :: (Binary a, Typeable a, Writable a) - => Compiler () [(Identifier a, Compiler () a)] + => Compiler () [(Identifier a, Compiler () a)] -- ^ Compiler generating the other compilers -> Rules -- ^ Resulting rules @@ -215,13 +226,14 @@ metaCompile compiler = do id' <- freshIdentifier "Hakyll.Core.Rules.metaCompile" metaCompileWith id' compiler + +-------------------------------------------------------------------------------- -- | Version of 'metaCompile' that allows you to specify a custom identifier for -- the metacompiler. --- metaCompileWith :: (Binary a, Typeable a, Writable a) => Identifier () -- ^ Identifier for this compiler - -> Compiler () [(Identifier a, Compiler () a)] + -> Compiler () [(Identifier a, Compiler () a)] -- ^ Compiler generating the other compilers -> Rules -- ^ Resulting rules @@ -239,6 +251,8 @@ metaCompileWith identifier compiler = RulesM $ do tell $ RuleSet mempty compilers mempty + +-------------------------------------------------------------------------------- -- | Generate a fresh Identifier with a given prefix freshIdentifier :: String -- ^ Prefix -> RulesM (Identifier a) -- ^ Fresh identifier diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 55c4446..245d935 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -1,6 +1,7 @@ +-------------------------------------------------------------------------------- -- | Internal rules module for types which are not exposed to the user --- -{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} module Hakyll.Core.Rules.Internal ( CompileRule (..) , RuleSet (..) @@ -11,88 +12,101 @@ module Hakyll.Core.Rules.Internal , runRules ) where -import Control.Applicative (Applicative) -import Control.Monad.Writer (WriterT, execWriterT) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State (State, evalState) -import Data.Monoid (Monoid, mempty, mappend) -import Data.Set (Set) -import qualified Data.Map as M - -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 +-------------------------------------------------------------------------------- +import Control.Applicative (Applicative) +import Control.Monad.RWS (RWST, runRWST) +import qualified Data.Map as M +import Data.Monoid (Monoid, mappend, mempty) +import Data.Set (Set) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.CompiledItem +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Routes + + +-------------------------------------------------------------------------------- -- | Output of a compiler rule -- -- * The compiler will produce a simple item. This is the most common case. -- -- * The compiler will produce more compilers. These new compilers need to be -- added to the runtime if possible, since other items might depend upon them. --- data CompileRule = CompileRule CompiledItem | MetaCompileRule [(Identifier (), Compiler () CompileRule)] + +-------------------------------------------------------------------------------- -- | A collection of rules for the compilation process --- data RuleSet = RuleSet { -- | Routes used in the compilation structure rulesRoutes :: Routes , -- | Compilation rules rulesCompilers :: [(Identifier (), Compiler () CompileRule)] - , -- | A list of the used resources - rulesResources :: Set Resource + , -- | A set of the actually used files + rulesResources :: Set (Identifier ()) } + +-------------------------------------------------------------------------------- instance Monoid RuleSet where mempty = RuleSet mempty mempty mempty mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) = RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) + +-------------------------------------------------------------------------------- -- | Rule state --- data RuleState = RuleState { rulesNextIdentifier :: Int } deriving (Show) + +-------------------------------------------------------------------------------- -- | Rule environment --- data RuleEnvironment = RuleEnvironment { rulesResourceProvider :: ResourceProvider , rulesPattern :: forall a. Pattern a , rulesGroup :: Maybe String } + +-------------------------------------------------------------------------------- -- | The monad used to compose rules --- newtype RulesM a = RulesM - { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a + { unRulesM :: RWST RuleEnvironment RuleSet RuleState IO a } deriving (Monad, Functor, Applicative) + +-------------------------------------------------------------------------------- -- | Simplification of the RulesM type; usually, it will not return any -- result. --- type Rules = RulesM () + +-------------------------------------------------------------------------------- -- | Run a Rules monad, resulting in a 'RuleSet' --- -runRules :: RulesM a -> ResourceProvider -> RuleSet -runRules rules provider = nubCompilers $ - evalState (execWriterT $ runReaderT (unRulesM rules) env) state +runRules :: RulesM a -> ResourceProvider -> IO RuleSet +runRules rules provider = do + (_, _, ruleSet) <- runRWST (unRulesM rules) env state + return $ nubCompilers ruleSet where state = RuleState {rulesNextIdentifier = 0} - env = RuleEnvironment { rulesResourceProvider = provider - , rulesPattern = mempty - , rulesGroup = Nothing - } + env = RuleEnvironment + { rulesResourceProvider = provider + , rulesPattern = mempty + , rulesGroup = Nothing + } + +-------------------------------------------------------------------------------- -- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an -- item, we prefer the first one --- nubCompilers :: RuleSet -> RuleSet nubCompilers set = set { rulesCompilers = nubCompilers' (rulesCompilers set) } where diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 0bc3625..ff7acac 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -25,9 +25,7 @@ import Hakyll.Core.DependencyAnalyzer import Hakyll.Core.DirectedGraph import Hakyll.Core.Identifier import Hakyll.Core.Logger -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider -import Hakyll.Core.Resource.Provider.File +import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal import Hakyll.Core.Store (Store) @@ -44,8 +42,8 @@ run configuration rules = do section logger "Initialising" store <- timed logger "Creating store" $ Store.new (inMemoryCache configuration) $ storeDirectory configuration - provider <- timed logger "Creating provider" $ - fileResourceProvider configuration + provider <- timed logger "Creating provider" $ newResourceProvider + store (ignoreFile configuration) "." -- Fetch the old graph from the store. If we don't find it, we consider this -- to be the first run @@ -53,8 +51,8 @@ run configuration rules = do let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g) _ -> (True, mempty) - let ruleSet = runRules rules provider - compilers = rulesCompilers ruleSet + ruleSet <- timed logger "Running rules" $ runRules rules provider + let compilers = rulesCompilers ruleSet -- Extract the reader/state reader = unRuntime $ addNewCompilers compilers @@ -114,7 +112,6 @@ addNewCompilers newCompilers = Runtime $ do logger <- hakyllLogger <$> ask section logger "Adding new compilers" provider <- hakyllResourceProvider <$> ask - store <- hakyllStore <$> ask firstRun <- hakyllFirstRun <$> ask -- Old state information @@ -134,7 +131,7 @@ addNewCompilers newCompilers = Runtime $ do -- Check which items have been modified modified <- fmap S.fromList $ flip filterM (map fst newCompilers) $ - liftIO . resourceModified provider store . fromIdentifier + liftIO . resourceModified provider let checkModified = if firstRun then const True else (`S.member` modified) -- Create a new analyzer and append it to the currect one @@ -185,7 +182,7 @@ build id' = Runtime $ do let compiler = compilers M.! id' -- Check if the resource was modified - isModified <- liftIO $ resourceModified provider store $ fromIdentifier id' + isModified <- liftIO $ resourceModified provider id' -- Run the compiler result <- timed logger "Total compile time" $ liftIO $ diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index f46d083..96a5e09 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -1,25 +1,40 @@ +-------------------------------------------------------------------------------- -- | Various arrow utility functions --- module Hakyll.Core.Util.Arrow - ( constA + ( ArrowMap (..) + , constA , sequenceA , unitA ) where -import Control.Arrow (Arrow, (&&&), arr, (>>^)) -constA :: Arrow a - => c - -> a b c +-------------------------------------------------------------------------------- +import Control.Arrow (Arrow, ArrowChoice, arr, (&&&), (>>^)) + + +-------------------------------------------------------------------------------- +-- | Additional arrow typeclass for performance reasons. +class ArrowChoice a => ArrowMap a where + mapA :: a b c -> a [b] [c] + + +-------------------------------------------------------------------------------- +instance ArrowMap (->) where + mapA = map + + +-------------------------------------------------------------------------------- +constA :: Arrow a => c -> a b c constA = arr . const -sequenceA :: Arrow a - => [a b c] - -> a b [c] + +-------------------------------------------------------------------------------- +sequenceA :: Arrow a => [a b c] -> a b [c] sequenceA = foldr reduce $ constA [] where reduce xa la = xa &&& la >>^ arr (uncurry (:)) -unitA :: Arrow a - => a b () + +-------------------------------------------------------------------------------- +unitA :: Arrow a => a b () unitA = constA () diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 06a4f78..160ee6f 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -24,9 +24,7 @@ import Hakyll.Core.Configuration makeDirectories :: FilePath -> IO () makeDirectories = createDirectoryIfMissing True . takeDirectory --- | Get all contents of a directory. Note that files starting with a dot (.) --- will be ignored. --- +-- | Get all contents of a directory. getRecursiveContents :: Bool -- ^ Include directories? -> FilePath -- ^ Directory to search -> IO [FilePath] -- ^ List of files found diff --git a/src/Hakyll/Core/Writable/CopyFile.hs b/src/Hakyll/Core/Writable/CopyFile.hs index ab9c698..6cc08f2 100644 --- a/src/Hakyll/Core/Writable/CopyFile.hs +++ b/src/Hakyll/Core/Writable/CopyFile.hs @@ -1,29 +1,36 @@ +-------------------------------------------------------------------------------- -- | Exports simple compilers to just copy files --- {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Hakyll.Core.Writable.CopyFile ( CopyFile (..) , copyFileCompiler ) where + +-------------------------------------------------------------------------------- import Control.Arrow ((>>^)) import System.Directory (copyFile) - import Data.Typeable (Typeable) import Data.Binary (Binary) -import Hakyll.Core.Resource + +-------------------------------------------------------------------------------- import Hakyll.Core.Writable import Hakyll.Core.Compiler import Hakyll.Core.Identifier + +-------------------------------------------------------------------------------- -- | Newtype construct around 'FilePath' which will copy the file directly --- newtype CopyFile = CopyFile {unCopyFile :: FilePath} - deriving (Show, Eq, Ord, Binary, Typeable) + deriving (Show, Eq, Ord, Binary, Typeable) + +-------------------------------------------------------------------------------- instance Writable CopyFile where write dst (CopyFile src) = copyFile src dst -copyFileCompiler :: Compiler Resource CopyFile + +-------------------------------------------------------------------------------- +copyFileCompiler :: Compiler a CopyFile copyFileCompiler = getIdentifier >>^ CopyFile . toFilePath diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index d97dc31..6c9103f 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -12,6 +12,7 @@ import System.Environment (getProgName, getArgs) import System.Process (system) import Hakyll.Core.Configuration +import Hakyll.Core.Identifier import Hakyll.Core.Run import Hakyll.Core.Rules @@ -20,7 +21,6 @@ import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import qualified Data.Set as S -import Hakyll.Core.Resource import Hakyll.Core.Rules.Internal import Hakyll.Web.Preview.Poll import Hakyll.Web.Preview.Server @@ -106,7 +106,7 @@ preview conf rules port = do -- Run the server in the main thread server conf port where - update = map unResource . S.toList . rulesResources <$> run conf rules + update = map toFilePath . S.toList . rulesResources <$> run conf rules #else preview _ _ _ = previewServerDisabled #endif diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index 52b5396..d0ca8cd 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -11,12 +11,11 @@ import Data.List (isPrefixOf) import Control.Arrow ((>>^)) import Hakyll.Core.Compiler -import Hakyll.Core.Resource import Hakyll.Core.Util.String -- | Compiler form of 'compressCss' -- -compressCssCompiler :: Compiler Resource String +compressCssCompiler :: Compiler a String compressCssCompiler = getResourceString >>^ compressCss -- | Compress CSS to speed up your site. diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index f2f3342..218f28c 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -62,7 +62,7 @@ createFeed :: Template -- ^ Feed template -> [Page String] -- ^ Items to include -> String -- ^ Resulting feed createFeed feedTemplate itemTemplate url configuration items = - pageBody $ applyTemplate feedTemplate + pageBody $ applyTemplateToPage feedTemplate $ trySetField "updated" updated $ trySetField "title" (feedTitle configuration) $ trySetField "description" (feedDescription configuration) @@ -73,7 +73,7 @@ createFeed feedTemplate itemTemplate url configuration items = $ fromBody body where -- Preprocess items - items' = flip map items $ applyTemplate itemTemplate + items' = flip map items $ applyTemplateToPage itemTemplate . trySetField "root" (feedRoot configuration) -- Body: concatenated items diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index e92bb14..7f2430f 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -72,7 +72,6 @@ import Text.Pandoc (Pandoc, ParserState, WriterOptions) import Hakyll.Core.Identifier import Hakyll.Core.Compiler -import Hakyll.Core.Resource import Hakyll.Web.Page.Internal import Hakyll.Web.Page.Read import Hakyll.Web.Page.Metadata @@ -87,12 +86,12 @@ fromBody = Page M.empty -- | Read a page (do not render it) -- -readPageCompiler :: Compiler Resource (Page String) +readPageCompiler :: Compiler () (Page String) readPageCompiler = getResourceString >>^ readPage -- | Read a page, add default fields, substitute fields and render using pandoc -- -pageCompiler :: Compiler Resource (Page String) +pageCompiler :: Compiler () (Page String) pageCompiler = pageCompilerWith defaultHakyllParserState defaultHakyllWriterOptions @@ -100,7 +99,7 @@ pageCompiler = -- options -- pageCompilerWith :: ParserState -> WriterOptions - -> Compiler Resource (Page String) + -> Compiler () (Page String) pageCompilerWith state options = pageCompilerWithPandoc state options id -- | An extension of 'pageCompilerWith' which allows you to specify a custom @@ -108,7 +107,7 @@ pageCompilerWith state options = pageCompilerWithPandoc state options id -- pageCompilerWithPandoc :: ParserState -> WriterOptions -> (Pandoc -> Pandoc) - -> Compiler Resource (Page String) + -> Compiler () (Page String) pageCompilerWithPandoc state options f = cached cacheName $ readPageCompiler >>> addDefaultFields >>> arr applySelf >>> pageReadPandocWith state @@ -124,7 +123,7 @@ pageCompilerWithPandoc state options f = cached cacheName $ pageCompilerWithFields :: ParserState -> WriterOptions -> (Pandoc -> Pandoc) -> Compiler (Page String) (Page String) - -> Compiler Resource (Page String) + -> Compiler () (Page String) pageCompilerWithFields state options f g = readPageCompiler >>> addDefaultFields >>> g >>> arr applySelf >>> pageReadPandocWith state diff --git a/src/Hakyll/Web/Page/List.hs b/src/Hakyll/Web/Page/List.hs index 1edb250..24721e7 100644 --- a/src/Hakyll/Web/Page/List.hs +++ b/src/Hakyll/Web/Page/List.hs @@ -55,8 +55,8 @@ pageListCompiler sort template = -- applyTemplateToList :: Identifier Template -> Compiler [Page String] [Page String] -applyTemplateToList identifier = - require identifier $ \posts template -> map (applyTemplate template) posts +applyTemplateToList identifier = require identifier $ + \posts template -> map (applyTemplateToPage template) posts -- | Concatenate the bodies of a page list -- diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs index 4528d78..8605aea 100644 --- a/src/Hakyll/Web/Page/Metadata.hs +++ b/src/Hakyll/Web/Page/Metadata.hs @@ -38,7 +38,7 @@ import Hakyll.Web.Page.Internal import Hakyll.Core.Util.String import Hakyll.Core.Identifier import Hakyll.Core.Compiler -import Hakyll.Core.Resource.Provider +import Hakyll.Core.ResourceProvider -- | Get a metadata field. If the field does not exist, the empty string is -- returned. @@ -209,7 +209,7 @@ renderModificationTimeWith :: TimeLocale -> Compiler (Page String) (Page String) -- ^ Resulting compiler renderModificationTimeWith locale key format = - id &&& (getResource >>> getResourceWith resourceModificationTime) >>> + id &&& (getResourceWith resourceModificationTime) >>> setFieldA key (arr (formatTime locale format)) -- | Copy the body of a page to a metadata field diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs index 48f7982..64a702b 100644 --- a/src/Hakyll/Web/Pandoc/Biblio.hs +++ b/src/Hakyll/Web/Pandoc/Biblio.hs @@ -17,7 +17,7 @@ module Hakyll.Web.Pandoc.Biblio ) where import Control.Applicative ((<$>)) -import Control.Arrow (arr, returnA) +import Control.Arrow (arr, returnA, (>>>)) import Data.Typeable (Typeable) import Data.Binary (Binary (..)) @@ -27,7 +27,6 @@ import qualified Text.CSL as CSL import Hakyll.Core.Compiler import Hakyll.Core.Identifier -import Hakyll.Core.Resource import Hakyll.Core.Writable import Hakyll.Web.Page import Hakyll.Web.Pandoc @@ -35,8 +34,8 @@ import Hakyll.Web.Pandoc newtype CSL = CSL FilePath deriving (Binary, Show, Typeable, Writable) -cslCompiler :: Compiler Resource CSL -cslCompiler = arr (CSL . unResource) +cslCompiler :: Compiler () CSL +cslCompiler = getIdentifier >>> arr (CSL . toFilePath) newtype Biblio = Biblio [CSL.Reference] deriving (Show, Typeable) @@ -49,9 +48,9 @@ instance Binary Biblio where instance Writable Biblio where write _ _ = return () -biblioCompiler :: Compiler Resource Biblio -biblioCompiler = unsafeCompiler $ - fmap Biblio . CSL.readBiblioFile . unResource +biblioCompiler :: Compiler () Biblio +biblioCompiler = getIdentifier >>> + arr toFilePath >>> unsafeCompiler CSL.readBiblioFile >>> arr Biblio pageReadPandocBiblio :: ParserState -> Identifier CSL diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 42612a7..4ea2ca0 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -65,6 +65,7 @@ import Hakyll.Web.Urls import Hakyll.Core.Writable import Hakyll.Core.Identifier import Hakyll.Core.Compiler +import Hakyll.Core.Util.Arrow import Hakyll.Core.Util.String -- | Data about tags @@ -128,8 +129,7 @@ renderTags :: (String -> Identifier (Page a)) -- ^ 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) - -< tags + tags' <- mapA ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) -< tags let -- Absolute frequencies of the pages freqs = map snd tags' @@ -195,7 +195,7 @@ renderTagsFieldWith tags destination makeUrl = -- Compiler creating a comma-separated HTML string for a list of tags renderTags' :: Compiler [String] String renderTags' = arr (map $ id &&& makeUrl) - >>> mapCompiler (id *** getRouteFor) + >>> mapA (id *** getRouteFor) >>> arr (map $ uncurry renderLink) >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes) diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index b33d1f3..5b7256a 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -58,73 +58,84 @@ -- > <a href="/about.html"> About -- > <a href="/code.html"> Code -- > #{body} --- +{-# LANGUAGE Arrows #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template ( Template , applyTemplate - , applyTemplateWith + , applyTemplateToPage , applySelf , templateCompiler , templateCompilerWith , applyTemplateCompiler - , applyTemplateCompilerWith ) where -import Control.Arrow -import Data.Maybe (fromMaybe) -import System.FilePath (takeExtension) -import qualified Data.Map as M -import Text.Hamlet (HamletSettings, defaultHamletSettings) +-------------------------------------------------------------------------------- +import Control.Arrow +import Control.Category (id) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Prelude hiding (id) +import System.FilePath (takeExtension) +import Text.Hamlet (HamletSettings, + defaultHamletSettings) -import Hakyll.Core.Compiler -import Hakyll.Core.Identifier -import Hakyll.Core.Resource -import Hakyll.Web.Template.Internal -import Hakyll.Web.Template.Read -import Hakyll.Web.Page.Internal +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler +import Hakyll.Core.Identifier +import Hakyll.Core.Util.Arrow +import Hakyll.Web.Page.Internal +import Hakyll.Web.Template.Internal +import Hakyll.Web.Template.Read --- | Substitutes @$identifiers@ in the given @Template@ by values from the given --- "Page". When a key is not found, it is left as it is. --- -applyTemplate :: Template -> Page String -> Page String -applyTemplate = applyTemplateWith defaultMissingHandler --- | Default solution if a key is missing: render it again -defaultMissingHandler :: String -> String -defaultMissingHandler k = "$" ++ k ++ "$" +-------------------------------------------------------------------------------- +applyTemplate :: forall a b. (ArrowChoice a, ArrowMap a) + => a (String, b) String + -> a (Template, b) String +applyTemplate field = + arr (\(tpl, x) -> [(e, x) | e <- unTemplate tpl]) >>> + mapA applyElement >>^ concat + where + applyElement :: a (TemplateElement, b) String + applyElement = unElement >>> (id ||| field) --- | A version of 'applyTemplate' which allows you to give a fallback option, --- which can produce the value for a key if it is missing. --- -applyTemplateWith :: (String -> String) -- ^ Fallback if key missing - -> Template -- ^ Template to apply - -> Page String -- ^ Input page - -> Page String -- ^ Resulting page -applyTemplateWith missing template page = - fmap (const $ substitute =<< unTemplate template) page + unElement :: a (TemplateElement, b) (Either String (String, b)) + unElement = arr $ \(e, x) -> case e of + Chunk c -> Left c + Escaped -> Left "$" + Key k -> Right (k, x) + + +-------------------------------------------------------------------------------- +-- | TODO: Remove +applyTemplateToPage :: Template -> Page String -> Page String +applyTemplateToPage tpl page = + fmap (const $ applyTemplate pageField (tpl, page)) page where - map' = toMap page - substitute (Chunk chunk) = chunk - substitute (Key key) = fromMaybe (missing key) $ M.lookup key map' - substitute (Escaped) = "$" + pageField (k, p) = fromMaybe ("$" ++ k ++ "$") $ M.lookup k $ toMap p +{-# DEPRECATED applyTemplateToPage "Use applyTemplate" #-} + +-------------------------------------------------------------------------------- -- | Apply a page as it's own template. This is often very useful to fill in -- certain keys like @$root@ and @$url@. --- applySelf :: Page String -> Page String -applySelf page = applyTemplate (readTemplate $ pageBody page) page +applySelf page = applyTemplateToPage (readTemplate $ pageBody page) page +{-# DEPRECATED applySelf "Use applyTemplate" #-} + +-------------------------------------------------------------------------------- -- | Read a template. If the extension of the file we're compiling is -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed -- as such. --- -templateCompiler :: Compiler Resource Template +templateCompiler :: Compiler () Template templateCompiler = templateCompilerWith defaultHamletSettings -- | Version of 'templateCompiler' that enables custom settings. -- -templateCompilerWith :: HamletSettings -> Compiler Resource Template +templateCompilerWith :: HamletSettings -> Compiler () Template templateCompilerWith settings = cached "Hakyll.Web.Template.templateCompilerWith" $ getIdentifier &&& getResourceString >>^ uncurry read' @@ -136,15 +147,9 @@ templateCompilerWith settings = -- Hakyll template else readTemplate string + +-------------------------------------------------------------------------------- applyTemplateCompiler :: Identifier Template -- ^ Template -> Compiler (Page String) (Page String) -- ^ Compiler -applyTemplateCompiler = applyTemplateCompilerWith defaultMissingHandler - --- | A version of 'applyTemplateCompiler' which allows you to pass a function --- which is called for a key when it is missing. --- -applyTemplateCompilerWith :: (String -> String) - -> Identifier Template - -> Compiler (Page String) (Page String) -applyTemplateCompilerWith missing identifier = - require identifier (flip $ applyTemplateWith missing) +applyTemplateCompiler identifier = require identifier $ + flip applyTemplateToPage diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs new file mode 100644 index 0000000..5ca1556 --- /dev/null +++ b/src/Hakyll/Web/Template/Context.hs @@ -0,0 +1,24 @@ +-------------------------------------------------------------------------------- +module Hakyll.Web.Template.Context + ( Context + , field + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative (empty) +import Control.Arrow +import Hakyll.Core.Compiler + + +-------------------------------------------------------------------------------- +type Context a = Compiler (String, a) String + + +-------------------------------------------------------------------------------- +field :: String -> Compiler a String -> Context a +field key value = arr checkKey >>> empty ||| value + where + checkKey (k, x) + | k == key = Left () + | otherwise = Right x |