From 0da0dd469de6f3c7439099900676deb8a667bbe6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 13 Dec 2010 20:41:26 +0100 Subject: Experimental changes for a re-write --- src/Text/Hakyll/File.hs | 2 +- src/Text/Hakyll/HakyllAction.hs | 98 ---------------------------------- src/Text/Hakyll/HakyllMonad.hs | 99 ---------------------------------- src/Text/Hakyll/Monad.hs | 115 ++++++++++++++++++++++++++++++++++++++++ src/Text/Hakyll/Pandoc.hs | 31 +++++++++++ src/Text/Hakyll/Resource.hs | 60 +++++++++++++++++++++ src/Text/Hakyll/Transformer.hs | 97 +++++++++++++++++++++++++++++++++ 7 files changed, 304 insertions(+), 198 deletions(-) delete mode 100644 src/Text/Hakyll/HakyllAction.hs delete mode 100644 src/Text/Hakyll/HakyllMonad.hs create mode 100644 src/Text/Hakyll/Monad.hs create mode 100644 src/Text/Hakyll/Resource.hs create mode 100644 src/Text/Hakyll/Transformer.hs (limited to 'src') diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs index 167ece7..747608c 100644 --- a/src/Text/Hakyll/File.hs +++ b/src/Text/Hakyll/File.hs @@ -26,7 +26,7 @@ import Data.List (isPrefixOf, sortBy) import Data.Ord (comparing) import Control.Monad.Reader (liftIO) -import Text.Hakyll.HakyllMonad +import Text.Hakyll.Monad import Text.Hakyll.Internal.FileType (isRenderableFile) -- | Auxiliary function to remove pathSeparators form the start. We don't deal diff --git a/src/Text/Hakyll/HakyllAction.hs b/src/Text/Hakyll/HakyllAction.hs deleted file mode 100644 index 491f1f1..0000000 --- a/src/Text/Hakyll/HakyllAction.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | This is the module which exports @HakyllAction@. -module Text.Hakyll.HakyllAction - ( HakyllAction (..) - , createHakyllAction - , createSimpleHakyllAction - , createFileHakyllAction - , chain - , runHakyllAction - , runHakyllActionIfNeeded - ) where - -import Control.Arrow -import Control.Category -import Control.Monad ((<=<), unless) -import Prelude hiding ((.), id) - -import Text.Hakyll.File (toDestination, isFileMoreRecent) -import Text.Hakyll.HakyllMonad - --- | Type used for rendering computations that carry along dependencies. -data HakyllAction a b = HakyllAction - { -- | Dependencies of the @HakyllAction@. - actionDependencies :: [FilePath] - , -- | URL pointing to the result of this @HakyllAction@. - actionUrl :: Either (Hakyll FilePath) - (Hakyll FilePath -> Hakyll FilePath) - , -- | The actual render function. - actionFunction :: a -> Hakyll b - } - --- | Create a @HakyllAction@ from a function. -createHakyllAction :: (a -> Hakyll b) -- ^ Function to execute. - -> HakyllAction a b -createHakyllAction f = id { actionFunction = f } - --- | Create a @HakyllAction@ from a simple @Hakyll@ value. -createSimpleHakyllAction :: Hakyll b -- ^ Hakyll value to pass on. - -> HakyllAction () b -createSimpleHakyllAction = createHakyllAction . const - --- | Create a @HakyllAction@ that operates on one file. -createFileHakyllAction :: FilePath -- ^ File to operate on. - -> Hakyll b -- ^ Value to pass on. - -> HakyllAction () b -- ^ The resulting action. -createFileHakyllAction path action = HakyllAction - { actionDependencies = [path] - , actionUrl = Left $ return path - , actionFunction = const action - } - --- | Run a @HakyllAction@ now. -runHakyllAction :: HakyllAction () a -- ^ Render action to run. - -> Hakyll a -- ^ Result of the action. -runHakyllAction action = actionFunction action () - --- | Run a @HakyllAction@, but only when it is out-of-date. At this point, the --- @actionUrl@ field must be set. -runHakyllActionIfNeeded :: HakyllAction () () -- ^ Action to run. - -> Hakyll () -- ^ Empty result. -runHakyllActionIfNeeded action = do - url <- case actionUrl action of - Left u -> u - Right _ -> error "No url when checking dependencies." - destination <- toDestination url - valid <- isFileMoreRecent destination $ actionDependencies action - unless valid $ do logHakyll $ "Rendering " ++ destination - runHakyllAction action - --- | Chain a number of @HakyllAction@ computations. -chain :: [HakyllAction a a] -- ^ Actions to chain. - -> HakyllAction a a -- ^ Resulting action. -chain [] = id -chain list = foldl1 (>>>) list - -instance Category HakyllAction where - id = HakyllAction - { actionDependencies = [] - , actionUrl = Right id - , actionFunction = return - } - - x . y = HakyllAction - { actionDependencies = actionDependencies x ++ actionDependencies y - , actionUrl = case actionUrl x of - Left ux -> Left ux - Right fx -> case actionUrl y of - Left uy -> Left (fx uy) - Right fy -> Right (fx . fy) - , actionFunction = actionFunction x <=< actionFunction y - } - -instance Arrow HakyllAction where - arr f = id { actionFunction = return . f } - - first x = x - { actionFunction = \(y, z) -> do y' <- actionFunction x y - return (y', z) - } diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs deleted file mode 100644 index f51cf2c..0000000 --- a/src/Text/Hakyll/HakyllMonad.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Module describing the Hakyll monad stack. -module Text.Hakyll.HakyllMonad - ( HakyllConfiguration (..) - , PreviewMode (..) - , Hakyll - , askHakyll - , getAdditionalContext - , logHakyll - , forkHakyllWait - , concurrentHakyll - ) where - -import Control.Monad.Trans (liftIO) -import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad (liftM, forM, forM_) -import qualified Data.Map as M -import System.IO (hPutStrLn, stderr) - -import Text.Pandoc (ParserState, WriterOptions) -import Text.Hamlet (HamletSettings) - -import Text.Hakyll.Context (Context (..)) - --- | Our custom monad stack. --- -type Hakyll = ReaderT HakyllConfiguration IO - --- | Preview mode. --- -data PreviewMode = BuildOnRequest - | BuildOnInterval - deriving (Show, Eq, Ord) - --- | Hakyll global configuration type. --- -data HakyllConfiguration = HakyllConfiguration - { -- | Absolute URL of the site. - absoluteUrl :: String - , -- | An additional context to use when rendering. This additional context - -- is used globally. - additionalContext :: Context - , -- | Directory where the site is placed. - siteDirectory :: FilePath - , -- | Directory for cache files. - cacheDirectory :: FilePath - , -- | Enable index links. - enableIndexUrl :: Bool - , -- | The preview mode used - previewMode :: PreviewMode - , -- | Pandoc parsing options - pandocParserState :: ParserState - , -- | Pandoc writer options - pandocWriterOptions :: WriterOptions - , -- | Hamlet settings (if you use hamlet for templates) - hamletSettings :: HamletSettings - } - --- | Simplified @ask@ function for the Hakyll monad stack. --- --- Usage would typically be something like: --- --- > doSomething :: a -> b -> Hakyll c --- > doSomething arg1 arg2 = do --- > siteDirectory' <- askHakyll siteDirectory --- > ... --- -askHakyll :: (HakyllConfiguration -> a) -> Hakyll a -askHakyll = flip liftM ask - --- | Obtain the globally available, additional context. --- -getAdditionalContext :: HakyllConfiguration -> Context -getAdditionalContext configuration = - let (Context c) = additionalContext configuration - in Context $ M.insert "absolute" (absoluteUrl configuration) c - --- | Write some log information. --- -logHakyll :: String -> Hakyll () -logHakyll = liftIO . hPutStrLn stderr - --- | Perform a concurrent hakyll action. Returns an MVar you can wait on --- -forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) -forkHakyllWait action = do - mvar <- liftIO newEmptyMVar - config <- ask - liftIO $ do - runReaderT action config - putMVar mvar () - return mvar - --- | Perform a number of concurrent hakyll actions, and waits for them to finish --- -concurrentHakyll :: [Hakyll ()] -> Hakyll () -concurrentHakyll actions = do - mvars <- forM actions forkHakyllWait - forM_ mvars (liftIO . readMVar) diff --git a/src/Text/Hakyll/Monad.hs b/src/Text/Hakyll/Monad.hs new file mode 100644 index 0000000..5de5e44 --- /dev/null +++ b/src/Text/Hakyll/Monad.hs @@ -0,0 +1,115 @@ +-- | Module describing the Hakyll monad stack. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Text.Hakyll.Monad + ( HakyllConfiguration (..) + , PreviewMode (..) + , Hakyll + , askHakyll + , getAdditionalContext + , logHakyll + , forkHakyllWait + , concurrentHakyll + ) where + +import Control.Monad.Trans (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad (liftM, forM, forM_) +import qualified Data.Map as M +import System.IO (hPutStrLn, stderr) + +import Text.Pandoc (ParserState, WriterOptions) +import Text.Hamlet (HamletSettings) + +import Text.Hakyll.Context (Context (..)) + +-- | Our custom monad stack. +-- +newtype Hakyll a = Hakyll (ReaderT HakyllConfiguration IO a) + deriving (Monad, Functor) + +instance MonadIO Hakyll where + liftIO = Hakyll . liftIO + +-- | Run a hakyll stack +-- +runHakyll :: Hakyll a -> HakyllConfiguration -> IO a +runHakyll (Hakyll h) = runReaderT h + +-- | Preview mode. +-- +data PreviewMode = BuildOnRequest + | BuildOnInterval + deriving (Show, Eq, Ord) + +-- | Hakyll global configuration type. +-- +data HakyllConfiguration = HakyllConfiguration + { -- | Absolute URL of the site. + absoluteUrl :: String + , -- | An additional context to use when rendering. This additional context + -- is used globally. + additionalContext :: Context + , -- | Directory where the site is placed. + siteDirectory :: FilePath + , -- | Directory for cache files. + cacheDirectory :: FilePath + , -- | Enable index links. + enableIndexUrl :: Bool + , -- | The preview mode used + previewMode :: PreviewMode + , -- | Pandoc parsing options + pandocParserState :: ParserState + , -- | Pandoc writer options + pandocWriterOptions :: WriterOptions + , -- | Hamlet settings (if you use hamlet for templates) + hamletSettings :: HamletSettings + } + +-- | Get the hakyll configuration +-- +getHakyllConfiguration :: Hakyll HakyllConfiguration +getHakyllConfiguration = Hakyll ask + +-- | Simplified @ask@ function for the Hakyll monad stack. +-- +-- Usage would typically be something like: +-- +-- > doSomething :: a -> b -> Hakyll c +-- > doSomething arg1 arg2 = do +-- > siteDirectory' <- askHakyll siteDirectory +-- > ... +-- +askHakyll :: (HakyllConfiguration -> a) -> Hakyll a +askHakyll = flip liftM getHakyllConfiguration + +-- | Obtain the globally available, additional context. +-- +getAdditionalContext :: HakyllConfiguration -> Context +getAdditionalContext configuration = + let (Context c) = additionalContext configuration + in Context $ M.insert "absolute" (absoluteUrl configuration) c + +-- | Write some log information. +-- +logHakyll :: String -> Hakyll () +logHakyll = Hakyll . liftIO . hPutStrLn stderr + +-- | Perform a concurrent hakyll action. Returns an MVar you can wait on +-- +forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) +forkHakyllWait action = do + mvar <- liftIO newEmptyMVar + config <- getHakyllConfiguration + liftIO $ do + runHakyll action config + putMVar mvar () + return mvar + +-- | Perform a number of concurrent hakyll actions, and waits for them to finish +-- +concurrentHakyll :: [Hakyll ()] -> Hakyll () +concurrentHakyll actions = do + mvars <- forM actions forkHakyllWait + forM_ mvars (liftIO . readMVar) diff --git a/src/Text/Hakyll/Pandoc.hs b/src/Text/Hakyll/Pandoc.hs index c0dec77..af4be62 100644 --- a/src/Text/Hakyll/Pandoc.hs +++ b/src/Text/Hakyll/Pandoc.hs @@ -17,6 +17,30 @@ import Text.Hakyll.HakyllMonad import Text.Hakyll.HakyllAction import Text.Hakyll.Context +-- | Reader function for plain text +-- +readText :: ParserState -> String -> Pandoc +readText _ = Pandoc (Meta [] [] []) . return . Plain . return . Str + +-- | Get a read function for a given extension. +-- +readPandoc :: HakyllAction (FileType, String) Pandoc +readPandoc = createHakyllAction $ \(fileType, inp) -> do + parserState <- askHakyll pandocParserState + return $ readFunction fileType (readOptions parserState fileType) inp + where + readFunction ReStructuredText = readRST + readFunction LaTeX = readLaTeX + readFunction Markdown = readMarkdown + readFunction LiterateHaskellMarkdown = readMarkdown + readFunction Html = readHtml + readFunction Text = readText + readFunction t = error $ "Cannot render " ++ show t + + readOptions options LiterateHaskellMarkdown = options + { stateLiterateHaskell = True } + readOptions options _ = options + -- | Get a render function for a given extension. -- getRenderFunction :: HakyllAction FileType (String -> String) @@ -39,6 +63,13 @@ getRenderFunction = createHakyllAction $ \fileType -> case fileType of { stateLiterateHaskell = True } readOptions options _ = options +-- | Get a render action +-- +renderPandoc :: HakyllAction Pandoc String +renderPandoc = createHakyllAction $ \p -> do + writerOptions <- askHakyll pandocWriterOptions + return $ writeHtmlString writerOptions p + -- | An action that renders the list of page sections to a context using pandoc -- renderAction :: HakyllAction [PageSection] Context diff --git a/src/Text/Hakyll/Resource.hs b/src/Text/Hakyll/Resource.hs new file mode 100644 index 0000000..a8a77b2 --- /dev/null +++ b/src/Text/Hakyll/Resource.hs @@ -0,0 +1,60 @@ +-- | A resource represents data for a website +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Text.Hakyll.Resource + ( Metadata (..) + , Resource (..) + , getData + , getMetadata + , getMetadataList + ) where + +import Data.Monoid (Monoid, mempty, mappend) +import Control.Applicative (Applicative, (<*>), pure) + +-- | Metadata for a resource +-- +newtype Metadata = Metadata {unMetadata :: [(String, String)]} + deriving (Show, Eq, Ord, Monoid) + +-- | A resource represents a data source for the website. It contains a value +-- and a number of metadata fields +-- +data Resource a = Resource + { resourceMetadata :: Metadata + , resourceData :: a + } deriving (Show, Eq, Ord) + +instance Functor Resource where + fmap f (Resource m d) = Resource m $ f d + +instance Applicative Resource where + pure d = Resource mempty d + (Resource m1 f) <*> (Resource m2 d) = Resource (mappend m2 m1) (f d) + +instance Monad Resource where + return d = Resource mempty d + (Resource m1 d) >>= f = let Resource m2 d' = f d + in Resource (mappend m2 m1) d' + +instance Monoid a => Monoid (Resource a) where + mempty = Resource mempty mempty + mappend (Resource m1 d1) (Resource m2 d2) = + Resource (mappend m1 m2) (mappend d1 d2) + +-- | Get the data from a resource +-- +getData :: Resource a -> a +getData = resourceData + +-- | Get a metadata field from a resource +-- +getMetadata :: String -> Resource a -> Maybe String +getMetadata k (Resource m _) = lookup k $ unMetadata m + +-- | Get a metadata field from a resource. If multiple fields with the same name +-- exist, they will all be returned +-- +getMetadataList :: String -> Resource a -> [String] +getMetadataList k = map snd . filter ((== k) . fst) + . unMetadata . resourceMetadata diff --git a/src/Text/Hakyll/Transformer.hs b/src/Text/Hakyll/Transformer.hs new file mode 100644 index 0000000..fff8470 --- /dev/null +++ b/src/Text/Hakyll/Transformer.hs @@ -0,0 +1,97 @@ +-- | This is the module which exports @Transformer@. +module Text.Hakyll.Transformer + ( Transformer (..) + , transformResource + , transformResourceM + , transformData + , transformDataM + , transformMetaData + , transformMetaDataM + , runTransformer + , runTransformerForced + ) where + +import Data.Monoid (mappend, mempty) +import Control.Arrow +import Control.Category +import Control.Applicative ((<$>)) +import Control.Monad ((<=<), unless) +import Prelude hiding ((.), id) + +import Text.Hakyll.Resource +import Text.Hakyll.File (toDestination, isFileMoreRecent) +import Text.Hakyll.Monad + +-- | Type used for computations that transform resources, carrying along +-- dependencies. +-- +data Transformer a b = Transformer + { -- | Dependencies of the @Transformer@. + transformerDependencies :: [FilePath] + , -- | URL pointing to the result of this @Transformer@. + transformerUrl :: FilePath -> Hakyll FilePath + , -- | The actual transforming function. + transformerFunction :: Resource a -> Hakyll (Resource b) + } + +instance Category Transformer where + id = Transformer + { transformerDependencies = [] + , transformerUrl = return + , transformerFunction = return + } + + x . y = Transformer + { transformerDependencies = + transformerDependencies x ++ transformerDependencies y + , transformerUrl = transformerUrl y <=< transformerUrl x + , transformerFunction = transformerFunction x <=< transformerFunction y + } + +instance Arrow Transformer where + arr = transformData + + first t = t + { transformerFunction = \(Resource m (x, y)) -> do + Resource m' x' <- transformerFunction t $ Resource m x + return $ Resource (mappend m' m) (x', y) + } + +transformResource :: (Resource a -> Resource b) -> Transformer a b +transformResource = transformResourceM . (return .) + +transformResourceM :: (Resource a -> Hakyll (Resource b)) -> Transformer a b +transformResourceM f = id {transformerFunction = f} + +transformData :: (a -> b) -> Transformer a b +transformData = transformResource . fmap + +transformDataM :: (a -> Hakyll b) -> Transformer a b +transformDataM f = transformResourceM $ \(Resource m x) -> + f x >>= return . Resource m + +transformMetaData :: (Metadata -> Metadata) -> Transformer a a +transformMetaData = transformMetaDataM . (return .) + +transformMetaDataM :: (Metadata -> Hakyll Metadata) -> Transformer a a +transformMetaDataM f = transformResourceM $ \(Resource m x) -> do + m' <- f m + return $ Resource m' x + +-- | Run a transformer. This might not run it when the result is up-to-date +-- +runTransformer :: Transformer () () + -> Hakyll () +runTransformer t = do + url <- transformerUrl t $ + error "runTransformer: No url when checking dependencies." + destination <- toDestination url + valid <- isFileMoreRecent destination $ transformerDependencies t + unless valid $ do logHakyll $ "Rendering " ++ destination + runTransformerForced t + +-- | Always run the transformer, even when the target is up-to-date +-- +runTransformerForced :: Transformer () () + -> Hakyll () +runTransformerForced t = getData <$> transformerFunction t mempty -- cgit v1.2.3 From fef1172c77e510054fc9bf95d5d2b85b8a15478e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 13 Dec 2010 22:02:54 +0100 Subject: ContextManipulations → Metadata MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Text/Hakyll/ContextManipulations.hs | 124 -------------------------------- src/Text/Hakyll/Metadata.hs | 108 ++++++++++++++++++++++++++++ src/Text/Hakyll/Resource.hs | 21 +++--- src/Text/Hakyll/Transformer.hs | 26 ++++--- 4 files changed, 135 insertions(+), 144 deletions(-) delete mode 100644 src/Text/Hakyll/ContextManipulations.hs create mode 100644 src/Text/Hakyll/Metadata.hs (limited to 'src') diff --git a/src/Text/Hakyll/ContextManipulations.hs b/src/Text/Hakyll/ContextManipulations.hs deleted file mode 100644 index 1c26f72..0000000 --- a/src/Text/Hakyll/ContextManipulations.hs +++ /dev/null @@ -1,124 +0,0 @@ --- | This module exports a number of functions that produce @HakyllAction@s to --- manipulate @Context@s. -module Text.Hakyll.ContextManipulations - ( renderValue - , changeValue - , changeUrl - , copyValue - , renderDate - , renderDateWithLocale - , changeExtension - , renderBody - , takeBody - ) where - -import Control.Monad (liftM) -import Control.Arrow (arr) -import System.Locale (TimeLocale, defaultTimeLocale) -import System.FilePath (takeFileName, addExtension, dropExtension) -import Data.Time.Format (parseTime, formatTime) -import Data.Time.Clock (UTCTime) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Regex (substituteRegex) -import Text.Hakyll.HakyllAction (HakyllAction (..)) -import Text.Hakyll.Context (Context (..)) - --- | Do something with a value in a @Context@, but keep the old value as well. --- If the key given is not present in the @Context@, nothing will happen. --- -renderValue :: String -- ^ Key of which the value should be copied. - -> String -- ^ Key the value should be copied to. - -> (String -> String) -- ^ Function to apply on the value. - -> HakyllAction Context Context -renderValue source destination f = arr $ \(Context context) -> Context $ - case M.lookup source context of - Nothing -> context - (Just value) -> M.insert destination (f value) context - --- | Change a value in a @Context@. --- --- > import Data.Char (toUpper) --- > changeValue "title" (map toUpper) --- --- Will put the title in UPPERCASE. -changeValue :: String -- ^ Key to change. - -> (String -> String) -- ^ Function to apply on the value. - -> HakyllAction Context Context -changeValue key = renderValue key key - --- | Change the URL of a page. This requires a special function, so dependency --- handling can happen correctly. --- -changeUrl :: (String -> String) -- ^ Function to change URL with. - -> HakyllAction Context Context -- ^ Resulting action. -changeUrl f = let action = changeValue "url" f - in action {actionUrl = Right $ liftM f} - --- | Copy a value from one key to another in a @Context@. -copyValue :: String -- ^ Source key. - -> String -- ^ Destination key. - -> HakyllAction Context Context -copyValue source destination = renderValue source destination id - --- | When the context has a key called @path@ in a --- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages), --- this function can render the date. --- --- > renderDate "date" "%B %e, %Y" "Date unknown" --- --- Will render something like @January 32, 2010@. --- -renderDate :: String -- ^ Key in which the rendered date should be placed. - -> String -- ^ Format to use on the date. - -> String -- ^ Default key, in case the date cannot be parsed. - -> HakyllAction Context Context -renderDate = renderDateWithLocale defaultTimeLocale - --- | This is an extended version of 'renderDate' that allows you to specify a --- time locale that is used for outputting the date. For more details, see --- 'renderDate'. --- -renderDateWithLocale :: TimeLocale -- ^ Output time locale. - -> String -- ^ Destination key. - -> String -- ^ Format to use on the date. - -> String -- ^ Default key. - -> HakyllAction Context Context -renderDateWithLocale locale key format defaultValue = - renderValue "path" key renderDate' - where - renderDate' filePath = fromMaybe defaultValue $ do - let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" - (takeFileName filePath) - time <- parseTime defaultTimeLocale - "%Y-%m-%d" - dateString :: Maybe UTCTime - return $ formatTime locale format time - --- | Change the extension of a file. This is only needed when you want to --- render, for example, mardown to @.php@ files instead of @.html@ files. --- --- > changeExtension "php" --- --- Will render @test.markdown@ to @test.php@ instead of @test.html@. -changeExtension :: String -- ^ Extension to change to. - -> HakyllAction Context Context -changeExtension extension = changeValue "url" changeExtension' - where - changeExtension' = flip addExtension extension . dropExtension - --- | Change the body of a file using a certain manipulation. --- --- > import Data.Char (toUpper) --- > renderBody (map toUpper) --- --- Will put the entire body of the page in UPPERCASE. -renderBody :: (String -> String) - -> HakyllAction Context Context -renderBody = renderValue "body" "body" - --- | Get the resulting body text from a context --- -takeBody :: HakyllAction Context String -takeBody = arr $ fromMaybe "" . M.lookup "body" . unContext diff --git a/src/Text/Hakyll/Metadata.hs b/src/Text/Hakyll/Metadata.hs new file mode 100644 index 0000000..7698dad --- /dev/null +++ b/src/Text/Hakyll/Metadata.hs @@ -0,0 +1,108 @@ +-- | This module exports a number of functions to manipulate metadata of +-- resources +-- +module Text.Hakyll.ContextManipulations + ( renderValue + , changeValue + , changeUrl + , copyValue + , renderDate + , renderDateWithLocale + , changeExtension + ) where + +import System.Locale (TimeLocale, defaultTimeLocale) +import System.FilePath (takeFileName, addExtension, dropExtension) +import Data.Time.Format (parseTime, formatTime) +import Data.Time.Clock (UTCTime) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + +import Text.Hakyll.Regex (substituteRegex) +import Text.Hakyll.Transformer (Transformer (..), transformMetadata) +import Text.Hakyll.Resource + +-- | Do something with a value in a @Context@, but keep the old value as well. +-- If the key given is not present in the @Context@, nothing will happen. +-- +renderValue :: String -- ^ Key of which the value should be copied. + -> String -- ^ Key the value should be copied to. + -> (String -> String) -- ^ Function to apply on the value. + -> Transformer a a -- ^ Resulting transformer +renderValue source destination f = transformMetadata $ \(Metadata m) -> + Metadata $ case M.lookup source m of + Nothing -> m + (Just value) -> M.insert destination (f value) m + +-- | Change a value in the metadata +-- +-- > import Data.Char (toUpper) +-- > changeValue "title" (map toUpper) +-- +-- Will put the title in UPPERCASE. +changeValue :: String -- ^ Key to change. + -> (String -> String) -- ^ Function to apply on the value. + -> Transformer a a +changeValue key = renderValue key key + +-- | Change the URL of a page. You should always use this function instead of +-- 'changeValue' for this, because using 'changeValue' might break dependency +-- handling when changing the @url@ field. +-- +changeUrl :: (String -> String) -- ^ Function to change URL with. + -> Transformer a a -- ^ Resulting action. +changeUrl f = let t = changeValue "url" f + in t {transformerUrl = return . f} + +-- | Copy a metadata value from one key to another +-- +copyValue :: String -- ^ Source key. + -> String -- ^ Destination key. + -> Transformer a a -- ^ Resulting transformer +copyValue source destination = renderValue source destination id + +-- | When the context has a key called @path@ in a +-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages), +-- this function can render the date. +-- +-- > renderDate "date" "%B %e, %Y" "Date unknown" +-- +-- Will render something like @January 32, 2010@. +-- +renderDate :: String -- ^ Key in which the rendered date should be placed. + -> String -- ^ Format to use on the date. + -> String -- ^ Default key, in case the date cannot be parsed. + -> Transformer a a +renderDate = renderDateWithLocale defaultTimeLocale + +-- | This is an extended version of 'renderDate' that allows you to specify a +-- time locale that is used for outputting the date. For more details, see +-- 'renderDate'. +-- +renderDateWithLocale :: TimeLocale -- ^ Output time locale. + -> String -- ^ Destination key. + -> String -- ^ Format to use on the date. + -> String -- ^ Default key. + -> Transformer a a +renderDateWithLocale locale key format defaultValue = + renderValue "path" key renderDate' + where + renderDate' filePath = fromMaybe defaultValue $ do + let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" + (takeFileName filePath) + time <- parseTime defaultTimeLocale + "%Y-%m-%d" + dateString :: Maybe UTCTime + return $ formatTime locale format time + +-- | Change the extension of a file. This is only needed when you want to +-- render, for example, mardown to @.php@ files instead of @.html@ files. +-- +-- > changeExtension "php" +-- +-- Will render @test.markdown@ to @test.php@ instead of @test.html@. +changeExtension :: String -- ^ Extension to change to. + -> Transformer a a -- ^ Resulting transformer +changeExtension extension = changeValue "url" changeExtension' + where + changeExtension' = flip addExtension extension . dropExtension diff --git a/src/Text/Hakyll/Resource.hs b/src/Text/Hakyll/Resource.hs index a8a77b2..b0ffb8c 100644 --- a/src/Text/Hakyll/Resource.hs +++ b/src/Text/Hakyll/Resource.hs @@ -1,21 +1,25 @@ -- | A resource represents data for a website -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Text.Hakyll.Resource ( Metadata (..) , Resource (..) , getData , getMetadata - , getMetadataList ) where import Data.Monoid (Monoid, mempty, mappend) import Control.Applicative (Applicative, (<*>), pure) +import Data.Map (Map) +import qualified Data.Map as M -- | Metadata for a resource -- -newtype Metadata = Metadata {unMetadata :: [(String, String)]} - deriving (Show, Eq, Ord, Monoid) +newtype Metadata = Metadata {unMetadata :: Map String String} + deriving (Show, Eq, Ord) + +instance Monoid Metadata where + mempty = Metadata M.empty + (Metadata m1) `mappend` (Metadata m2) = Metadata $ m1 `M.union` m2 -- | A resource represents a data source for the website. It contains a value -- and a number of metadata fields @@ -50,11 +54,4 @@ getData = resourceData -- | Get a metadata field from a resource -- getMetadata :: String -> Resource a -> Maybe String -getMetadata k (Resource m _) = lookup k $ unMetadata m - --- | Get a metadata field from a resource. If multiple fields with the same name --- exist, they will all be returned --- -getMetadataList :: String -> Resource a -> [String] -getMetadataList k = map snd . filter ((== k) . fst) - . unMetadata . resourceMetadata +getMetadata k (Resource m _) = M.lookup k $ unMetadata m diff --git a/src/Text/Hakyll/Transformer.hs b/src/Text/Hakyll/Transformer.hs index fff8470..669e1d0 100644 --- a/src/Text/Hakyll/Transformer.hs +++ b/src/Text/Hakyll/Transformer.hs @@ -5,17 +5,17 @@ module Text.Hakyll.Transformer , transformResourceM , transformData , transformDataM - , transformMetaData - , transformMetaDataM + , transformMetadata + , transformMetadataM , runTransformer , runTransformerForced ) where -import Data.Monoid (mappend, mempty) +import Data.Monoid (Monoid, mappend, mempty) import Control.Arrow import Control.Category import Control.Applicative ((<$>)) -import Control.Monad ((<=<), unless) +import Control.Monad ((<=<), unless, liftM2) import Prelude hiding ((.), id) import Text.Hakyll.Resource @@ -34,6 +34,16 @@ data Transformer a b = Transformer transformerFunction :: Resource a -> Hakyll (Resource b) } +instance Monoid b => Monoid (Transformer a b) where + mempty = arr (const mempty) + mappend x y = Transformer + { transformerDependencies = + transformerDependencies x ++ transformerDependencies y + , transformerUrl = transformerUrl x + , transformerFunction = \r -> + liftM2 mappend (transformerFunction x r) (transformerFunction y r) + } + instance Category Transformer where id = Transformer { transformerDependencies = [] @@ -70,11 +80,11 @@ transformDataM :: (a -> Hakyll b) -> Transformer a b transformDataM f = transformResourceM $ \(Resource m x) -> f x >>= return . Resource m -transformMetaData :: (Metadata -> Metadata) -> Transformer a a -transformMetaData = transformMetaDataM . (return .) +transformMetadata :: (Metadata -> Metadata) -> Transformer a a +transformMetadata = transformMetadataM . (return .) -transformMetaDataM :: (Metadata -> Hakyll Metadata) -> Transformer a a -transformMetaDataM f = transformResourceM $ \(Resource m x) -> do +transformMetadataM :: (Metadata -> Hakyll Metadata) -> Transformer a a +transformMetadataM f = transformResourceM $ \(Resource m x) -> do m' <- f m return $ Resource m' x -- cgit v1.2.3 From 9b63052148a140b8ad5fc04b996023d8b8e3796d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 14:31:30 +0100 Subject: Remove old code for now --- src/Network/Hakyll/SimpleServer.hs | 215 -------------------------- src/Text/Hakyll.hs | 185 ---------------------- src/Text/Hakyll/Configurations/Static.hs | 59 ------- src/Text/Hakyll/Context.hs | 16 -- src/Text/Hakyll/CreateContext.hs | 114 -------------- src/Text/Hakyll/Feed.hs | 112 -------------- src/Text/Hakyll/File.hs | 196 ----------------------- src/Text/Hakyll/Internal/Cache.hs | 53 ------- src/Text/Hakyll/Internal/CompressCss.hs | 36 ----- src/Text/Hakyll/Internal/FileType.hs | 49 ------ src/Text/Hakyll/Internal/Template.hs | 86 ----------- src/Text/Hakyll/Internal/Template/Hamlet.hs | 56 ------- src/Text/Hakyll/Internal/Template/Template.hs | 34 ---- src/Text/Hakyll/Metadata.hs | 108 ------------- src/Text/Hakyll/Monad.hs | 115 -------------- src/Text/Hakyll/Page.hs | 108 ------------- src/Text/Hakyll/Paginate.hs | 94 ----------- src/Text/Hakyll/Pandoc.hs | 88 ----------- src/Text/Hakyll/Regex.hs | 77 --------- src/Text/Hakyll/Render.hs | 126 --------------- src/Text/Hakyll/Resource.hs | 57 ------- src/Text/Hakyll/Tags.hs | 172 --------------------- src/Text/Hakyll/Transformer.hs | 107 ------------- src/Text/Hakyll/Util.hs | 34 ---- 24 files changed, 2297 deletions(-) delete mode 100644 src/Network/Hakyll/SimpleServer.hs delete mode 100644 src/Text/Hakyll.hs delete mode 100644 src/Text/Hakyll/Configurations/Static.hs delete mode 100644 src/Text/Hakyll/Context.hs delete mode 100644 src/Text/Hakyll/CreateContext.hs delete mode 100644 src/Text/Hakyll/Feed.hs delete mode 100644 src/Text/Hakyll/File.hs delete mode 100644 src/Text/Hakyll/Internal/Cache.hs delete mode 100644 src/Text/Hakyll/Internal/CompressCss.hs delete mode 100644 src/Text/Hakyll/Internal/FileType.hs delete mode 100644 src/Text/Hakyll/Internal/Template.hs delete mode 100644 src/Text/Hakyll/Internal/Template/Hamlet.hs delete mode 100644 src/Text/Hakyll/Internal/Template/Template.hs delete mode 100644 src/Text/Hakyll/Metadata.hs delete mode 100644 src/Text/Hakyll/Monad.hs delete mode 100644 src/Text/Hakyll/Page.hs delete mode 100644 src/Text/Hakyll/Paginate.hs delete mode 100644 src/Text/Hakyll/Pandoc.hs delete mode 100644 src/Text/Hakyll/Regex.hs delete mode 100644 src/Text/Hakyll/Render.hs delete mode 100644 src/Text/Hakyll/Resource.hs delete mode 100644 src/Text/Hakyll/Tags.hs delete mode 100644 src/Text/Hakyll/Transformer.hs delete mode 100644 src/Text/Hakyll/Util.hs (limited to 'src') diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs deleted file mode 100644 index 4eef689..0000000 --- a/src/Network/Hakyll/SimpleServer.hs +++ /dev/null @@ -1,215 +0,0 @@ --- | Module containing a small, simple http file server for testing and preview --- purposes. -module Network.Hakyll.SimpleServer - ( simpleServer - ) where - -import Prelude hiding (log) -import Control.Monad (forever) -import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO) -import Network -import System.IO -import System.Directory (doesFileExist, doesDirectoryExist) -import Control.Concurrent (forkIO) -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import System.FilePath (takeExtension) -import qualified Data.Map as M -import Data.List (intercalate) - -import Text.Hakyll.Util -import Text.Hakyll.Regex - --- | Function to log from a chan. -log :: Chan String -> IO () -log logChan = forever (readChan logChan >>= hPutStrLn stderr) - --- | General server configuration. -data ServerConfig = ServerConfig { documentRoot :: FilePath - , portNumber :: PortNumber - , logChannel :: Chan String - } - --- | Custom monad stack. -type Server = ReaderT ServerConfig IO - --- | Simple representation of a HTTP request. -data Request = Request { requestMethod :: String - , requestURI :: String - , requestVersion :: String - } deriving (Ord, Eq) - -instance Show Request where - show request = requestMethod request ++ " " - ++ requestURI request ++ " " - ++ requestVersion request - --- | Read a HTTP request from a 'Handle'. For now, this will ignore the request --- headers and body. -readRequest :: Handle -> Server Request -readRequest handle = do - requestLine <- liftIO $ hGetLine handle - let [method, uri, version] = map trim $ splitRegex " " requestLine - request = Request { requestMethod = method - , requestURI = uri - , requestVersion = version - } - return request - --- | Simple representation of the HTTP response we send back. -data Response = Response { responseVersion :: String - , responseStatusCode :: Int - , responsePhrase :: String - , responseHeaders :: M.Map String String - , responseBody :: String - } deriving (Ord, Eq) - -instance Show Response where - show response = responseVersion response ++ " " - ++ show (responseStatusCode response) ++ " " - ++ responsePhrase response - --- | A default response. -defaultResponse :: Response -defaultResponse = Response { responseVersion = "HTTP/1.1" - , responseStatusCode = 0 - , responsePhrase = "" - , responseHeaders = M.empty - , responseBody = "" - } - --- | Create a response for a given HTTP request. -createResponse :: Request -> Server Response -createResponse request - | requestMethod request == "GET" = createGetResponse request - | otherwise = return $ createErrorResponse 501 "Not Implemented" - --- | Create a simple error response. -createErrorResponse :: Int -- ^ Error code. - -> String -- ^ Error phrase. - -> Response -- ^ Result. -createErrorResponse statusCode phrase = defaultResponse - { responseStatusCode = statusCode - , responsePhrase = phrase - , responseHeaders = M.singleton "Content-Type" "text/html" - , responseBody = - " " ++ show statusCode ++ " " - ++ "

" ++ show statusCode ++ "

\n" - ++ "

" ++ phrase ++ "

" - } - --- | Create a simple get response. -createGetResponse :: Request -> Server Response -createGetResponse request = do - -- Construct the complete fileName of the requested resource. - config <- ask - let -- Drop everything after a '?'. - uri = takeWhile ((/=) '?') $ requestURI request - log' = writeChan (logChannel config) - isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri - let fileName = - documentRoot config ++ if isDirectory then uri ++ "/index.html" - else uri - - create200 = do - h <- openBinaryFile fileName ReadMode - contentLength <- hFileSize h - body <- hGetContents h - let mimeHeader = getMIMEHeader fileName - headers = ("Content-Length", show contentLength) : mimeHeader - return $ defaultResponse - { responseStatusCode = 200 - , responsePhrase = "OK" - , responseHeaders = responseHeaders defaultResponse - `M.union` M.fromList headers - , responseBody = body - } - - -- Called when an error occurs during the creation of a 200 response. - create500 e = do - log' $ "Internal Error: " ++ show e - return $ createErrorResponse 500 "Internal Server Error" - - -- Send back the page if found. - exists <- liftIO $ doesFileExist fileName - if exists - then liftIO $ catch create200 create500 - else do liftIO $ log' $ "Not Found: " ++ fileName - return $ createErrorResponse 404 "Not Found" - --- | Get the mime header for a certain filename. This is based on the extension --- of the given 'FilePath'. -getMIMEHeader :: FilePath -> [(String, String)] -getMIMEHeader fileName = - case result of (Just x) -> [("Content-Type", x)] - Nothing -> [] - where - result = lookup (takeExtension fileName) [ (".css", "text/css") - , (".gif", "image/gif") - , (".htm", "text/html") - , (".html", "text/html") - , (".jpeg", "image/jpeg") - , (".jpg", "image/jpeg") - , (".js", "text/javascript") - , (".png", "image/png") - , (".txt", "text/plain") - , (".xml", "text/xml") - ] - --- | Respond to an incoming request. -respond :: Handle -> Server () -respond handle = do - -- Read the request and create a response. - request <- readRequest handle - response <- createResponse request - - -- Generate some output. - config <- ask - liftIO $ writeChan (logChannel config) - $ show request ++ " => " ++ show response - - -- Send the response back to the handle. - liftIO $ putResponse response - where - putResponse response = do hPutStr handle $ intercalate " " - [ responseVersion response - , show $ responseStatusCode response - , responsePhrase response - ] - hPutStr handle "\r\n" - mapM_ putHeader - (M.toList $ responseHeaders response) - hPutStr handle "\r\n" - hPutStr handle $ responseBody response - hPutStr handle "\r\n" - hClose handle - - putHeader (key, value) = - hPutStr handle $ key ++ ": " ++ value ++ "\r\n" - --- | Start a simple http server on the given 'PortNumber', serving the given --- directory. --- -simpleServer :: PortNumber -- ^ Port to listen on. - -> FilePath -- ^ Root directory to serve. - -> IO () -- ^ Optional pre-respond action. - -> IO () -simpleServer port root preRespond = do - -- Channel to send logs to - logChan <- newChan - - let config = ServerConfig { documentRoot = root - , portNumber = port - , logChannel = logChan - } - - -- When a client connects, respond in a separate thread. - listen socket = do (handle, _, _) <- accept socket - preRespond - forkIO (runReaderT (respond handle) config) - - -- Handle logging in a separate thread - _ <- forkIO (log logChan) - - writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..." - socket <- listenOn (PortNumber port) - forever (listen socket) diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs deleted file mode 100644 index b0fe479..0000000 --- a/src/Text/Hakyll.hs +++ /dev/null @@ -1,185 +0,0 @@ --- | This is the main Hakyll module, exporting the important @hakyll@ function. --- --- Most configurations would use this @hakyll@ function more or less as the --- main function: --- --- > main = hakyll $ do --- > directory css "css" --- > directory static "images" --- -module Text.Hakyll - ( defaultHakyllConfiguration - , hakyll - , hakyllWithConfiguration - , runDefaultHakyll - - , module Text.Hakyll.Context - , module Text.Hakyll.ContextManipulations - , module Text.Hakyll.CreateContext - , module Text.Hakyll.File - , module Text.Hakyll.HakyllMonad - , module Text.Hakyll.Regex - , module Text.Hakyll.Render - , module Text.Hakyll.HakyllAction - , module Text.Hakyll.Paginate - , module Text.Hakyll.Page - , module Text.Hakyll.Pandoc - , module Text.Hakyll.Util - , module Text.Hakyll.Tags - , module Text.Hakyll.Feed - , module Text.Hakyll.Configurations.Static - ) where - -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad.Reader (runReaderT, liftIO, ask) -import Control.Monad (when) -import Data.Monoid (mempty) -import System.Environment (getArgs, getProgName) -import System.Directory (doesDirectoryExist, removeDirectoryRecursive) -import System.Time (getClockTime) - -import Text.Pandoc -import Text.Hamlet (defaultHamletSettings) - -import Network.Hakyll.SimpleServer (simpleServer) -import Text.Hakyll.Context -import Text.Hakyll.ContextManipulations -import Text.Hakyll.CreateContext -import Text.Hakyll.File -import Text.Hakyll.HakyllMonad -import Text.Hakyll.Regex -import Text.Hakyll.Render -import Text.Hakyll.HakyllAction -import Text.Hakyll.Paginate -import Text.Hakyll.Page -import Text.Hakyll.Pandoc -import Text.Hakyll.Util -import Text.Hakyll.Tags -import Text.Hakyll.Feed -import Text.Hakyll.Configurations.Static - --- | The default reader options for pandoc parsing. --- -defaultPandocParserState :: ParserState -defaultPandocParserState = defaultParserState - { -- The following option causes pandoc to read smart typography, a nice - -- and free bonus. - stateSmart = True - } - --- | The default writer options for pandoc rendering. --- -defaultPandocWriterOptions :: WriterOptions -defaultPandocWriterOptions = defaultWriterOptions - { -- This option causes literate haskell to be written using '>' marks in - -- html, which I think is a good default. - writerLiterateHaskell = True - } - --- | The default hakyll configuration. --- -defaultHakyllConfiguration :: String -- ^ Absolute site URL. - -> HakyllConfiguration -- ^ Default config. -defaultHakyllConfiguration absoluteUrl' = HakyllConfiguration - { absoluteUrl = absoluteUrl' - , additionalContext = mempty - , siteDirectory = "_site" - , cacheDirectory = "_cache" - , enableIndexUrl = False - , previewMode = BuildOnRequest - , pandocParserState = defaultPandocParserState - , pandocWriterOptions = defaultPandocWriterOptions - , hamletSettings = defaultHamletSettings - } - --- | Main function to run Hakyll with the default configuration. The --- absolute URL is only used in certain cases, for example RSS feeds et --- cetera. --- -hakyll :: String -- ^ Absolute URL of your site. Used in certain cases. - -> Hakyll () -- ^ You code. - -> IO () -hakyll absolute = hakyllWithConfiguration configuration - where - configuration = defaultHakyllConfiguration absolute - --- | Main function to run hakyll with a custom configuration. --- -hakyllWithConfiguration :: HakyllConfiguration -> Hakyll () -> IO () -hakyllWithConfiguration configuration buildFunction = do - args <- getArgs - let f = case args of ["build"] -> buildFunction - ["clean"] -> clean - ["preview", p] -> preview (read p) - ["preview"] -> preview defaultPort - ["rebuild"] -> clean >> buildFunction - ["server", p] -> server (read p) (return ()) - ["server"] -> server defaultPort (return ()) - _ -> help - runReaderT f configuration - where - preview port = case previewMode configuration of - BuildOnRequest -> server port buildFunction - BuildOnInterval -> do - let pIO = runReaderT (previewThread buildFunction) configuration - _ <- liftIO $ forkIO pIO - server port (return ()) - - defaultPort = 8000 - --- | A preview thread that periodically recompiles the site. --- -previewThread :: Hakyll () -- ^ Build function - -> Hakyll () -- ^ Result -previewThread buildFunction = run =<< liftIO getClockTime - where - delay = 1000000 - run time = do liftIO $ threadDelay delay - contents <- getRecursiveContents "." - valid <- isMoreRecent time contents - when valid buildFunction - run =<< liftIO getClockTime - --- | Clean up directories. --- -clean :: Hakyll () -clean = do askHakyll siteDirectory >>= remove' - askHakyll cacheDirectory >>= remove' - where - remove' dir = liftIO $ do putStrLn $ "Removing " ++ dir ++ "..." - exists <- doesDirectoryExist dir - when exists $ removeDirectoryRecursive dir - --- | Show usage information. --- -help :: Hakyll () -help = liftIO $ do - name <- getProgName - putStrLn $ "This is a Hakyll site generator program. You should always\n" - ++ "run it from the project root directory.\n" - ++ "\n" - ++ "Usage:\n" - ++ name ++ " build Generate the site.\n" - ++ name ++ " clean Clean up and remove cache.\n" - ++ name ++ " help Show this message.\n" - ++ name ++ " preview [port] Run a server and autocompile.\n" - ++ name ++ " rebuild Clean up and build again.\n" - ++ name ++ " server [port] Run a local test server.\n" - --- | Start a server at the given port number. --- -server :: Integer -- ^ Port number to serve on. - -> Hakyll () -- ^ Pre-respond action. - -> Hakyll () -server port preRespond = do - configuration <- ask - root <- askHakyll siteDirectory - let preRespondIO = runReaderT preRespond configuration - liftIO $ simpleServer (fromIntegral port) root preRespondIO - --- | Run a Hakyll action with default settings. This is mostly aimed at testing --- code. --- -runDefaultHakyll :: Hakyll a -> IO a -runDefaultHakyll f = - runReaderT f $ defaultHakyllConfiguration "http://example.com" diff --git a/src/Text/Hakyll/Configurations/Static.hs b/src/Text/Hakyll/Configurations/Static.hs deleted file mode 100644 index 5a2c1be..0000000 --- a/src/Text/Hakyll/Configurations/Static.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | Module for a simple static configuration of a website. --- --- The configuration works like this: --- --- * The @templates/@ directory should contain one template. --- --- * Renderable files in the directory tree are rendered using this template. --- --- * The @static/@ directory is copied entirely (if it exists). --- --- * All files in the @css/@ directory are compressed. --- -module Text.Hakyll.Configurations.Static - ( staticConfiguration - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (filterM, forM_) - -import Text.Hakyll.File ( getRecursiveContents, inDirectory, inHakyllDirectory - , directory ) -import Text.Hakyll.Internal.FileType (isRenderableFile) -import Text.Hakyll.HakyllMonad (Hakyll, logHakyll) -import Text.Hakyll.Render (renderChain, css, static) -import Text.Hakyll.CreateContext (createPage) - --- | A simple configuration for an entirely static website. --- -staticConfiguration :: Hakyll () -staticConfiguration = do - -- Find all files not in _site or _cache. - files <- filterM isRenderableFile' =<< getRecursiveContents "." - - -- Find a main template to use - mainTemplate <- take 1 <$> getRecursiveContents templateDir - logHakyll $ case mainTemplate of [] -> "Using no template" - (x : _) -> "Using template " ++ x - - -- Render all files using this template - forM_ files $ renderChain mainTemplate . createPage - - -- Render a static directory - directory static staticDir - - -- Render a css directory - directory css cssDir - where - -- A file should have a renderable extension and not be in a hakyll - -- directory, and not in a special directory. - isRenderableFile' file = do - inHakyllDirectory' <- inHakyllDirectory file - return $ isRenderableFile file - && not (any (inDirectory file) [templateDir, cssDir, staticDir]) - && not inHakyllDirectory' - - -- Directories - templateDir = "templates" - cssDir = "css" - staticDir = "static" diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs deleted file mode 100644 index 9045a65..0000000 --- a/src/Text/Hakyll/Context.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | This (quite small) module exports the datatype used for contexts. A --- @Context@ is a simple key-value mapping. You can render these @Context@s --- with templates, and manipulate them in various ways. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Hakyll.Context - ( Context (..) - ) where - -import Data.Monoid (Monoid) -import Data.Map (Map) -import Data.Binary (Binary) - --- | Datatype used for key-value mappings. -newtype Context = Context { -- | Extract the context. - unContext :: Map String String - } deriving (Show, Monoid, Binary) diff --git a/src/Text/Hakyll/CreateContext.hs b/src/Text/Hakyll/CreateContext.hs deleted file mode 100644 index 6a0e321..0000000 --- a/src/Text/Hakyll/CreateContext.hs +++ /dev/null @@ -1,114 +0,0 @@ --- | A module that provides different ways to create a @Context@. These --- functions all use the @HakyllAction@ arrow, so they produce values of the --- type @HakyllAction () Context@. -module Text.Hakyll.CreateContext - ( createPage - , createCustomPage - , createListing - , addField - , combine - , combineWithUrl - ) where - -import Prelude hiding (id) - -import qualified Data.Map as M -import Control.Arrow (second, arr, (&&&), (***)) -import Control.Monad (liftM2) -import Control.Applicative ((<$>)) -import Control.Arrow ((>>>)) -import Control.Category (id) - -import Text.Hakyll.Context -import Text.Hakyll.HakyllAction -import Text.Hakyll.Render -import Text.Hakyll.Page -import Text.Hakyll.Pandoc -import Text.Hakyll.Internal.Cache - --- | Create a @Context@ from a page file stored on the disk. This is probably --- the most common way to create a @Context@. -createPage :: FilePath -> HakyllAction () Context -createPage path = cacheAction "pages" $ readPageAction path >>> renderAction - --- | Create a custom page @Context@. --- --- The association list given maps keys to values for substitution. Note --- that as value, you can either give a @String@ or a --- @HakyllAction () String@. The latter is preferred for more complex data, --- since it allows dependency checking. A @String@ is obviously more simple --- to use in some cases. --- -createCustomPage :: FilePath - -> [(String, Either String (HakyllAction () String))] - -> HakyllAction () Context -createCustomPage url association = HakyllAction - { actionDependencies = dataDependencies - , actionUrl = Left $ return url - , actionFunction = \_ -> Context . M.fromList <$> assoc' - } - where - mtuple (a, b) = b >>= \b' -> return (a, b') - toHakyllString = second (either return runHakyllAction) - assoc' = mapM (mtuple . toHakyllString) $ ("url", Left url) : association - dataDependencies = map snd association >>= getDependencies - getDependencies (Left _) = [] - getDependencies (Right x) = actionDependencies x - --- | A @createCustomPage@ function specialized in creating listings. --- --- This function creates a listing of a certain list of @Context@s. Every --- item in the list is created by applying the given template to every --- renderable. You can also specify additional context to be included in the --- @CustomPage@. -createListing :: FilePath -- ^ Destination of the page. - -> [FilePath] -- ^ Templates to render items with. - -> [HakyllAction () Context] -- ^ Renderables in the list. - -> [(String, Either String (HakyllAction () String))] - -> HakyllAction () Context -createListing url templates renderables additional = - createCustomPage url context - where - context = ("body", Right concatenation) : additional - concatenation = renderAndConcat templates renderables - --- | Add a field to a 'Context'. --- -addField :: String -- ^ Key - -> Either String (HakyllAction () String) -- ^ Value - -> HakyllAction Context Context -- ^ Result -addField key value = arr (const ()) &&& id - >>> value' *** id - >>> arr (uncurry insert) - where - value' = arr (const ()) >>> either (arr . const) id value - insert v = Context . M.insert key v . unContext - --- | Combine two @Context@s. The url will always be taken from the first --- @Renderable@. Also, if a `$key` is present in both renderables, the --- value from the first @Context@ will be taken as well. --- --- You can see this as a this as a @union@ between two mappings. -combine :: HakyllAction () Context -> HakyllAction () Context - -> HakyllAction () Context -combine x y = HakyllAction - { actionDependencies = actionDependencies x ++ actionDependencies y - , actionUrl = actionUrl x - , actionFunction = \_ -> - Context <$> liftM2 (M.union) (unContext <$> runHakyllAction x) - (unContext <$> runHakyllAction y) - } - --- | Combine two @Context@s and set a custom URL. This behaves like @combine@, --- except that for the @url@ field, the given URL is always chosen. -combineWithUrl :: FilePath - -> HakyllAction () Context - -> HakyllAction () Context - -> HakyllAction () Context -combineWithUrl url x y = combine' - { actionUrl = Left $ return url - , actionFunction = \_ -> - Context . M.insert "url" url . unContext <$> runHakyllAction combine' - } - where - combine' = combine x y diff --git a/src/Text/Hakyll/Feed.hs b/src/Text/Hakyll/Feed.hs deleted file mode 100644 index be8d023..0000000 --- a/src/Text/Hakyll/Feed.hs +++ /dev/null @@ -1,112 +0,0 @@ --- | A Module that allows easy rendering of RSS feeds. If you use this module, --- you must make sure you set the `absoluteUrl` field in the main Hakyll --- configuration. --- --- Apart from that, the main rendering functions (@renderRss@, @renderAtom@) --- all assume that you pass the list of items so that the most recent entry --- in the feed is the first item in the list. --- --- Also note that the @Context@s should have (at least) the following --- fields to produce a correct feed: --- --- - @$title@: Title of the item. --- --- - @$description@: Description to appear in the feed. --- --- - @$url@: URL to the item - this is usually set automatically. --- --- Furthermore, the feed will be generated, but will be incorrect (it won't --- validate) if an empty list is passed. --- -module Text.Hakyll.Feed - ( FeedConfiguration (..) - , renderRss - , renderAtom - ) where - -import Control.Arrow ((>>>), second) -import Control.Monad.Reader (liftIO) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.CreateContext (createListing) -import Text.Hakyll.ContextManipulations (renderDate) -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.Render (render, renderChain) -import Text.Hakyll.HakyllAction - -import Paths_hakyll - --- | This is a data structure to keep the configuration of a feed. -data FeedConfiguration = FeedConfiguration - { -- | Url of the feed (relative to site root). For example, @rss.xml@. - feedUrl :: String - , -- | Title of the feed. - feedTitle :: String - , -- | Description of the feed. - feedDescription :: String - , -- | Name of the feed author. - feedAuthorName :: String - } - --- | This is an auxiliary function to create a listing that is, in fact, a feed. --- The items should be sorted on date. -createFeed :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include. - -> FilePath -- ^ Feed template. - -> FilePath -- ^ Item template. - -> HakyllAction () Context -createFeed configuration renderables template itemTemplate = - listing >>> render template - where - listing = createListing (feedUrl configuration) - [itemTemplate] renderables additional - - additional = map (second $ Left . ($ configuration)) - [ ("title", feedTitle) - , ("description", feedDescription) - , ("authorName", feedAuthorName) - ] ++ updated - - -- Take the first timestamp, which should be the most recent. - updated = let action = createHakyllAction $ return . fromMaybe "foo" - . M.lookup "timestamp" . unContext - toTuple r = ("timestamp", Right $ r >>> action) - in map toTuple $ take 1 renderables - - --- | Abstract function to render any feed. -renderFeed :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include in the feed. - -> FilePath -- ^ Feed template. - -> FilePath -- ^ Item template. - -> Hakyll () -renderFeed configuration renderables template itemTemplate = do - template' <- liftIO $ getDataFileName template - itemTemplate' <- liftIO $ getDataFileName itemTemplate - let renderFeed' = createFeed configuration renderables - template' itemTemplate' - renderChain [] renderFeed' - --- | Render an RSS feed with a number of items. -renderRss :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include in the feed. - -> Hakyll () -renderRss configuration renderables = - renderFeed configuration (map (>>> renderRssDate) renderables) - "templates/rss.xml" "templates/rss-item.xml" - where - renderRssDate = renderDate "timestamp" "%a, %d %b %Y %H:%M:%S UT" - "No date found." - --- | Render an Atom feed with a number of items. -renderAtom :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include in the feed. - -> Hakyll () -renderAtom configuration renderables = - renderFeed configuration (map (>>> renderAtomDate) renderables) - "templates/atom.xml" "templates/atom-item.xml" - where - renderAtomDate = renderDate "timestamp" "%Y-%m-%dT%H:%M:%SZ" - "No date found." diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs deleted file mode 100644 index 747608c..0000000 --- a/src/Text/Hakyll/File.hs +++ /dev/null @@ -1,196 +0,0 @@ --- | A module containing various function for manipulating and examinating --- files and directories. -module Text.Hakyll.File - ( toDestination - , toCache - , toUrl - , toRoot - , inDirectory - , inHakyllDirectory - , removeSpaces - , makeDirectories - , getRecursiveContents - , sortByBaseName - , havingExtension - , directory - , isMoreRecent - , isFileMoreRecent - ) where - -import System.Directory -import Control.Applicative ((<$>)) -import System.FilePath -import System.Time (ClockTime) -import Control.Monad -import Data.List (isPrefixOf, sortBy) -import Data.Ord (comparing) -import Control.Monad.Reader (liftIO) - -import Text.Hakyll.Monad -import Text.Hakyll.Internal.FileType (isRenderableFile) - --- | Auxiliary function to remove pathSeparators form the start. We don't deal --- with absolute paths here. We also remove $root from the start. -removeLeadingSeparator :: FilePath -> FilePath -removeLeadingSeparator [] = [] -removeLeadingSeparator path - | head path' `elem` pathSeparators = drop 1 path' - | otherwise = path' - where - path' = if "$root" `isPrefixOf` path then drop 5 path - else path - --- | Convert a relative URL to a filepath in the destination --- (default: @_site@). -toDestination :: FilePath -> Hakyll FilePath -toDestination url = do dir <- askHakyll siteDirectory - toFilePath dir url - --- | Convert a relative URL to a filepath in the cache --- (default: @_cache@). -toCache :: FilePath -> Hakyll FilePath -toCache path = do dir <- askHakyll cacheDirectory - toFilePath dir path - --- | Implementation of toDestination/toCache --- -toFilePath :: String -- ^ Directory (site or cache) - -> String -- ^ URL - -> Hakyll FilePath -- ^ Resulting file path -toFilePath dir url = do - enableIndexUrl' <- askHakyll enableIndexUrl - let destination = if enableIndexUrl' && separatorEnd - then dir noSeparator "index.html" - else dir noSeparator - return destination - where - noSeparator = removeLeadingSeparator url - separatorEnd = not (null url) && last url == '/' - --- | Get the url for a given page. For most extensions, this would be the path --- itself. It's only for rendered extensions (@.markdown@, @.rst@, @.lhs@ this --- function returns a path with a @.html@ extension instead. -toUrl :: FilePath -> Hakyll FilePath -toUrl path = do enableIndexUrl' <- askHakyll enableIndexUrl - -- If the file does not have a renderable extension, like for - -- example favicon.ico, we don't have to change it at all. - return $ if not (isRenderableFile path) - then path - -- If index url's are enabled, we create pick it - -- unless the page is an index already. - else if enableIndexUrl' && not isIndex - then indexUrl - else withSimpleHtmlExtension - where - isIndex = dropExtension (takeFileName path) == "index" - withSimpleHtmlExtension = flip addExtension ".html" $ dropExtension path - indexUrl = dropExtension path ++ "/" - - --- | Get the relative url to the site root, for a given (absolute) url -toRoot :: FilePath -> FilePath -toRoot = emptyException . joinPath . map parent . splitPath - . takeDirectory . removeLeadingSeparator - where - parent = const ".." - emptyException [] = "." - emptyException x = x - --- | Check if a file is in a given directory. --- -inDirectory :: FilePath -- ^ File path - -> FilePath -- ^ Directory - -> Bool -- ^ Result -inDirectory path dir = case splitDirectories path of - [] -> False - (x : _) -> x == dir - --- | Check if a file is in a Hakyll directory. With a Hakyll directory, we mean --- a directory that should be "ignored" such as the @_site@ or @_cache@ --- directory. --- --- Example: --- --- > inHakyllDirectory "_cache/pages/index.html" --- --- Result: --- --- > True --- -inHakyllDirectory :: FilePath -> Hakyll Bool -inHakyllDirectory path = - or <$> mapM (liftM (inDirectory path) . askHakyll) - [siteDirectory, cacheDirectory] - --- | Swaps spaces for '-'. -removeSpaces :: FilePath -> FilePath -removeSpaces = map swap - where - swap ' ' = '-' - swap x = x - --- | Given a path to a file, try to make the path writable by making --- all directories on the path. -makeDirectories :: FilePath -> Hakyll () -makeDirectories path = liftIO $ createDirectoryIfMissing True dir - where - dir = takeDirectory path - --- | Get all contents of a directory. Note that files starting with a dot (.) --- will be ignored. --- -getRecursiveContents :: FilePath -> Hakyll [FilePath] -getRecursiveContents topdir = do - topdirExists <- liftIO $ doesDirectoryExist topdir - if topdirExists - then do names <- liftIO $ getDirectoryContents topdir - let properNames = filter isProper names - paths <- forM properNames $ \name -> do - let path = topdir name - isDirectory <- liftIO $ doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [normalise path] - return (concat paths) - else return [] - where - isProper = not . (== '.') . head - --- | Sort a list of filenames on the basename. -sortByBaseName :: [FilePath] -> [FilePath] -sortByBaseName = sortBy compareBaseName - where - compareBaseName = comparing takeFileName - --- | A filter that takes all file names with a given extension. Prefix the --- extension with a dot: --- --- > havingExtension ".markdown" [ "index.markdown" --- > , "style.css" --- > ] == ["index.markdown"] -havingExtension :: String -> [FilePath] -> [FilePath] -havingExtension extension = filter ((==) extension . takeExtension) - --- | Perform a Hakyll action on every file in a given directory. -directory :: (FilePath -> Hakyll ()) -> FilePath -> Hakyll () -directory action dir = getRecursiveContents dir >>= mapM_ action - --- | Check if a timestamp is newer then a number of given files. -isMoreRecent :: ClockTime -- ^ The time to check. - -> [FilePath] -- ^ Dependencies of the cached file. - -> Hakyll Bool -isMoreRecent _ [] = return True -isMoreRecent timeStamp depends = do - dependsModified <- liftIO $ mapM getModificationTime depends - return (timeStamp >= maximum dependsModified) - --- | Check if a file is newer then a number of given files. -isFileMoreRecent :: FilePath -- ^ The cached file. - -> [FilePath] -- ^ Dependencies of the cached file. - -> Hakyll Bool -isFileMoreRecent file depends = do - exists <- liftIO $ doesFileExist file - if not exists - then return False - else do timeStamp <- liftIO $ getModificationTime file - isMoreRecent timeStamp depends diff --git a/src/Text/Hakyll/Internal/Cache.hs b/src/Text/Hakyll/Internal/Cache.hs deleted file mode 100644 index b83d9af..0000000 --- a/src/Text/Hakyll/Internal/Cache.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Text.Hakyll.Internal.Cache - ( storeInCache - , getFromCache - , isCacheMoreRecent - , cacheAction - ) where - -import Control.Monad ((<=<)) -import Control.Monad.Reader (liftIO) -import Data.Binary -import System.FilePath (()) - -import Text.Hakyll.File -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.HakyllAction - --- | We can store all datatypes instantiating @Binary@ to the cache. The cache --- directory is specified by the @HakyllConfiguration@, usually @_cache@. -storeInCache :: (Binary a) => a -> FilePath -> Hakyll () -storeInCache value path = do - cachePath <- toCache path - makeDirectories cachePath - liftIO $ encodeFile cachePath value - --- | Get a value from the cache. The filepath given should not be located in the --- cache. This function performs a timestamp check on the filepath and the --- filepath in the cache, and only returns the cached value when it is still --- up-to-date. -getFromCache :: (Binary a) => FilePath -> Hakyll a -getFromCache = liftIO . decodeFile <=< toCache - --- | Check if a file in the cache is more recent than a number of other files. -isCacheMoreRecent :: FilePath -> [FilePath] -> Hakyll Bool -isCacheMoreRecent file depends = toCache file >>= flip isFileMoreRecent depends - --- | Cache an entire arrow --- -cacheAction :: Binary a - => String - -> HakyllAction () a - -> HakyllAction () a -cacheAction key action = action { actionFunction = const cacheFunction } - where - cacheFunction = do - -- Construct a filename - fileName <- fmap (key ) $ either id (const $ return "unknown") - $ actionUrl action - -- Check the cache - cacheOk <- isCacheMoreRecent fileName $ actionDependencies action - if cacheOk then getFromCache fileName - else do result <- actionFunction action () - storeInCache result fileName - return result diff --git a/src/Text/Hakyll/Internal/CompressCss.hs b/src/Text/Hakyll/Internal/CompressCss.hs deleted file mode 100644 index 4a78791..0000000 --- a/src/Text/Hakyll/Internal/CompressCss.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Module used for CSS compression. The compression is currently in a simple --- state, but would typically reduce the number of bytes by about 25%. -module Text.Hakyll.Internal.CompressCss - ( compressCss - ) where - -import Data.List (isPrefixOf) - -import Text.Hakyll.Regex (substituteRegex) - --- | Compress CSS to speed up your site. -compressCss :: String -> String -compressCss = compressSeparators - . stripComments - . compressWhitespace - --- | Compresses certain forms of separators. -compressSeparators :: String -> String -compressSeparators = substituteRegex "; *}" "}" - . substituteRegex " *([{};:]) *" "\\1" - . substituteRegex ";;*" ";" - --- | Compresses all whitespace. -compressWhitespace :: String -> String -compressWhitespace = substituteRegex "[ \t\n][ \t\n]*" " " - --- | Function that strips CSS comments away. -stripComments :: String -> String -stripComments [] = [] -stripComments str - | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str - | otherwise = head str : stripComments (drop 1 str) - where - eatComments str' | null str' = [] - | isPrefixOf "*/" str' = drop 2 str' - | otherwise = eatComments $ drop 1 str' diff --git a/src/Text/Hakyll/Internal/FileType.hs b/src/Text/Hakyll/Internal/FileType.hs deleted file mode 100644 index 689c77f..0000000 --- a/src/Text/Hakyll/Internal/FileType.hs +++ /dev/null @@ -1,49 +0,0 @@ --- | A module dealing with file extensions and associated file types. -module Text.Hakyll.Internal.FileType - ( FileType (..) - , getFileType - , isRenderable - , isRenderableFile - ) where - -import System.FilePath (takeExtension) - --- | Datatype to represent the different file types Hakyll can deal with. -data FileType = Html - | LaTeX - | LiterateHaskellMarkdown - | Markdown - | ReStructuredText - | Text - | UnknownFileType - deriving (Eq, Ord, Show, Read) - --- | Get the file type for a certain file. The type is determined by extension. -getFileType :: FilePath -> FileType -getFileType = getFileType' . takeExtension - where - getFileType' ".htm" = Html - getFileType' ".html" = Html - getFileType' ".lhs" = LiterateHaskellMarkdown - getFileType' ".markdown" = Markdown - getFileType' ".md" = Markdown - getFileType' ".mdn" = Markdown - getFileType' ".mdown" = Markdown - getFileType' ".mdwn" = Markdown - getFileType' ".mkd" = Markdown - getFileType' ".mkdwn" = Markdown - getFileType' ".page" = Markdown - getFileType' ".rst" = ReStructuredText - getFileType' ".tex" = LaTeX - getFileType' ".text" = Text - getFileType' ".txt" = Text - getFileType' _ = UnknownFileType - --- | Check if a certain @FileType@ is renderable. -isRenderable :: FileType -> Bool -isRenderable UnknownFileType = False -isRenderable _ = True - --- | Check if a certain file is renderable. -isRenderableFile :: FilePath -> Bool -isRenderableFile = isRenderable . getFileType diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs deleted file mode 100644 index cd6a3bd..0000000 --- a/src/Text/Hakyll/Internal/Template.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Text.Hakyll.Internal.Template - ( Template (..) - , fromString - , readTemplate - , substitute - , regularSubstitute - , finalSubstitute - ) where - -import Control.Arrow ((>>>)) -import Control.Applicative ((<$>)) -import Data.List (isPrefixOf) -import Data.Char (isAlphaNum) -import Data.Maybe (fromMaybe) -import System.FilePath (()) -import qualified Data.Map as M - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.HakyllAction -import Text.Hakyll.Pandoc -import Text.Hakyll.Internal.Cache -import Text.Hakyll.Page -import Text.Hakyll.ContextManipulations -import Text.Hakyll.Internal.Template.Template -import Text.Hakyll.Internal.Template.Hamlet - --- | Construct a @Template@ from a string. --- -fromString :: String -> Template -fromString = Template . fromString' - where - fromString' [] = [] - fromString' string - | "$$" `isPrefixOf` string = - EscapeCharacter : (fromString' $ drop 2 string) - | "$" `isPrefixOf` string = - let (key, rest) = span isAlphaNum $ drop 1 string - in Identifier key : fromString' rest - | otherwise = - let (chunk, rest) = break (== '$') string - in Chunk chunk : fromString' rest - --- | Read a @Template@ from a file. This function might fetch the @Template@ --- from the cache, if available. -readTemplate :: FilePath -> Hakyll Template -readTemplate path = do - isCacheMoreRecent' <- isCacheMoreRecent fileName [path] - if isCacheMoreRecent' - then getFromCache fileName - else do - template <- if isHamletRTFile path - then readHamletTemplate - else readDefaultTemplate - storeInCache template fileName - return template - where - fileName = "templates" path - readDefaultTemplate = do - body <- runHakyllAction $ readPageAction path - >>> renderAction - >>> takeBody - return $ fromString body - - readHamletTemplate = fromHamletRT <$> readHamletRT path - --- | Substitutes @$identifiers@ in the given @Template@ by values from the given --- "Context". When a key is not found, it is left as it is. You can specify --- the characters used to replace escaped dollars (@$$@) here. -substitute :: String -> Template -> Context -> String -substitute escaper template context = substitute' =<< unTemplate template - where - substitute' (Chunk chunk) = chunk - substitute' (Identifier key) = - fromMaybe ('$' : key) $ M.lookup key $ unContext context - substitute' (EscapeCharacter) = escaper - --- | @substitute@ for use during a chain. This will leave escaped characters as --- they are. -regularSubstitute :: Template -> Context -> String -regularSubstitute = substitute "$$" - --- | @substitute@ for the end of a chain (just before writing). This renders --- escaped characters. -finalSubstitute :: Template -> Context -> String -finalSubstitute = substitute "$" diff --git a/src/Text/Hakyll/Internal/Template/Hamlet.hs b/src/Text/Hakyll/Internal/Template/Hamlet.hs deleted file mode 100644 index 458ab35..0000000 --- a/src/Text/Hakyll/Internal/Template/Hamlet.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | Support for Hamlet templates in Hakyll. --- -module Text.Hakyll.Internal.Template.Hamlet - ( isHamletRTFile - , readHamletRT - , fromHamletRT - ) where - -import Control.Exception (try) -import Control.Monad.Trans (liftIO) -import System.FilePath (takeExtension) - -import Text.Hamlet.RT - -import Text.Hakyll.Internal.Template.Template -import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, hamletSettings, logHakyll) - --- | Determine if a file is a hamlet template by extension. --- -isHamletRTFile :: FilePath -> Bool -isHamletRTFile fileName = takeExtension fileName `elem` [".hamlet", ".hml"] - --- | Read a 'HamletRT' by file name. --- -readHamletRT :: FilePath -- ^ Filename of the template - -> Hakyll HamletRT -- ^ Resulting hamlet template -readHamletRT fileName = do - settings <- askHakyll hamletSettings - string <- liftIO $ readFile fileName - result <- liftIO $ try $ parseHamletRT settings string - case result of - Left (HamletParseException s) -> error' s - Left (HamletUnsupportedDocException d) -> error' $ show d - Left (HamletRenderException s) -> error' s - Right x -> return x - where - error' s = do - logHakyll $ "Parse of hamlet file " ++ fileName ++ " failed." - logHakyll s - error "Parse failed." - --- | Convert a 'HamletRT' to a 'Template' --- -fromHamletRT :: HamletRT -- ^ Hamlet runtime template - -> Template -- ^ Hakyll template -fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd - where - fromSimpleDoc :: SimpleDoc -> TemplateElement - fromSimpleDoc (SDRaw chunk) = Chunk chunk - fromSimpleDoc (SDVar [var]) = Identifier var - fromSimpleDoc (SDVar _) = - error "Hakyll does not support '.' in identifier names when using \ - \hamlet templates." - fromSimpleDoc _ = - error "Only simple $key$ identifiers are allowed when using hamlet \ - \templates." diff --git a/src/Text/Hakyll/Internal/Template/Template.hs b/src/Text/Hakyll/Internal/Template/Template.hs deleted file mode 100644 index 49373fd..0000000 --- a/src/Text/Hakyll/Internal/Template/Template.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Module containing the template data structure. --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Hakyll.Internal.Template.Template - ( Template (..) - , TemplateElement (..) - ) where - -import Control.Applicative ((<$>)) - -import Data.Binary (Binary, get, getWord8, put, putWord8) - --- | Datatype used for template substitutions. --- -newtype Template = Template { unTemplate :: [TemplateElement] } - deriving (Show, Eq, Binary) - --- | Elements of a template. --- -data TemplateElement = Chunk String - | Identifier String - | EscapeCharacter - deriving (Show, Eq) - -instance Binary TemplateElement where - put (Chunk string) = putWord8 0 >> put string - put (Identifier key) = putWord8 1 >> put key - put (EscapeCharacter) = putWord8 2 - - get = getWord8 >>= \tag -> - case tag of 0 -> Chunk <$> get - 1 -> Identifier <$> get - 2 -> return EscapeCharacter - _ -> error "Error reading cached template" diff --git a/src/Text/Hakyll/Metadata.hs b/src/Text/Hakyll/Metadata.hs deleted file mode 100644 index 7698dad..0000000 --- a/src/Text/Hakyll/Metadata.hs +++ /dev/null @@ -1,108 +0,0 @@ --- | This module exports a number of functions to manipulate metadata of --- resources --- -module Text.Hakyll.ContextManipulations - ( renderValue - , changeValue - , changeUrl - , copyValue - , renderDate - , renderDateWithLocale - , changeExtension - ) where - -import System.Locale (TimeLocale, defaultTimeLocale) -import System.FilePath (takeFileName, addExtension, dropExtension) -import Data.Time.Format (parseTime, formatTime) -import Data.Time.Clock (UTCTime) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Regex (substituteRegex) -import Text.Hakyll.Transformer (Transformer (..), transformMetadata) -import Text.Hakyll.Resource - --- | Do something with a value in a @Context@, but keep the old value as well. --- If the key given is not present in the @Context@, nothing will happen. --- -renderValue :: String -- ^ Key of which the value should be copied. - -> String -- ^ Key the value should be copied to. - -> (String -> String) -- ^ Function to apply on the value. - -> Transformer a a -- ^ Resulting transformer -renderValue source destination f = transformMetadata $ \(Metadata m) -> - Metadata $ case M.lookup source m of - Nothing -> m - (Just value) -> M.insert destination (f value) m - --- | Change a value in the metadata --- --- > import Data.Char (toUpper) --- > changeValue "title" (map toUpper) --- --- Will put the title in UPPERCASE. -changeValue :: String -- ^ Key to change. - -> (String -> String) -- ^ Function to apply on the value. - -> Transformer a a -changeValue key = renderValue key key - --- | Change the URL of a page. You should always use this function instead of --- 'changeValue' for this, because using 'changeValue' might break dependency --- handling when changing the @url@ field. --- -changeUrl :: (String -> String) -- ^ Function to change URL with. - -> Transformer a a -- ^ Resulting action. -changeUrl f = let t = changeValue "url" f - in t {transformerUrl = return . f} - --- | Copy a metadata value from one key to another --- -copyValue :: String -- ^ Source key. - -> String -- ^ Destination key. - -> Transformer a a -- ^ Resulting transformer -copyValue source destination = renderValue source destination id - --- | When the context has a key called @path@ in a --- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages), --- this function can render the date. --- --- > renderDate "date" "%B %e, %Y" "Date unknown" --- --- Will render something like @January 32, 2010@. --- -renderDate :: String -- ^ Key in which the rendered date should be placed. - -> String -- ^ Format to use on the date. - -> String -- ^ Default key, in case the date cannot be parsed. - -> Transformer a a -renderDate = renderDateWithLocale defaultTimeLocale - --- | This is an extended version of 'renderDate' that allows you to specify a --- time locale that is used for outputting the date. For more details, see --- 'renderDate'. --- -renderDateWithLocale :: TimeLocale -- ^ Output time locale. - -> String -- ^ Destination key. - -> String -- ^ Format to use on the date. - -> String -- ^ Default key. - -> Transformer a a -renderDateWithLocale locale key format defaultValue = - renderValue "path" key renderDate' - where - renderDate' filePath = fromMaybe defaultValue $ do - let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" - (takeFileName filePath) - time <- parseTime defaultTimeLocale - "%Y-%m-%d" - dateString :: Maybe UTCTime - return $ formatTime locale format time - --- | Change the extension of a file. This is only needed when you want to --- render, for example, mardown to @.php@ files instead of @.html@ files. --- --- > changeExtension "php" --- --- Will render @test.markdown@ to @test.php@ instead of @test.html@. -changeExtension :: String -- ^ Extension to change to. - -> Transformer a a -- ^ Resulting transformer -changeExtension extension = changeValue "url" changeExtension' - where - changeExtension' = flip addExtension extension . dropExtension diff --git a/src/Text/Hakyll/Monad.hs b/src/Text/Hakyll/Monad.hs deleted file mode 100644 index 5de5e44..0000000 --- a/src/Text/Hakyll/Monad.hs +++ /dev/null @@ -1,115 +0,0 @@ --- | Module describing the Hakyll monad stack. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Hakyll.Monad - ( HakyllConfiguration (..) - , PreviewMode (..) - , Hakyll - , askHakyll - , getAdditionalContext - , logHakyll - , forkHakyllWait - , concurrentHakyll - ) where - -import Control.Monad.Trans (liftIO) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad (liftM, forM, forM_) -import qualified Data.Map as M -import System.IO (hPutStrLn, stderr) - -import Text.Pandoc (ParserState, WriterOptions) -import Text.Hamlet (HamletSettings) - -import Text.Hakyll.Context (Context (..)) - --- | Our custom monad stack. --- -newtype Hakyll a = Hakyll (ReaderT HakyllConfiguration IO a) - deriving (Monad, Functor) - -instance MonadIO Hakyll where - liftIO = Hakyll . liftIO - --- | Run a hakyll stack --- -runHakyll :: Hakyll a -> HakyllConfiguration -> IO a -runHakyll (Hakyll h) = runReaderT h - --- | Preview mode. --- -data PreviewMode = BuildOnRequest - | BuildOnInterval - deriving (Show, Eq, Ord) - --- | Hakyll global configuration type. --- -data HakyllConfiguration = HakyllConfiguration - { -- | Absolute URL of the site. - absoluteUrl :: String - , -- | An additional context to use when rendering. This additional context - -- is used globally. - additionalContext :: Context - , -- | Directory where the site is placed. - siteDirectory :: FilePath - , -- | Directory for cache files. - cacheDirectory :: FilePath - , -- | Enable index links. - enableIndexUrl :: Bool - , -- | The preview mode used - previewMode :: PreviewMode - , -- | Pandoc parsing options - pandocParserState :: ParserState - , -- | Pandoc writer options - pandocWriterOptions :: WriterOptions - , -- | Hamlet settings (if you use hamlet for templates) - hamletSettings :: HamletSettings - } - --- | Get the hakyll configuration --- -getHakyllConfiguration :: Hakyll HakyllConfiguration -getHakyllConfiguration = Hakyll ask - --- | Simplified @ask@ function for the Hakyll monad stack. --- --- Usage would typically be something like: --- --- > doSomething :: a -> b -> Hakyll c --- > doSomething arg1 arg2 = do --- > siteDirectory' <- askHakyll siteDirectory --- > ... --- -askHakyll :: (HakyllConfiguration -> a) -> Hakyll a -askHakyll = flip liftM getHakyllConfiguration - --- | Obtain the globally available, additional context. --- -getAdditionalContext :: HakyllConfiguration -> Context -getAdditionalContext configuration = - let (Context c) = additionalContext configuration - in Context $ M.insert "absolute" (absoluteUrl configuration) c - --- | Write some log information. --- -logHakyll :: String -> Hakyll () -logHakyll = Hakyll . liftIO . hPutStrLn stderr - --- | Perform a concurrent hakyll action. Returns an MVar you can wait on --- -forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) -forkHakyllWait action = do - mvar <- liftIO newEmptyMVar - config <- getHakyllConfiguration - liftIO $ do - runHakyll action config - putMVar mvar () - return mvar - --- | Perform a number of concurrent hakyll actions, and waits for them to finish --- -concurrentHakyll :: [Hakyll ()] -> Hakyll () -concurrentHakyll actions = do - mvars <- forM actions forkHakyllWait - forM_ mvars (liftIO . readMVar) diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs deleted file mode 100644 index f2b5fde..0000000 --- a/src/Text/Hakyll/Page.hs +++ /dev/null @@ -1,108 +0,0 @@ --- | A module for dealing with @Page@s. This module is mostly internally used. -module Text.Hakyll.Page - ( PageSection (..) - , readPage - , readPageAction - ) where - -import Data.List (isPrefixOf) -import Data.Char (isSpace) -import Control.Monad.Reader (liftIO) -import System.FilePath -import Control.Monad.State (State, evalState, get, put) - -import Text.Hakyll.File -import Text.Hakyll.HakyllMonad -import Text.Hakyll.HakyllAction -import Text.Hakyll.Regex (substituteRegex, matchesRegex) -import Text.Hakyll.Util (trim) - --- | A page is first parsed into a number of page sections. A page section --- consists of: --- --- * A key --- --- * A value --- --- * A 'Bool' flag, indicating if the value is applicable for rendering --- -data PageSection = PageSection {unPageSection :: (String, String, Bool)} - deriving (Show) - --- | Split a page into sections. --- -splitAtDelimiters :: [String] -> State (Maybe String) [[String]] -splitAtDelimiters [] = return [] -splitAtDelimiters ls@(x:xs) = do - delimiter <- get - if not (isDelimiter delimiter x) - then return [ls] - else do let proper = takeWhile (== '-') x - (content, rest) = break (isDelimiter $ Just proper) xs - put $ Just proper - rest' <- splitAtDelimiters rest - return $ (x : content) : rest' - where - isDelimiter old = case old of - Nothing -> isPossibleDelimiter - (Just d) -> (== d) . takeWhile (== '-') - --- | Check if the given string is a metadata delimiter. -isPossibleDelimiter :: String -> Bool -isPossibleDelimiter = isPrefixOf "---" - --- | Read one section of a page. --- -readSection :: Bool -- ^ If this section is the first section in the page. - -> [String] -- ^ Lines in the section. - -> [PageSection] -- ^ Key-values extracted. -readSection _ [] = [] -readSection isFirst ls - | not isDelimiter' = [body ls] - | isNamedDelimiter = readSectionMetaData ls - | isFirst = readSimpleMetaData (drop 1 ls) - | otherwise = [body (drop 1 ls)] - where - isDelimiter' = isPossibleDelimiter (head ls) - isNamedDelimiter = head ls `matchesRegex` "^----* *[a-zA-Z0-9][a-zA-Z0-9]*" - body ls' = PageSection ("body", unlines ls', True) - - readSimpleMetaData = map readPair . filter (not . all isSpace) - readPair = trimPair . break (== ':') - trimPair (key, value) = PageSection (trim key, trim (drop 1 value), False) - - readSectionMetaData [] = [] - readSectionMetaData (header:value) = - let key = substituteRegex "[^a-zA-Z0-9]" "" header - in [PageSection (key, unlines value, True)] - --- | Read a page from a file. Metadata is supported. --- -readPage :: FilePath -> Hakyll [PageSection] -readPage path = do - let sectionFunctions = map readSection $ True : repeat False - - -- Read file. - contents <- liftIO $ readFile path - url <- toUrl path - let sections = evalState (splitAtDelimiters $ lines contents) Nothing - sectionsData = concat $ zipWith ($) sectionFunctions sections - - -- Note that url, path etc. are listed first, which means can be overwritten - -- by section data - return $ PageSection ("url", url, False) - : PageSection ("path", path, False) - : PageSection ("title", takeBaseName path, False) - : (category ++ sectionsData) - where - category = let dirs = splitDirectories $ takeDirectory path - in [PageSection ("category", last dirs, False) | not (null dirs)] - --- | Read a page from a file. Metadata is supported. --- -readPageAction :: FilePath -> HakyllAction () [PageSection] -readPageAction path = HakyllAction - { actionDependencies = [path] - , actionUrl = Left $ toUrl path - , actionFunction = const $ readPage path - } diff --git a/src/Text/Hakyll/Paginate.hs b/src/Text/Hakyll/Paginate.hs deleted file mode 100644 index 04194ca..0000000 --- a/src/Text/Hakyll/Paginate.hs +++ /dev/null @@ -1,94 +0,0 @@ --- | Module aimed to paginate web pages. --- -module Text.Hakyll.Paginate - ( PaginateConfiguration (..) - , defaultPaginateConfiguration - , paginate - ) where - -import Control.Applicative ((<$>)) - -import Text.Hakyll.Context (Context) -import Text.Hakyll.CreateContext -import Text.Hakyll.HakyllAction -import Text.Hakyll.Util (link) - --- | A configuration for a pagination. --- -data PaginateConfiguration = PaginateConfiguration - { -- | Label for the link to the previous page. - previousLabel :: String - , -- | Label for the link to the next page. - nextLabel :: String - , -- | Label for the link to the first page. - firstLabel :: String - , -- | Label for the link to the last page. - lastLabel :: String - } - --- | A simple default configuration for pagination. --- -defaultPaginateConfiguration :: PaginateConfiguration -defaultPaginateConfiguration = PaginateConfiguration - { previousLabel = "Previous" - , nextLabel = "Next" - , firstLabel = "First" - , lastLabel = "Last" - } - --- | The most important function for pagination. This function operates on a --- list of @Context@s (the pages), and basically just adds fields to them --- by combining them with a custom page. --- --- The following metadata fields will be added: --- --- - @$previous@: A link to the previous page. --- --- - @$next@: A link to the next page. --- --- - @$first@: A link to the first page. --- --- - @$last@: A link to the last page. --- --- - @$index@: 1-based index of the current page. --- --- - @$length@: Total number of pages. --- --- When @$previous@ or @$next@ are not available, they will be just a label --- without a link. The same goes for when we are on the first or last page for --- @$first@ and @$last@. --- -paginate :: PaginateConfiguration - -> [HakyllAction () Context] - -> [HakyllAction () Context] -paginate configuration renderables = paginate' Nothing renderables (1 :: Int) - where - -- Create a link with a given label, taken from the configuration. - linkWithLabel f r = Right $ case actionUrl r of - Left l -> createSimpleHakyllAction $ - link (f configuration) . ("$root/" ++) <$> l - Right _ -> error "No link found for pagination." - - -- The main function that creates combined renderables by recursing over - -- the list of items. - paginate' _ [] _ = [] - paginate' maybePrev (x:xs) index = - let (previous, first) = case maybePrev of - (Just r) -> ( linkWithLabel previousLabel r - , linkWithLabel firstLabel (head renderables) ) - Nothing -> ( Left $ previousLabel configuration - , Left $ firstLabel configuration ) - (next, last') = case xs of - (n:_) -> ( linkWithLabel nextLabel n - , linkWithLabel lastLabel (last renderables) ) - [] -> ( Left $ nextLabel configuration - , Left $ lastLabel configuration ) - customPage = createCustomPage "" - [ ("previous", previous) - , ("next", next) - , ("first", first) - , ("last", last') - , ("index", Left $ show index) - , ("length", Left $ show $ length renderables) - ] - in (x `combine` customPage) : paginate' (Just x) xs (index + 1) diff --git a/src/Text/Hakyll/Pandoc.hs b/src/Text/Hakyll/Pandoc.hs deleted file mode 100644 index af4be62..0000000 --- a/src/Text/Hakyll/Pandoc.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | Module exporting a pandoc arrow --- -module Text.Hakyll.Pandoc - ( renderAction - , renderActionWith - ) where - -import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import Control.Arrow (second, (>>>), arr, (&&&)) - -import Text.Pandoc - -import Text.Hakyll.Internal.FileType -import Text.Hakyll.Page -import Text.Hakyll.HakyllMonad -import Text.Hakyll.HakyllAction -import Text.Hakyll.Context - --- | Reader function for plain text --- -readText :: ParserState -> String -> Pandoc -readText _ = Pandoc (Meta [] [] []) . return . Plain . return . Str - --- | Get a read function for a given extension. --- -readPandoc :: HakyllAction (FileType, String) Pandoc -readPandoc = createHakyllAction $ \(fileType, inp) -> do - parserState <- askHakyll pandocParserState - return $ readFunction fileType (readOptions parserState fileType) inp - where - readFunction ReStructuredText = readRST - readFunction LaTeX = readLaTeX - readFunction Markdown = readMarkdown - readFunction LiterateHaskellMarkdown = readMarkdown - readFunction Html = readHtml - readFunction Text = readText - readFunction t = error $ "Cannot render " ++ show t - - readOptions options LiterateHaskellMarkdown = options - { stateLiterateHaskell = True } - readOptions options _ = options - --- | Get a render function for a given extension. --- -getRenderFunction :: HakyllAction FileType (String -> String) -getRenderFunction = createHakyllAction $ \fileType -> case fileType of - Html -> return id - Text -> return id - UnknownFileType -> return id - _ -> do parserState <- askHakyll pandocParserState - writerOptions <- askHakyll pandocWriterOptions - return $ writeHtmlString writerOptions - . readFunction fileType (readOptions parserState fileType) - where - readFunction ReStructuredText = readRST - readFunction LaTeX = readLaTeX - readFunction Markdown = readMarkdown - readFunction LiterateHaskellMarkdown = readMarkdown - readFunction t = error $ "Cannot render " ++ show t - - readOptions options LiterateHaskellMarkdown = options - { stateLiterateHaskell = True } - readOptions options _ = options - --- | Get a render action --- -renderPandoc :: HakyllAction Pandoc String -renderPandoc = createHakyllAction $ \p -> do - writerOptions <- askHakyll pandocWriterOptions - return $ writeHtmlString writerOptions p - --- | An action that renders the list of page sections to a context using pandoc --- -renderAction :: HakyllAction [PageSection] Context -renderAction = (arr id &&& (getFileType' >>> getRenderFunction)) - >>> renderActionWith - where - getFileType' = arr $ getFileType . fromMaybe "unknown" . lookup "path" - . map (\(x, y, _) -> (x, y)) . map unPageSection - --- | An action to render pages, offering just a little more flexibility --- -renderActionWith :: HakyllAction ([PageSection], String -> String) Context -renderActionWith = createHakyllAction $ \(sections, render') -> return $ - Context $ M.fromList $ map (renderTriple render' . unPageSection) sections - where - renderTriple render' (k, v, r) = second (if r then render' else id) (k, v) diff --git a/src/Text/Hakyll/Regex.hs b/src/Text/Hakyll/Regex.hs deleted file mode 100644 index ba7ee46..0000000 --- a/src/Text/Hakyll/Regex.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | A module that exports a simple regex interface. This code is mostly copied --- from the regex-compat package at hackage. I decided to write this module --- because I want to abstract the regex package used. -module Text.Hakyll.Regex - ( splitRegex - , substituteRegex - , matchesRegex - ) where - -import Text.Regex.TDFA - --- | Match a regular expression against a string, returning more information --- about the match. -matchRegexAll :: Regex -> String -> Maybe (String, String, String, [String]) -matchRegexAll = matchM - --- | Replaces every occurance of the given regexp with the replacement string. -subRegex :: Regex -- ^ Search pattern - -> String -- ^ Input string - -> String -- ^ Replacement text - -> String -- ^ Output string -subRegex _ "" _ = "" -subRegex regexp inp replacement = - let -- bre matches a backslash then capture either a backslash or some digits - bre = makeRegex "\\\\(\\\\|[0-9]+)" - lookup' _ [] _ = [] - lookup' [] _ _ = [] - lookup' match' repl groups = - case matchRegexAll bre repl of - Nothing -> repl - Just (lead, _, trail, bgroups) -> - let newval = - if head bgroups == "\\" - then "\\" - else let index :: Int - index = read (head bgroups) - 1 - in if index == -1 - then match' - else groups !! index - in lead ++ newval ++ lookup' match' trail groups - in case matchRegexAll regexp inp of - Nothing -> inp - Just (lead, match', trail, groups) -> - lead ++ lookup' match' replacement groups - ++ subRegex regexp trail replacement - --- | Splits a string based on a regular expression. The regular expression --- should identify one delimiter. -splitRegex' :: Regex -> String -> [String] -splitRegex' _ [] = [] -splitRegex' delim strIn = loop strIn where - loop str = case matchOnceText delim str of - Nothing -> [str] - Just (firstline, _, remainder) -> - if null remainder - then [firstline,""] - else firstline : loop remainder - --- | Split a list at a certain element. -splitRegex :: String -> String -> [String] -splitRegex pattern = filter (not . null) - . splitRegex' (makeRegex pattern) - --- | Substitute a regex. Simplified interface. This function performs a global --- substitution. -substituteRegex :: String -- ^ Pattern to replace (regex). - -> String -- ^ Replacement string. - -> String -- ^ Input string. - -> String -- ^ Result. -substituteRegex pattern replacement string = - subRegex (makeRegex pattern) string replacement - --- | Simple regex matching. -matchesRegex :: String -- ^ Input string. - -> String -- ^ Pattern to match. - -> Bool -matchesRegex = (=~) diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs deleted file mode 100644 index aa3ef8c..0000000 --- a/src/Text/Hakyll/Render.hs +++ /dev/null @@ -1,126 +0,0 @@ --- | Module containing rendering functions. All these functions are used to --- render files to the @_site@ directory. -module Text.Hakyll.Render - ( render - , renderAndConcat - , renderChain - , static - , css - , writePage - ) where - -import Control.Arrow ((>>>)) -import Control.Applicative ((<$>)) -import Control.Monad.Reader (liftIO) -import System.Directory (copyFile) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, getAdditionalContext) -import Text.Hakyll.File -import Text.Hakyll.HakyllAction -import Text.Hakyll.ContextManipulations -import Text.Hakyll.Internal.CompressCss -import Text.Hakyll.Internal.Template - --- | A pure render function - used internally. -pureRender :: Template -- ^ Template to use for rendering. - -> Context -- ^ Renderable object to render with given template. - -> Context -- ^ The body of the result will contain the render. -pureRender template (Context c) = - -- Ignore $root when substituting here. We will only replace that in the - -- final render (just before writing). - let contextIgnoringRoot = Context $ M.insert "root" "$root" c - body = regularSubstitute template $ contextIgnoringRoot - in Context $ M.insert "body" body c - --- | This is the most simple render action. You render a @Context@ with a --- template, and get back the result. -render :: FilePath -- ^ Template to use for rendering. - -> HakyllAction Context Context -- ^ The render computation. -render templatePath = HakyllAction - { actionDependencies = [templatePath] - , actionUrl = Right id - , actionFunction = \context -> - flip pureRender context <$> readTemplate templatePath - } - --- | Render each @Context@ with the given templates, then concatenate the --- result. So, basically this function: --- --- - Takes every @Context@. --- --- - Renders every @Context@ with all given templates. This is comparable --- with a renderChain action. --- --- - Concatenates the result and returns that as a @String@. -renderAndConcat :: [FilePath] - -> [HakyllAction () Context] - -> HakyllAction () String -renderAndConcat templatePaths renderables = HakyllAction - { actionDependencies = renders >>= actionDependencies - , actionUrl = Right id - , actionFunction = actionFunction' - } - where - render' = chain (map render templatePaths) - renders = map (>>> render') renderables - - actionFunction' _ = do - contexts <- mapM (runHakyllAction . (>>> takeBody)) renders - return $ concat contexts - --- | Chain a render action for a page with a number of templates. This will --- also write the result to the site destination. This is the preferred way --- to do general rendering. --- --- > renderChain [ "templates/notice.html" --- > , "templates/default.html" --- > ] $ createPagePath "warning.html" --- --- This code will first render @warning.html@ using @templates/notice.html@, --- and will then render the result with @templates/default.html@. -renderChain :: [FilePath] - -> HakyllAction () Context - -> Hakyll () -renderChain templatePaths initial = - runHakyllActionIfNeeded renderChainWith' - where - renderChainWith' = initial >>> chain' >>> writePage - chain' = chain $ map render templatePaths - --- | Mark a certain file as static, so it will just be copied when the site is --- generated. -static :: FilePath -> Hakyll () -static source = runHakyllActionIfNeeded static' - where - static' = createFileHakyllAction source $ do - destination <- toDestination source - makeDirectories destination - liftIO $ copyFile source destination - --- | Render a css file, compressing it. -css :: FilePath -> Hakyll () -css source = runHakyllActionIfNeeded css' - where - css' = createFileHakyllAction source $ do - contents <- liftIO $ readFile source - destination <- toDestination source - makeDirectories destination - liftIO $ writeFile destination (compressCss contents) - --- | Write a page to the site destination. Final action after render --- chains and such. -writePage :: HakyllAction Context () -writePage = createHakyllAction $ \(Context initialContext) -> do - additionalContext' <- unContext <$> askHakyll getAdditionalContext - let url = fromMaybe (error "No url defined at write time.") - (M.lookup "url" initialContext) - body = fromMaybe "" (M.lookup "body" initialContext) - let context = additionalContext' `M.union` M.singleton "root" (toRoot url) - destination <- toDestination url - makeDirectories destination - -- Substitute $root here, just before writing. - liftIO $ writeFile destination $ finalSubstitute (fromString body) - (Context context) diff --git a/src/Text/Hakyll/Resource.hs b/src/Text/Hakyll/Resource.hs deleted file mode 100644 index b0ffb8c..0000000 --- a/src/Text/Hakyll/Resource.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | A resource represents data for a website --- -module Text.Hakyll.Resource - ( Metadata (..) - , Resource (..) - , getData - , getMetadata - ) where - -import Data.Monoid (Monoid, mempty, mappend) -import Control.Applicative (Applicative, (<*>), pure) -import Data.Map (Map) -import qualified Data.Map as M - --- | Metadata for a resource --- -newtype Metadata = Metadata {unMetadata :: Map String String} - deriving (Show, Eq, Ord) - -instance Monoid Metadata where - mempty = Metadata M.empty - (Metadata m1) `mappend` (Metadata m2) = Metadata $ m1 `M.union` m2 - --- | A resource represents a data source for the website. It contains a value --- and a number of metadata fields --- -data Resource a = Resource - { resourceMetadata :: Metadata - , resourceData :: a - } deriving (Show, Eq, Ord) - -instance Functor Resource where - fmap f (Resource m d) = Resource m $ f d - -instance Applicative Resource where - pure d = Resource mempty d - (Resource m1 f) <*> (Resource m2 d) = Resource (mappend m2 m1) (f d) - -instance Monad Resource where - return d = Resource mempty d - (Resource m1 d) >>= f = let Resource m2 d' = f d - in Resource (mappend m2 m1) d' - -instance Monoid a => Monoid (Resource a) where - mempty = Resource mempty mempty - mappend (Resource m1 d1) (Resource m2 d2) = - Resource (mappend m1 m2) (mappend d1 d2) - --- | Get the data from a resource --- -getData :: Resource a -> a -getData = resourceData - --- | Get a metadata field from a resource --- -getMetadata :: String -> Resource a -> Maybe String -getMetadata k (Resource m _) = M.lookup k $ unMetadata m diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs deleted file mode 100644 index a4559ca..0000000 --- a/src/Text/Hakyll/Tags.hs +++ /dev/null @@ -1,172 +0,0 @@ --- | Module containing some specialized functions to deal with tags. --- This Module follows certain conventions. Stick with them. --- --- More concrete: all functions in this module assume that the tags are --- located in the @tags@ field, and separated by commas. An example file --- @foo.markdown@ could look like: --- --- > --- --- > author: Philip K. Dick --- > title: Do androids dream of electric sheep? --- > tags: future, science fiction, humanoid --- > --- --- > The novel is set in a post-apocalyptic near future, where the Earth and --- > its populations have been damaged greatly by Nuclear... --- --- All the following functions would work with such a format. In addition to --- tags, Hakyll also supports categories. The convention when using categories --- is to place pages in subdirectories. --- --- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@ --- Tags or categories are read using the @readTagMap@ and @readCategoryMap@ --- functions. Because categories are implemented using tags - categories can --- be seen as tags, with the restriction that a page can only have one --- category - all functions for tags also work with categories. --- --- When reading a @TagMap@ (which is also used for category maps) using the --- @readTagMap@ or @readCategoryMap@ function, you also have to give a unique --- identifier to it. This identifier is simply for caching reasons, so Hakyll --- can tell different maps apart; it has no other use. --- -module Text.Hakyll.Tags - ( TagMap - , readTagMap - , readCategoryMap - , withTagMap - , renderTagCloud - , renderTagLinks - ) where - -import qualified Data.Map as M -import Data.List (intercalate) -import Data.Maybe (fromMaybe, maybeToList) -import Control.Arrow (second, (>>>)) -import Control.Applicative ((<$>)) -import System.FilePath - -import Text.Blaze.Renderer.String (renderHtml) -import Text.Blaze.Html5 ((!), string, stringValue) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.ContextManipulations (changeValue) -import Text.Hakyll.CreateContext (createPage) -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.Regex -import Text.Hakyll.HakyllAction -import Text.Hakyll.Util -import Text.Hakyll.Internal.Cache - --- | Type for a tag map. --- --- This is a map associating tags or categories to the appropriate pages --- using that tag or category. In the case of categories, each path will only --- appear under one category - this is not the case with tags. -type TagMap = M.Map String [HakyllAction () Context] - --- | Read a tag map. This is a internally used function that can be used for --- tags as well as for categories. -readMap :: (Context -> [String]) -- ^ Function to get tags from a context. - -> String -- ^ Unique identifier for the tagmap. - -> [FilePath] - -> HakyllAction () TagMap -readMap getTagsFunction identifier paths = HakyllAction - { actionDependencies = paths - , actionUrl = Right id - , actionFunction = actionFunction' - } - where - fileName = "tagmaps" identifier - - actionFunction' _ = do - isCacheMoreRecent' <- isCacheMoreRecent fileName paths - assocMap <- if isCacheMoreRecent' - then M.fromAscList <$> getFromCache fileName - else do assocMap' <- readTagMap' - storeInCache (M.toAscList assocMap') fileName - return assocMap' - return $ M.map (map createPage) assocMap - - -- TODO: preserve order - readTagMap' :: Hakyll (M.Map String [FilePath]) - readTagMap' = do - pairs' <- concat <$> mapM pairs paths - return $ M.fromListWith (flip (++)) pairs' - - -- | Read a page, and return an association list where every tag is - -- associated with some paths. Of course, this will always be just one - -- @FilePath@ here. - pairs :: FilePath -> Hakyll [(String, [FilePath])] - pairs path = do - context <- runHakyllAction $ createPage path - let tags = getTagsFunction context - return $ map (\tag -> (tag, [path])) tags - --- | Read a @TagMap@, using the @tags@ metadata field. -readTagMap :: String -- ^ Unique identifier for the map. - -> [FilePath] -- ^ Paths to get tags from. - -> HakyllAction () TagMap -readTagMap = readMap getTagsFunction - where - getTagsFunction = map trim . splitRegex "," - . fromMaybe [] . M.lookup "tags" . unContext - --- | Read a @TagMap@, using the subdirectories the pages are placed in. -readCategoryMap :: String -- ^ Unique identifier for the map. - -> [FilePath] -- ^ Paths to get tags from. - -> HakyllAction () TagMap -readCategoryMap = readMap $ maybeToList . M.lookup "category" . unContext - --- | Perform a @Hakyll@ action on every item in the tag --- -withTagMap :: HakyllAction () TagMap - -> (String -> [HakyllAction () Context] -> Hakyll ()) - -> Hakyll () -withTagMap tagMap function = runHakyllAction (tagMap >>> action) - where - action = createHakyllAction (mapM_ (uncurry function) . M.toList) - --- | Render a tag cloud. -renderTagCloud :: (String -> String) -- ^ Function to produce an url for a tag. - -> Float -- ^ Smallest font size, in percent. - -> Float -- ^ Biggest font size, in percent. - -> HakyllAction TagMap String -renderTagCloud urlFunction minSize maxSize = createHakyllAction renderTagCloud' - where - renderTagCloud' tagMap = - return $ intercalate " " $ map (renderTag tagMap) (tagCount tagMap) - - renderTag tagMap (tag, count) = renderHtml $ - H.a ! A.style (stringValue $ "font-size: " ++ sizeTag tagMap count) - ! A.href (stringValue $ urlFunction tag) - $ string tag - - sizeTag tagMap count = show (size' :: Int) ++ "%" - where - size' = floor $ minSize + relative tagMap count * (maxSize - minSize) - - minCount = minimum . map snd . tagCount - maxCount = maximum . map snd . tagCount - relative tagMap count = (count - minCount tagMap) / - (maxCount tagMap - minCount tagMap) - - tagCount = map (second $ fromIntegral . length) . M.toList - --- | Render all tags to links. --- --- On your site, it is nice if you can display the tags on a page, but --- naturally, most people would expect these are clickable. --- --- So, this function takes a function to produce an url for a given tag, and --- applies it on all tags. --- --- Note that it is your own responsibility to ensure a page with such an url --- exists. -renderTagLinks :: (String -> String) -- ^ Function to produce an url for a tag. - -> HakyllAction Context Context -renderTagLinks urlFunction = changeValue "tags" renderTagLinks' - where - renderTagLinks' = intercalate ", " - . map ((\t -> link t $ urlFunction t) . trim) - . splitRegex "," diff --git a/src/Text/Hakyll/Transformer.hs b/src/Text/Hakyll/Transformer.hs deleted file mode 100644 index 669e1d0..0000000 --- a/src/Text/Hakyll/Transformer.hs +++ /dev/null @@ -1,107 +0,0 @@ --- | This is the module which exports @Transformer@. -module Text.Hakyll.Transformer - ( Transformer (..) - , transformResource - , transformResourceM - , transformData - , transformDataM - , transformMetadata - , transformMetadataM - , runTransformer - , runTransformerForced - ) where - -import Data.Monoid (Monoid, mappend, mempty) -import Control.Arrow -import Control.Category -import Control.Applicative ((<$>)) -import Control.Monad ((<=<), unless, liftM2) -import Prelude hiding ((.), id) - -import Text.Hakyll.Resource -import Text.Hakyll.File (toDestination, isFileMoreRecent) -import Text.Hakyll.Monad - --- | Type used for computations that transform resources, carrying along --- dependencies. --- -data Transformer a b = Transformer - { -- | Dependencies of the @Transformer@. - transformerDependencies :: [FilePath] - , -- | URL pointing to the result of this @Transformer@. - transformerUrl :: FilePath -> Hakyll FilePath - , -- | The actual transforming function. - transformerFunction :: Resource a -> Hakyll (Resource b) - } - -instance Monoid b => Monoid (Transformer a b) where - mempty = arr (const mempty) - mappend x y = Transformer - { transformerDependencies = - transformerDependencies x ++ transformerDependencies y - , transformerUrl = transformerUrl x - , transformerFunction = \r -> - liftM2 mappend (transformerFunction x r) (transformerFunction y r) - } - -instance Category Transformer where - id = Transformer - { transformerDependencies = [] - , transformerUrl = return - , transformerFunction = return - } - - x . y = Transformer - { transformerDependencies = - transformerDependencies x ++ transformerDependencies y - , transformerUrl = transformerUrl y <=< transformerUrl x - , transformerFunction = transformerFunction x <=< transformerFunction y - } - -instance Arrow Transformer where - arr = transformData - - first t = t - { transformerFunction = \(Resource m (x, y)) -> do - Resource m' x' <- transformerFunction t $ Resource m x - return $ Resource (mappend m' m) (x', y) - } - -transformResource :: (Resource a -> Resource b) -> Transformer a b -transformResource = transformResourceM . (return .) - -transformResourceM :: (Resource a -> Hakyll (Resource b)) -> Transformer a b -transformResourceM f = id {transformerFunction = f} - -transformData :: (a -> b) -> Transformer a b -transformData = transformResource . fmap - -transformDataM :: (a -> Hakyll b) -> Transformer a b -transformDataM f = transformResourceM $ \(Resource m x) -> - f x >>= return . Resource m - -transformMetadata :: (Metadata -> Metadata) -> Transformer a a -transformMetadata = transformMetadataM . (return .) - -transformMetadataM :: (Metadata -> Hakyll Metadata) -> Transformer a a -transformMetadataM f = transformResourceM $ \(Resource m x) -> do - m' <- f m - return $ Resource m' x - --- | Run a transformer. This might not run it when the result is up-to-date --- -runTransformer :: Transformer () () - -> Hakyll () -runTransformer t = do - url <- transformerUrl t $ - error "runTransformer: No url when checking dependencies." - destination <- toDestination url - valid <- isFileMoreRecent destination $ transformerDependencies t - unless valid $ do logHakyll $ "Rendering " ++ destination - runTransformerForced t - --- | Always run the transformer, even when the target is up-to-date --- -runTransformerForced :: Transformer () () - -> Hakyll () -runTransformerForced t = getData <$> transformerFunction t mempty diff --git a/src/Text/Hakyll/Util.hs b/src/Text/Hakyll/Util.hs deleted file mode 100644 index e032c52..0000000 --- a/src/Text/Hakyll/Util.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Miscellaneous text manipulation functions. -module Text.Hakyll.Util - ( trim - , stripHtml - , link - ) where - -import Data.Char (isSpace) - -import Text.Blaze.Html5 ((!), string, stringValue, a) -import Text.Blaze.Html5.Attributes (href) -import Text.Blaze.Renderer.String (renderHtml) - --- | Trim a string (drop spaces, tabs and newlines at both sides). -trim :: String -> String -trim = reverse . trim' . reverse . trim' - where - trim' = dropWhile isSpace - --- | Strip html tags from the given string. -stripHtml :: String -> String -stripHtml [] = [] -stripHtml str = let (beforeTag, rest) = break (== '<') str - (_, afterTag) = break (== '>') rest - in beforeTag ++ stripHtml (drop 1 afterTag) - --- | Make a HTML link. --- --- > link "foo" "bar.html" == "foo" -link :: String -- ^ Link text. - -> String -- ^ Link destination. - -> String -link text destination = renderHtml $ a ! href (stringValue destination) - $ string text -- cgit v1.2.3 From ad6712121ffc3e41f6bd2a9833267252315b6f65 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 14:31:45 +0100 Subject: Add directed graph modules --- src/Hakyll/Core/DirectedGraph.hs | 87 +++++++++++++++++++++++ src/Hakyll/Core/DirectedGraph/DependencySolver.hs | 68 ++++++++++++++++++ src/Hakyll/Core/DirectedGraph/Internal.hs | 39 ++++++++++ src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs | 25 +++++++ 4 files changed, 219 insertions(+) create mode 100644 src/Hakyll/Core/DirectedGraph.hs create mode 100644 src/Hakyll/Core/DirectedGraph/DependencySolver.hs create mode 100644 src/Hakyll/Core/DirectedGraph/Internal.hs create mode 100644 src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs (limited to 'src') diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs new file mode 100644 index 0000000..6dc6ae5 --- /dev/null +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -0,0 +1,87 @@ +-- | Representation of a directed graph. In Hakyll, this is used for dependency +-- tracking. +-- +module Hakyll.Core.DirectedGraph + ( DirectedGraph + , fromList + , neighbours + , reverse + , filter + , reachableNodes + ) where + +import Prelude hiding (reverse, filter) +import Data.Monoid (mconcat) +import Data.Set (Set) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M +import qualified Data.Set as S + +import Hakyll.Core.DirectedGraph.Internal + +-- | Construction of directed graphs +-- +fromList :: Ord a + => [(a, Set a)] -- ^ List of (node, reachable neighbours) + -> DirectedGraph a -- ^ Resulting directed graph +fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d)) + +-- | Get a set of reachable neighbours from a directed graph +-- +neighbours :: Ord a + => a -- ^ Node to get the neighbours of + -> DirectedGraph a -- ^ Graph to search in + -> Set a -- ^ Set containing the neighbours +neighbours x = fromMaybe S.empty . fmap nodeNeighbours + . M.lookup x . unDirectedGraph + +-- | Reverse a directed graph (i.e. flip all edges) +-- +reverse :: Ord a + => DirectedGraph a + -> DirectedGraph a +reverse = mconcat . map reverse' . M.toList . unDirectedGraph + where + reverse' (id', Node _ neighbours') = fromList $ + zip (S.toList neighbours') $ repeat $ S.singleton id' + +-- | Filter a directed graph (i.e. remove nodes based on a predicate) +-- +filter :: Ord a + => (a -> Bool) -- ^ Predicate + -> DirectedGraph a -- ^ Graph + -> DirectedGraph a -- ^ Resulting graph +filter predicate = + DirectedGraph . M.filterWithKey (\k _ -> predicate k) . unDirectedGraph + +-- | Find all reachable nodes from a given node in the directed graph +-- +reachableNodes :: Ord a => a -> DirectedGraph a -> Set a +reachableNodes x graph = reachable (neighbours x graph) (S.singleton x) + where + reachable next visited + | S.null next = visited + | otherwise = reachable (sanitize neighbours') (next `S.union` visited) + where + sanitize = S.filter (`S.notMember` visited) + neighbours' = S.unions $ map (flip neighbours graph) + $ S.toList $ sanitize next + +{- +exampleGraph :: DirectedGraph Int +exampleGraph = fromList + [ makeNode 8 [2, 4, 6] + , makeNode 2 [4, 3] + , makeNode 4 [3] + , makeNode 6 [4] + , makeNode 3 [] + ] + where + makeNode tag deps = (tag, S.fromList deps) + +cyclic :: DirectedGraph Int +cyclic = fromList + [ (1, S.fromList [2]) + , (2, S.fromList [1, 3]) + ] +-} diff --git a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs new file mode 100644 index 0000000..dce59e0 --- /dev/null +++ b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs @@ -0,0 +1,68 @@ +-- | Given a dependency graph, this module provides a function that will +-- generate an order in which the graph can be visited, so that all the +-- dependencies of a given node have been visited before the node itself is +-- visited. +-- +module Hakyll.Core.DirectedGraph.DependencySolver + ( solveDependencies + ) where + +import Prelude +import qualified Prelude as P +import Data.Set (Set) +import Data.Maybe (catMaybes) +import qualified Data.Map as M +import qualified Data.Set as S + +import Hakyll.Core.DirectedGraph +import qualified Hakyll.Core.DirectedGraph as DG +import Hakyll.Core.DirectedGraph.Internal + +-- | Solve a dependency graph. This function returns an order to run the +-- different nodes +-- +solveDependencies :: Ord a + => DirectedGraph a -- ^ Graph + -> [a] -- ^ Resulting plan +solveDependencies = P.reverse . order [] [] S.empty + +-- | Produce a reversed order using a stack +-- +order :: Ord a + => [a] -- ^ Temporary result + -> [Node a] -- ^ Backtrace stack + -> Set a -- ^ Items in the stack + -> DirectedGraph a -- ^ Graph + -> [a] -- ^ Ordered result +order temp stack set graph@(DirectedGraph graph') + -- Empty graph - return our current result + | M.null graph' = temp + | otherwise = case stack of + + -- Empty stack - pick a node, and add it to the stack + [] -> + let (tag, node) = M.findMin graph' + in order temp (node : stack) (S.insert tag set) graph + + -- At least one item on the stack - continue using this item + (node : stackTail) -> + -- Check which dependencies are still in the graph + let tag = nodeTag node + deps = S.toList $ nodeNeighbours node + unsatisfied = catMaybes $ map (flip M.lookup graph') deps + in case unsatisfied of + + -- All dependencies for node are satisfied, we can return it and + -- remove it from the graph + [] -> order (tag : temp) stackTail (S.delete tag set) + (DG.filter (== tag) graph) + + -- There is at least one dependency left. We need to solve that + -- one first... + (dep : _) -> if (nodeTag dep) `S.member` set + -- The dependency is already in our stack - cycle detected! + then error "order: Cycle detected!" -- TODO: Dump cycle + -- Continue with the dependency + else order temp (dep : node : stackTail) + (S.insert (nodeTag dep) set) + graph diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs new file mode 100644 index 0000000..9890fc0 --- /dev/null +++ b/src/Hakyll/Core/DirectedGraph/Internal.hs @@ -0,0 +1,39 @@ +-- | Internal structure of the DirectedGraph type. Not exported in the library. +-- +module Hakyll.Core.DirectedGraph.Internal + ( Node (..) + , DirectedGraph (..) + ) where + +import Prelude hiding (reverse, filter) +import Data.Monoid (Monoid, mempty, mappend) +import Data.Set (Set) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S + +-- | A node in the directed graph +-- +data Node a = Node + { nodeTag :: a -- ^ Tag identifying the node + , nodeNeighbours :: (Set a) -- ^ Edges starting at this node + } deriving (Show) + +-- | Append two nodes. Useful for joining graphs. +-- +appendNodes :: Ord a => Node a -> Node a -> Node a +appendNodes (Node t1 n1) (Node t2 n2) + | t1 /= t2 = error "appendNodes: Appending differently tagged nodes" + | otherwise = Node t1 (n1 `S.union` n2) + +-- | Type used to represent a directed graph +-- +newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a (Node a)} + deriving (Show) + +-- | Allow users to concatenate different graphs +-- +instance Ord a => Monoid (DirectedGraph a) where + mempty = DirectedGraph M.empty + mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $ + M.unionWith appendNodes m1 m2 diff --git a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs new file mode 100644 index 0000000..a3bc57a --- /dev/null +++ b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs @@ -0,0 +1,25 @@ +-- | Module exporting a function that works as a filter on a dependency graph. +-- Given a list of obsolete nodes, this filter will reduce the graph so it only +-- contains obsolete nodes and nodes that depend (directly or indirectly) on +-- obsolete nodes. +-- +module Hakyll.Core.DirectedGraph.ObsoleteFilter + ( obsoleteFilter + ) where + +import qualified Data.Set as S + +import Hakyll.Core.DirectedGraph +import qualified Hakyll.Core.DirectedGraph as DG + +-- | Given a list of obsolete items, filter the dependency graph so it only +-- contains these items +-- +obsoleteFilter :: Ord a + => [a] -- ^ List of obsolete items + -> DirectedGraph a -- ^ Dependency graph + -> DirectedGraph a -- ^ Resulting dependency graph +obsoleteFilter obsolete graph = + let reversed = DG.reverse graph + allObsolete = S.unions $ map (flip reachableNodes reversed) obsolete + in DG.filter (`S.member` allObsolete) graph -- cgit v1.2.3 From d1d28b9349549297f89ade80616eb7b14083e600 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 14:51:38 +0100 Subject: Add tests for the directed graph modules --- src/Hakyll/Core/DirectedGraph.hs | 27 ++++--------- src/Hakyll/Core/DirectedGraph/DependencySolver.hs | 3 +- src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs | 6 +-- tests/Hakyll/Core/DirectedGraph/Tests.hs | 48 +++++++++++++++++++++++ tests/TestSuite.hs | 11 ++++++ 5 files changed, 71 insertions(+), 24 deletions(-) create mode 100644 tests/Hakyll/Core/DirectedGraph/Tests.hs create mode 100644 tests/TestSuite.hs (limited to 'src') diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs index 6dc6ae5..b24ce25 100644 --- a/src/Hakyll/Core/DirectedGraph.hs +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -4,6 +4,7 @@ module Hakyll.Core.DirectedGraph ( DirectedGraph , fromList + , nodes , neighbours , reverse , filter @@ -26,6 +27,13 @@ fromList :: Ord a -> DirectedGraph a -- ^ Resulting directed graph fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d)) +-- | Get all nodes in the graph +-- +nodes :: Ord a + => DirectedGraph a -- ^ Graph to get the nodes from + -> Set a -- ^ All nodes in the graph +nodes = M.keysSet . unDirectedGraph + -- | Get a set of reachable neighbours from a directed graph -- neighbours :: Ord a @@ -66,22 +74,3 @@ reachableNodes x graph = reachable (neighbours x graph) (S.singleton x) sanitize = S.filter (`S.notMember` visited) neighbours' = S.unions $ map (flip neighbours graph) $ S.toList $ sanitize next - -{- -exampleGraph :: DirectedGraph Int -exampleGraph = fromList - [ makeNode 8 [2, 4, 6] - , makeNode 2 [4, 3] - , makeNode 4 [3] - , makeNode 6 [4] - , makeNode 3 [] - ] - where - makeNode tag deps = (tag, S.fromList deps) - -cyclic :: DirectedGraph Int -cyclic = fromList - [ (1, S.fromList [2]) - , (2, S.fromList [1, 3]) - ] --} diff --git a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs index dce59e0..17a4b69 100644 --- a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs +++ b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs @@ -15,7 +15,6 @@ import qualified Data.Map as M import qualified Data.Set as S import Hakyll.Core.DirectedGraph -import qualified Hakyll.Core.DirectedGraph as DG import Hakyll.Core.DirectedGraph.Internal -- | Solve a dependency graph. This function returns an order to run the @@ -55,7 +54,7 @@ order temp stack set graph@(DirectedGraph graph') -- All dependencies for node are satisfied, we can return it and -- remove it from the graph [] -> order (tag : temp) stackTail (S.delete tag set) - (DG.filter (== tag) graph) + (DirectedGraph $ M.delete tag graph') -- There is at least one dependency left. We need to solve that -- one first... diff --git a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs index a3bc57a..f781819 100644 --- a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs +++ b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs @@ -4,7 +4,7 @@ -- obsolete nodes. -- module Hakyll.Core.DirectedGraph.ObsoleteFilter - ( obsoleteFilter + ( filterObsolete ) where import qualified Data.Set as S @@ -15,11 +15,11 @@ import qualified Hakyll.Core.DirectedGraph as DG -- | Given a list of obsolete items, filter the dependency graph so it only -- contains these items -- -obsoleteFilter :: Ord a +filterObsolete :: Ord a => [a] -- ^ List of obsolete items -> DirectedGraph a -- ^ Dependency graph -> DirectedGraph a -- ^ Resulting dependency graph -obsoleteFilter obsolete graph = +filterObsolete obsolete graph = let reversed = DG.reverse graph allObsolete = S.unions $ map (flip reachableNodes reversed) obsolete in DG.filter (`S.member` allObsolete) graph diff --git a/tests/Hakyll/Core/DirectedGraph/Tests.hs b/tests/Hakyll/Core/DirectedGraph/Tests.hs new file mode 100644 index 0000000..4ce5944 --- /dev/null +++ b/tests/Hakyll/Core/DirectedGraph/Tests.hs @@ -0,0 +1,48 @@ +module Hakyll.Core.DirectedGraph.Tests + ( tests + ) where + +import Data.Set (Set) +import qualified Data.Set as S + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Hakyll.Core.DirectedGraph +import Hakyll.Core.DirectedGraph.DependencySolver +import Hakyll.Core.DirectedGraph.ObsoleteFilter + +tests :: [Test] +tests = + [ testCase "solveDependencies01" solveDependencies01 + , testCase "filterObsolete01" filterObsolete01 + , testCase "filterObsolete02" filterObsolete02 + ] + +node :: Ord a => a -> [a] -> (a, Set a) +node t n = (t, S.fromList n) + +testGraph01 :: DirectedGraph Int +testGraph01 = fromList + [ node 8 [2, 4, 6] + , node 2 [4, 3] + , node 4 [3] + , node 6 [4] + , node 3 [] + ] + +solveDependencies01 :: Assertion +solveDependencies01 = result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8] + @? "solveDependencies01" + where + result = solveDependencies testGraph01 + +filterObsolete01 :: Assertion +filterObsolete01 = nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8] + @? "filterObsolete01" + +filterObsolete02 :: Assertion +filterObsolete02 = + nodes (filterObsolete [4] testGraph01) == S.fromList [4, 2, 6, 8] + @? "filterObsolete02" diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 index 0000000..26b26f0 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,11 @@ +module TestSuite where + +import Test.Framework (defaultMain, testGroup) + +import qualified Hakyll.Core.DirectedGraph.Tests + +main :: IO () +main = defaultMain + [ testGroup "Hakyll.Core.DirectedGraph.Tests" + Hakyll.Core.DirectedGraph.Tests.tests + ] -- cgit v1.2.3 From 3fdf8ab204cfc6f60a250b8ef0cccce8e82a4bcf Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 17:19:21 +0100 Subject: Add identifier/pattern modules --- src/Hakyll/Core/Identifier.hs | 47 +++++++++++++++++ src/Hakyll/Core/Identifier/Pattern.hs | 91 ++++++++++++++++++++++++++++++++ tests/Hakyll/Core/DirectedGraph/Tests.hs | 24 ++++----- tests/Hakyll/Core/Identifier/Tests.hs | 29 ++++++++++ tests/TestSuite.hs | 3 ++ 5 files changed, 182 insertions(+), 12 deletions(-) create mode 100644 src/Hakyll/Core/Identifier.hs create mode 100644 src/Hakyll/Core/Identifier/Pattern.hs create mode 100644 tests/Hakyll/Core/Identifier/Tests.hs (limited to 'src') diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs new file mode 100644 index 0000000..609e722 --- /dev/null +++ b/src/Hakyll/Core/Identifier.hs @@ -0,0 +1,47 @@ +-- | An identifier is a type used to uniquely identify a resource, target... +-- +-- One can think of an identifier as something similar to a file path. An +-- identifier is a path as well, with the different elements in the path +-- separated by @/@ characters. Examples of identifiers are: +-- +-- * @posts/foo.markdown@ +-- +-- * @index@ +-- +-- * @error/404@ +-- +module Hakyll.Core.Identifier + ( Identifier (..) + , parseIdentifier + , toFilePath + ) where + +import Control.Arrow (second) + +import GHC.Exts (IsString, fromString) +import System.FilePath (joinPath) + +-- | An identifier used to uniquely identify a value +-- +newtype Identifier = Identifier {unIdentifier :: [String]} + deriving (Eq, Ord) + +instance Show Identifier where + show = toFilePath + +instance IsString Identifier where + fromString = parseIdentifier + +-- | Parse an identifier from a string +-- +parseIdentifier :: String -> Identifier +parseIdentifier = Identifier . filter (not . null) . split' + where + split' [] = [[]] + split' str = let (pre, post) = second (drop 1) $ break (== '/') str + in pre : split' post + +-- | Convert an identifier to a relative 'FilePath' +-- +toFilePath :: Identifier -> FilePath +toFilePath = joinPath . unIdentifier diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs new file mode 100644 index 0000000..02b023f --- /dev/null +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -0,0 +1,91 @@ +-- | Module providing pattern matching and capturing on 'Identifier's. +-- +-- TODO: Documentation +-- +module Hakyll.Core.Identifier.Pattern + ( Pattern + , parsePattern + , match + , doesMatch + , matches + ) where + +import Data.List (intercalate) +import Control.Monad (msum) +import Data.Maybe (isJust) + +import GHC.Exts (IsString, fromString) + +import Hakyll.Core.Identifier + +-- | One base element of a pattern +-- +data PatternComponent = CaptureOne + | CaptureMany + | Literal String + deriving (Eq) + +instance Show PatternComponent where + show CaptureOne = "*" + show CaptureMany = "**" + show (Literal s) = s + +-- | Type that allows matching on identifiers +-- +newtype Pattern = Pattern {unPattern :: [PatternComponent]} + deriving (Eq) + +instance Show Pattern where + show = intercalate "/" . map show . unPattern + +instance IsString Pattern where + fromString = parsePattern + +-- | Parse a pattern from a string +-- +parsePattern :: String -> Pattern +parsePattern = Pattern . map toPattern . unIdentifier . parseIdentifier + where + toPattern x | x == "*" = CaptureOne + | x == "**" = CaptureMany + | otherwise = Literal x + +-- | Match an identifier against a pattern, generating a list of captures +-- +match :: Pattern -> Identifier -> Maybe [[String]] +match (Pattern p) (Identifier i) = match' p i + +-- | Check if an identifier matches a pattern +-- +doesMatch :: Pattern -> Identifier -> Bool +doesMatch p = isJust . match p + +-- | Given a list of identifiers, retain only those who match the given pattern +-- +matches :: Pattern -> [Identifier] -> [Identifier] +matches p = filter (doesMatch p) + +-- | Split a list at every possible point, generate a list of (init, tail) cases +-- +splits :: [a] -> [([a], [a])] +splits ls = reverse $ splits' [] ls + where + splits' lx ly = (lx, ly) : case ly of + [] -> [] + (y : ys) -> splits' (lx ++ [y]) ys + +-- | Internal verion of 'match' +-- +match' :: [PatternComponent] -> [String] -> Maybe [[String]] +match' [] [] = Just [] -- An empty match +match' [] _ = Nothing -- No match +match' _ [] = Nothing -- No match +match' (m : ms) (s : ss) = case m of + -- Take one string and one literal, fail on mismatch + Literal l -> if s == l then match' ms ss else Nothing + -- Take one string and one capture + CaptureOne -> fmap ([s] :) $ match' ms ss + -- Take one string, and one or many captures + CaptureMany -> + let take' (i, t) = fmap (i :) $ match' ms t + in msum $ map take' $ splits (s : ss) diff --git a/tests/Hakyll/Core/DirectedGraph/Tests.hs b/tests/Hakyll/Core/DirectedGraph/Tests.hs index 4ce5944..1a9b406 100644 --- a/tests/Hakyll/Core/DirectedGraph/Tests.hs +++ b/tests/Hakyll/Core/DirectedGraph/Tests.hs @@ -15,9 +15,9 @@ import Hakyll.Core.DirectedGraph.ObsoleteFilter tests :: [Test] tests = - [ testCase "solveDependencies01" solveDependencies01 - , testCase "filterObsolete01" filterObsolete01 - , testCase "filterObsolete02" filterObsolete02 + [ testCase "solveDependencies [1]" solveDependencies1 + , testCase "filterObsolete [1]" filterObsolete1 + , testCase "filterObsolete [2]" filterObsolete2 ] node :: Ord a => a -> [a] -> (a, Set a) @@ -32,17 +32,17 @@ testGraph01 = fromList , node 3 [] ] -solveDependencies01 :: Assertion -solveDependencies01 = result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8] - @? "solveDependencies01" +solveDependencies1 :: Assertion +solveDependencies1 = result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8] + @? "solveDependencies1" where result = solveDependencies testGraph01 -filterObsolete01 :: Assertion -filterObsolete01 = nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8] - @? "filterObsolete01" +filterObsolete1 :: Assertion +filterObsolete1 = nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8] + @? "filterObsolete1" -filterObsolete02 :: Assertion -filterObsolete02 = +filterObsolete2 :: Assertion +filterObsolete2 = nodes (filterObsolete [4] testGraph01) == S.fromList [4, 2, 6, 8] - @? "filterObsolete02" + @? "filterObsolete2" diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs new file mode 100644 index 0000000..910bca3 --- /dev/null +++ b/tests/Hakyll/Core/Identifier/Tests.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Core.Identifier.Tests + ( tests + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Hakyll.Core.Identifier.Pattern + +tests :: [Test] +tests = zipWith testCase names matchCases + where + names = map (\n -> "match [" ++ show n ++ "]") [1 :: Int ..] + +-- | Collection of simple cases +-- +matchCases :: [Assertion] +matchCases = + [ Just [["bar"]] @=? match "foo/**" "foo/bar" + , Just [["foo", "bar"]] @=? match "**" "foo/bar" + , Nothing @=? match "*" "foo/bar" + , Just [] @=? match "foo" "foo" + , Just [["foo"]] @=? match "*/bar" "foo/bar" + , Just [["foo", "bar"]] @=? match "**/qux" "foo/bar/qux" + , Just [["foo", "bar"], ["qux"]] @=? match "**/*" "foo/bar/qux" + , Just [["foo"], ["bar", "qux"]] @=? match "*/**" "foo/bar/qux" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 26b26f0..f75001f 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -3,9 +3,12 @@ module TestSuite where import Test.Framework (defaultMain, testGroup) import qualified Hakyll.Core.DirectedGraph.Tests +import qualified Hakyll.Core.Identifier.Tests main :: IO () main = defaultMain [ testGroup "Hakyll.Core.DirectedGraph.Tests" Hakyll.Core.DirectedGraph.Tests.tests + , testGroup "Hakyll.Core.Identifier.Tests" + Hakyll.Core.Identifier.Tests.tests ] -- cgit v1.2.3 From 10328b890cee125d8b5bd1c2a0a8d3b2489c4267 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 18:22:16 +0100 Subject: Document the pattern module a bit --- src/Hakyll/Core/Identifier/Pattern.hs | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index 02b023f..28c31f2 100644 --- a/src/Hakyll/Core/Identifier/Pattern.hs +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -1,6 +1,35 @@ -- | Module providing pattern matching and capturing on 'Identifier's. -- --- TODO: Documentation +-- A very simple pattern could be, for example: +-- +-- > foo/bar +-- +-- This pattern will only match the @foo\/bar@ identifier. +-- +-- To match more than one identifier, there are different captures that one can +-- use: +-- +-- * @*@: matches exactly one element of an identifier; +-- +-- * @**@: matches one or more elements of an identifier. +-- +-- Some examples: +-- +-- * @foo\/*@ will match @foo\/bar@ and @foo\/foo@, but not @foo\/bar\/qux@ nor +-- @foo@; +-- +-- * @**@ will match any non-empty identifier; +-- +-- * @foo\/**@ will match @foo\/bar@ and @foo\/bar\/qux@, but not @bar\/foo@ nor +-- @foo@; +-- +-- A small warning: patterns are not globs. Using @foo\/*.markdown@ will not do +-- what you probably intended, as it will only match the file which is literally +-- called @foo\/*.markdown@. Remember that these captures only work on elements +-- of identifiers as a whole; not on parts of these elements. +-- +-- Furthermore, the 'match' function allows the user to get access to the +-- elements captured by the capture elements in the pattern. -- module Hakyll.Core.Identifier.Pattern ( Pattern -- cgit v1.2.3 From 07ca8954a5afef265253dd7fa2b77561a8b7470a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 18:24:19 +0100 Subject: Minor change to pattern documentation --- src/Hakyll/Core/Identifier/Pattern.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index 28c31f2..b5f01e5 100644 --- a/src/Hakyll/Core/Identifier/Pattern.hs +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -1,10 +1,7 @@ -- | Module providing pattern matching and capturing on 'Identifier's. -- --- A very simple pattern could be, for example: --- --- > foo/bar --- --- This pattern will only match the @foo\/bar@ identifier. +-- A very simple pattern could be, for example, @foo\/bar@. This pattern will +-- only match the exact @foo\/bar@ identifier. -- -- To match more than one identifier, there are different captures that one can -- use: -- cgit v1.2.3 From 4bdd93b331eec642873262a524b6b3a6132eb1c9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 23 Dec 2010 19:20:05 +0100 Subject: Add Route code --- src/Hakyll/Core/Route.hs | 71 ++++++++++++++++++++++++++++++++++++++++ tests/Hakyll/Core/Route/Tests.hs | 25 ++++++++++++++ tests/TestSuite.hs | 3 ++ 3 files changed, 99 insertions(+) create mode 100644 src/Hakyll/Core/Route.hs create mode 100644 tests/Hakyll/Core/Route/Tests.hs (limited to 'src') diff --git a/src/Hakyll/Core/Route.hs b/src/Hakyll/Core/Route.hs new file mode 100644 index 0000000..195768c --- /dev/null +++ b/src/Hakyll/Core/Route.hs @@ -0,0 +1,71 @@ +-- | Once a target is compiled, the user usually wants to save it to the disk. +-- This is where the 'Route' type comes in; it determines where a certain target +-- should be written. +-- +-- When a route is applied (using 'runRoute'), it either returns a 'Just' +-- 'FilePath' (meaning the target should be written to that file path), or +-- 'Nothing' (meaning this target should not be written anywhere). +-- +module Hakyll.Core.Route + ( Route + , runRoute + , idRoute + , setExtension + , ifMatch + ) where + +import Data.Monoid (Monoid, mempty, mappend) +import Control.Monad (mplus) +import System.FilePath (replaceExtension) + +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern + +-- | Type used for a route +-- +newtype Route = Route {unRoute :: Identifier -> Maybe FilePath} + +instance Monoid Route where + mempty = Route $ const Nothing + mappend (Route f) (Route g) = Route $ \id' -> f id' `mplus` g id' + +-- | Apply a route to an identifier +-- +runRoute :: Route -> Identifier -> Maybe FilePath +runRoute = unRoute + +-- | 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 :: Route +idRoute = Route $ Just . toFilePath + +-- | Set (or replace) the extension of a route. +-- +-- Example: +-- +-- > runRoute (setExtension "html") "foo/bar" +-- +-- Result: +-- +-- > Just "foo/bar.html" +-- +-- Example: +-- +-- > runRoute (setExtension "html") "posts/the-art-of-trolling.markdown" +-- +-- Result: +-- +-- > Just "posts/the-art-of-trolling.html" +-- +setExtension :: String -> Route +setExtension exension = Route $ fmap (flip replaceExtension exension) + . unRoute idRoute + +-- | Modify a route: apply the route if the identifier matches the given +-- pattern, fail otherwise. +-- +ifMatch :: Pattern -> Route -> Route +ifMatch pattern (Route route) = Route $ \id' -> + if doesMatch pattern id' then route id' + else Nothing diff --git a/tests/Hakyll/Core/Route/Tests.hs b/tests/Hakyll/Core/Route/Tests.hs new file mode 100644 index 0000000..17a4123 --- /dev/null +++ b/tests/Hakyll/Core/Route/Tests.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Core.Route.Tests + ( tests + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Hakyll.Core.Route + +tests :: [Test] +tests = zipWith testCase names matchCases + where + names = map (\n -> "runRoute [" ++ show n ++ "]") [1 :: Int ..] + +-- | Collection of simple cases +-- +matchCases :: [Assertion] +matchCases = + [ Just "foo.html" @=? runRoute (setExtension "html") "foo" + , Just "foo.html" @=? runRoute (setExtension ".html") "foo" + , Just "foo.html" @=? runRoute (setExtension "html") "foo.markdown" + , Just "foo.html" @=? runRoute (setExtension ".html") "foo.markdown" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index f75001f..68c4f28 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -4,6 +4,7 @@ import Test.Framework (defaultMain, testGroup) import qualified Hakyll.Core.DirectedGraph.Tests import qualified Hakyll.Core.Identifier.Tests +import qualified Hakyll.Core.Route.Tests main :: IO () main = defaultMain @@ -11,4 +12,6 @@ main = defaultMain Hakyll.Core.DirectedGraph.Tests.tests , testGroup "Hakyll.Core.Identifier.Tests" Hakyll.Core.Identifier.Tests.tests + , testGroup "Hakyll.Core.Route.Tests" + Hakyll.Core.Route.Tests.tests ] -- cgit v1.2.3 From 4b7c42d644a1fb2242ad79a2193edad4ba6b2b7e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 24 Dec 2010 08:42:05 +0100 Subject: Add resource provider modules --- src/Hakyll/Core/ResourceProvider.hs | 18 +++++++++ .../Core/ResourceProvider/FileResourceProvider.hs | 44 ++++++++++++++++++++++ 2 files changed, 62 insertions(+) create mode 100644 src/Hakyll/Core/ResourceProvider.hs create mode 100644 src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs (limited to 'src') diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs new file mode 100644 index 0000000..7b4f94a --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -0,0 +1,18 @@ +-- | 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. +-- +module Hakyll.Core.ResourceProvider + ( ResourceProvider (..) + ) where + +import Hakyll.Core.Identifier + +-- | A value responsible for retrieving and listing resources +-- +data ResourceProvider = ResourceProvider + { -- | A list of all resources this provider is able to provide + resourceList :: [Identifier] + , -- | Retrieve a certain resource as string + resourceString :: Identifier -> IO String + } diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs new file mode 100644 index 0000000..b682634 --- /dev/null +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -0,0 +1,44 @@ +-- | A concrete 'ResourceProvider' that gets it's resources from the filesystem +-- +module Hakyll.Core.ResourceProvider.FileResourceProvider + ( fileResourceProvider + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM) + +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath ((), normalise) + +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Identifier + +-- | Create a filesystem-based 'ResourceProvider' +-- +fileResourceProvider :: IO ResourceProvider +fileResourceProvider = do + list <- map parseIdentifier <$> getRecursiveContents "." + return $ ResourceProvider + { resourceList = list + , resourceString = readFile . toFilePath + } + +-- | Get all contents of a directory. Note that files starting with a dot (.) +-- will be ignored. +-- +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents topdir = do + topdirExists <- doesDirectoryExist topdir + if topdirExists + then do names <- getDirectoryContents topdir + let properNames = filter isProper names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [normalise path] + return (concat paths) + else return [] + where + isProper = not . (== '.') . head -- cgit v1.2.3 From 12c446785c76130a65c46cc603e767893b4818b5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 24 Dec 2010 16:55:20 +0100 Subject: Add target module --- src/Hakyll/Core/DirectedGraph/Internal.hs | 3 +- src/Hakyll/Core/Target.hs | 11 ++++++++ src/Hakyll/Core/Target/Internal.hs | 46 +++++++++++++++++++++++++++++++ 3 files changed, 59 insertions(+), 1 deletion(-) create mode 100644 src/Hakyll/Core/Target.hs create mode 100644 src/Hakyll/Core/Target/Internal.hs (limited to 'src') diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs index 9890fc0..52a712d 100644 --- a/src/Hakyll/Core/DirectedGraph/Internal.hs +++ b/src/Hakyll/Core/DirectedGraph/Internal.hs @@ -1,4 +1,5 @@ --- | Internal structure of the DirectedGraph type. Not exported in the library. +-- | Internal structure of the DirectedGraph type. Not exported outside of the +-- library. -- module Hakyll.Core.DirectedGraph.Internal ( Node (..) diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs new file mode 100644 index 0000000..1f783df --- /dev/null +++ b/src/Hakyll/Core/Target.hs @@ -0,0 +1,11 @@ +-- | A target represents one compilation unit, e.g. a blog post, a CSS file... +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Target + ( DependencyLookup + , TargetM + , Target + , runTarget + ) where + +import Hakyll.Core.Target.Internal diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs new file mode 100644 index 0000000..a58f736 --- /dev/null +++ b/src/Hakyll/Core/Target/Internal.hs @@ -0,0 +1,46 @@ +-- | Internal structure of a Target, not exported outside of the library +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Target.Internal + ( DependencyLookup + , TargetM (..) + , Target + , runTarget + ) where + +import Control.Monad.Trans (MonadIO) +import Control.Monad.Reader (ReaderT, runReaderT) + +import Hakyll.Core.Identifier + +-- | A lookup with which we can get dependencies +-- +type DependencyLookup a = Identifier -> a + +-- | Environment for the target monad +-- +data TargetEnvironment a = TargetEnvironment + { targetIdentifier :: Identifier + , targetDependencyLookup :: DependencyLookup a -- ^ Dependency lookup + } + +-- | Monad for targets. In this monad, the user can compose targets and describe +-- how they should be created. +-- +newtype TargetM a b = TargetM {unTargetM :: ReaderT (TargetEnvironment a) IO b} + deriving (Monad, Functor, MonadIO) + +-- | Simplification of the 'TargetM' type for concrete cases: the type of the +-- returned item should equal the type of the dependencies. +-- +type Target a = TargetM a a + +-- | Run a target, yielding an actual result. +-- +runTarget :: Target a -> Identifier -> DependencyLookup a -> IO a +runTarget target id' lookup' = runReaderT (unTargetM target) env + where + env = TargetEnvironment + { targetIdentifier = id' + , targetDependencyLookup = lookup' + } -- cgit v1.2.3 From c372fc47da1d29d6613b782d7c8974a2de5b13ff Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 25 Dec 2010 18:15:44 +0100 Subject: Add Compiler module --- src/Hakyll/Core/Compiler.hs | 80 ++++++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Target/Internal.hs | 1 + 2 files changed, 81 insertions(+) create mode 100644 src/Hakyll/Core/Compiler.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs new file mode 100644 index 0000000..42598f6 --- /dev/null +++ b/src/Hakyll/Core/Compiler.hs @@ -0,0 +1,80 @@ +-- | A Compiler manages targets and dependencies between targets. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Compiler + ( Dependencies + , CompilerM + , Compiler + , runCompiler + , require + , target + ) where + +import Control.Arrow (second) +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.State (State, modify, runState) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Data.Set (Set) +import qualified Data.Set as S + +import Hakyll.Core.Identifier +import Hakyll.Core.Target.Internal + +-- | A set of dependencies +-- +type Dependencies = Set Identifier + +-- | Add one dependency +-- +addDependency :: Identifier -> CompilerM a () +addDependency dependency = CompilerM $ modify $ addDependency' + where + addDependency' x = x + { compilerDependencies = S.insert dependency $ compilerDependencies x + } + +-- | Environment in which a compiler runs +-- +data CompilerEnvironment a = CompilerEnvironment + { compilerIdentifier :: Identifier -- ^ Target identifier + } + +-- | State carried along by a compiler +-- +data CompilerState = CompilerState + { compilerDependencies :: Dependencies + } + +-- | The compiler monad +-- +newtype CompilerM a b = CompilerM + { unCompilerM :: ReaderT (CompilerEnvironment a) (State CompilerState) b + } deriving (Monad, Functor, Applicative) + +-- | Simplified type for a compiler generating a target (which covers most +-- cases) +-- +type Compiler a = CompilerM a (TargetM a a) + +-- | Run a compiler, yielding the resulting target and it's dependencies +-- +runCompiler :: Compiler a -> Identifier -> (TargetM a a, Dependencies) +runCompiler compiler identifier = second compilerDependencies $ + runState (runReaderT (unCompilerM compiler) env) state + where + env = CompilerEnvironment {compilerIdentifier = identifier} + state = CompilerState S.empty + +-- | Require another target. Using this function ensures automatic handling of +-- dependencies +-- +require :: Identifier + -> Compiler a +require identifier = do + addDependency identifier + return $ TargetM $ flip targetDependencyLookup identifier <$> ask + +-- | Construct a target inside a compiler +-- +target :: TargetM a a -> Compiler a +target = return diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs index a58f736..96e3087 100644 --- a/src/Hakyll/Core/Target/Internal.hs +++ b/src/Hakyll/Core/Target/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Target.Internal ( DependencyLookup + , TargetEnvironment (..) , TargetM (..) , Target , runTarget -- cgit v1.2.3 From 6b6a78ea4163bd6b5f843ca9a671aa29f9c29ad9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 25 Dec 2010 19:37:21 +0100 Subject: Add rules module --- src/Hakyll/Core/Rules.hs | 83 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) create mode 100644 src/Hakyll/Core/Rules.hs (limited to 'src') diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs new file mode 100644 index 0000000..d15b3b9 --- /dev/null +++ b/src/Hakyll/Core/Rules.hs @@ -0,0 +1,83 @@ +-- | This module provides a monadic DSL in which the user can specify the +-- different rules used to run the compilers +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Rules + ( RuleSet (..) + , RulesM + , Rules + , runRules + , compile + , create + , route + ) where + +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.Writer +import Control.Monad.Reader + +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Compiler +import Hakyll.Core.Route + +-- | A collection of rules for the compilation process +-- +data RuleSet a = RuleSet + { rulesRoute :: Route + , rulesCompilers :: [(Identifier, Compiler a)] + } + +instance Monoid (RuleSet a) where + mempty = RuleSet mempty mempty + mappend (RuleSet r1 c1) (RuleSet r2 c2) = + RuleSet (mappend r1 r2) (mappend c1 c2) + +-- | The monad used to compose rules +-- +newtype RulesM a b = RulesM + { unRulesM :: ReaderT ResourceProvider (Writer (RuleSet a)) b + } deriving (Monad, Functor, Applicative) + +-- | Simplification of the RulesM type; usually, it will not return any +-- result. +-- +type Rules a = RulesM a () + +-- | Run a Rules monad, resulting in a 'RuleSet' +-- +runRules :: Rules a -> ResourceProvider -> RuleSet a +runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider + +-- | Add a route +-- +addRoute :: Route -> Rules a +addRoute route' = RulesM $ tell $ RuleSet route' mempty + +-- | Add a number of compilers +-- +addCompilers :: [(Identifier, Compiler a)] -> Rules a +addCompilers compilers = RulesM $ tell $ RuleSet mempty compilers + +-- | Add a compilation rule +-- +-- This instructs all resources matching the given pattern to be compiled using +-- the given compiler +-- +compile :: Pattern -> Compiler a -> Rules a +compile pattern compiler = RulesM $ do + identifiers <- matches pattern . resourceList <$> ask + unRulesM $ addCompilers $ zip identifiers (repeat compiler) + +-- | Add a compilation rule +-- +-- This sets a compiler for the given identifier +-- +create :: Identifier -> Compiler a -> RulesM a () +create identifier compiler = addCompilers [(identifier, compiler)] + +-- | Add a route +-- +route :: Pattern -> Route -> RulesM a () +route pattern route' = addRoute $ ifMatch pattern route' -- cgit v1.2.3 From 0cd7716dae87d50e79883152edf735132ae4798e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 25 Dec 2010 20:18:36 +0100 Subject: Add writable class --- src/Hakyll/Core/Writable.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 src/Hakyll/Core/Writable.hs (limited to 'src') diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs new file mode 100644 index 0000000..d6c3683 --- /dev/null +++ b/src/Hakyll/Core/Writable.hs @@ -0,0 +1,15 @@ +-- | Describes writable items; items that can be saved to the disk +-- +{-# LANGUAGE FlexibleInstances #-} +module Hakyll.Core.Writable + ( Writable (..) + ) where + +-- | Describes an item that can be saved to the disk +-- +class Writable a where + -- | Save an item to the given filepath + write :: FilePath -> a -> IO () + +instance Writable [Char] where + write = writeFile -- cgit v1.2.3 From ec85de418b01b4eaefb286a52c050a141204d46f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 25 Dec 2010 22:02:20 +0100 Subject: Prototype Run module --- src/Hakyll/Core/Run.hs | 68 ++++++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Target.hs | 14 ++++++++ src/Hakyll/Core/Target/Internal.hs | 16 ++++++--- 3 files changed, 94 insertions(+), 4 deletions(-) create mode 100644 src/Hakyll/Core/Run.hs (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs new file mode 100644 index 0000000..4683768 --- /dev/null +++ b/src/Hakyll/Core/Run.hs @@ -0,0 +1,68 @@ +-- | This is the module which binds it all together +-- +module Hakyll.Core.Run where + +import Control.Arrow ((&&&)) +import Control.Monad (msum, foldM, forM, forM_) +import qualified Data.Map as M + +import Hakyll.Core.Route +import Hakyll.Core.Compiler +import Hakyll.Core.ResourceProvider +import Hakyll.Core.ResourceProvider.FileResourceProvider +import Hakyll.Core.Rules +import Hakyll.Core.Target +import Hakyll.Core.Identifier +import Hakyll.Core.DirectedGraph +import Hakyll.Core.DirectedGraph.DependencySolver +import Hakyll.Core.Writable + +hakyll :: Writable a => Rules a -> IO () +hakyll rules = do + provider <- fileResourceProvider + hakyllWith rules provider + +hakyllWith :: Writable a => Rules a -> ResourceProvider -> IO () +hakyllWith rules provider = do + let -- Get the rule set + ruleSet = runRules rules provider + + -- Get all identifiers and compilers + compilers = rulesCompilers ruleSet + + -- Get all targets + targets = flip map compilers $ \(id', compiler) -> + let (targ, deps) = runCompiler compiler id' + in (id', targ, deps) + + -- Map mapping every identifier to it's target + targetMap = M.fromList $ map (\(i, t, _) -> (i, t)) targets + + -- Create a dependency graph + graph = fromList $ map (\(i, _, d) -> (i, d)) targets + + -- Solve the graph, creating a target order + ordered = solveDependencies graph + + -- Join the order with the targets again + orderedTargets = map (id &&& (targetMap M.!)) ordered + + -- Generate all the targets in order + map' <- foldM addTarget M.empty orderedTargets + + let -- Fetch the routes + route' = rulesRoute ruleSet + + forM_ (M.toList map') $ \(id', result) -> + case runRoute route' id' of + Nothing -> return () + Just r -> do + putStrLn $ "Routing " ++ show id' ++ " to " ++ r + write r result + + putStrLn "DONE." + where + addTarget map' (id', targ) = do + result <- runTarget targ id' (map' M.!) provider + putStrLn $ "Generated target: " ++ show id' + return $ M.insert id' result map' diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs index 1f783df..215a53b 100644 --- a/src/Hakyll/Core/Target.hs +++ b/src/Hakyll/Core/Target.hs @@ -6,6 +6,20 @@ module Hakyll.Core.Target , TargetM , Target , runTarget + , getResourceString ) where +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ask) +import Control.Monad.Trans (liftIO) + import Hakyll.Core.Target.Internal +import Hakyll.Core.ResourceProvider + +-- | Get the resource content as a string +-- +getResourceString :: TargetM a String +getResourceString = TargetM $ do + provider <- targetResourceProvider <$> ask + identifier <- targetIdentifier <$> ask + liftIO $ resourceString provider identifier diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs index 96e3087..f40c798 100644 --- a/src/Hakyll/Core/Target/Internal.hs +++ b/src/Hakyll/Core/Target/Internal.hs @@ -9,10 +9,12 @@ module Hakyll.Core.Target.Internal , runTarget ) where +import Control.Applicative (Applicative) import Control.Monad.Trans (MonadIO) import Control.Monad.Reader (ReaderT, runReaderT) import Hakyll.Core.Identifier +import Hakyll.Core.ResourceProvider -- | A lookup with which we can get dependencies -- @@ -21,15 +23,16 @@ type DependencyLookup a = Identifier -> a -- | Environment for the target monad -- data TargetEnvironment a = TargetEnvironment - { targetIdentifier :: Identifier + { targetIdentifier :: Identifier -- ^ Identifier , targetDependencyLookup :: DependencyLookup a -- ^ Dependency lookup + , targetResourceProvider :: ResourceProvider -- ^ To get resources } -- | Monad for targets. In this monad, the user can compose targets and describe -- how they should be created. -- newtype TargetM a b = TargetM {unTargetM :: ReaderT (TargetEnvironment a) IO b} - deriving (Monad, Functor, MonadIO) + deriving (Monad, Functor, Applicative, MonadIO) -- | Simplification of the 'TargetM' type for concrete cases: the type of the -- returned item should equal the type of the dependencies. @@ -38,10 +41,15 @@ type Target a = TargetM a a -- | Run a target, yielding an actual result. -- -runTarget :: Target a -> Identifier -> DependencyLookup a -> IO a -runTarget target id' lookup' = runReaderT (unTargetM target) env +runTarget :: Target a + -> Identifier + -> DependencyLookup a + -> ResourceProvider + -> IO a +runTarget target id' lookup' provider = runReaderT (unTargetM target) env where env = TargetEnvironment { targetIdentifier = id' , targetDependencyLookup = lookup' + , targetResourceProvider = provider } -- cgit v1.2.3 From 5bc8028696ae8d5aa2c60db87aea3d00f9d7aebd Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 00:09:35 +0100 Subject: Add DirectedGraph to DOT module --- src/Hakyll/Core/DirectedGraph/Dot.hs | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 src/Hakyll/Core/DirectedGraph/Dot.hs (limited to 'src') diff --git a/src/Hakyll/Core/DirectedGraph/Dot.hs b/src/Hakyll/Core/DirectedGraph/Dot.hs new file mode 100644 index 0000000..8289992 --- /dev/null +++ b/src/Hakyll/Core/DirectedGraph/Dot.hs @@ -0,0 +1,30 @@ +-- | Dump a directed graph in dot format. Used for debugging purposes +-- +module Hakyll.Core.DirectedGraph.Dot + ( toDot + , writeDot + ) where + +import Hakyll.Core.DirectedGraph +import qualified Data.Set as S + +-- | Convert a directed graph into dot format for debugging purposes +-- +toDot :: Ord a + => (a -> String) -- ^ Convert nodes to dot names + -> DirectedGraph a -- ^ Graph to dump + -> String -- ^ Resulting string +toDot showTag graph = unlines $ concat + [ return "digraph dependencies {" + , concatMap showNode (S.toList $ nodes graph) + , return "}" + ] + where + showNode node = map (showEdge node) $ S.toList $ neighbours node graph + showEdge x y = " \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";" + +-- | Write out the @.dot@ file to a given file path. See 'toDot' for more +-- information. +-- +writeDot :: Ord a => FilePath -> (a -> String) -> DirectedGraph a -> IO () +writeDot path showTag = writeFile path . toDot showTag -- cgit v1.2.3 From 53d179a7da994bd45eff1363269c6e1cb533dfd7 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 09:38:40 +0100 Subject: Add file utility module --- .../Core/ResourceProvider/FileResourceProvider.hs | 25 +------- src/Hakyll/Core/Util/File.hs | 66 ++++++++++++++++++++++ 2 files changed, 67 insertions(+), 24 deletions(-) create mode 100644 src/Hakyll/Core/Util/File.hs (limited to 'src') diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs index b682634..442ae9a 100644 --- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -5,13 +5,10 @@ module Hakyll.Core.ResourceProvider.FileResourceProvider ) where import Control.Applicative ((<$>)) -import Control.Monad (forM) - -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath ((), normalise) import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier +import Hakyll.Core.Util.File -- | Create a filesystem-based 'ResourceProvider' -- @@ -22,23 +19,3 @@ fileResourceProvider = do { resourceList = list , resourceString = readFile . toFilePath } - --- | Get all contents of a directory. Note that files starting with a dot (.) --- will be ignored. --- -getRecursiveContents :: FilePath -> IO [FilePath] -getRecursiveContents topdir = do - topdirExists <- doesDirectoryExist topdir - if topdirExists - then do names <- getDirectoryContents topdir - let properNames = filter isProper names - paths <- forM properNames $ \name -> do - let path = topdir name - isDirectory <- doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [normalise path] - return (concat paths) - else return [] - where - isProper = not . (== '.') . head diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs new file mode 100644 index 0000000..355eafb --- /dev/null +++ b/src/Hakyll/Core/Util/File.hs @@ -0,0 +1,66 @@ +-- | A module containing various file utility functions +-- +module Hakyll.Core.Util.File + ( makeDirectories + , getRecursiveContents + , isFileObsolete + ) where + +import System.FilePath (normalise, takeDirectory, ()) +import System.Time (ClockTime) +import Control.Monad (forM) +import System.Directory ( createDirectoryIfMissing, doesDirectoryExist + , doesFileExist, getModificationTime + , getDirectoryContents + ) + +-- | Given a path to a file, try to make the path writable by making +-- all directories on the path. +-- +makeDirectories :: FilePath -> IO () +makeDirectories = createDirectoryIfMissing True . takeDirectory + +-- | Get all contents of a directory. Note that files starting with a dot (.) +-- will be ignored. +-- +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents topdir = do + topdirExists <- doesDirectoryExist topdir + if topdirExists + then do names <- getDirectoryContents topdir + let properNames = filter isProper names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [normalise path] + return (concat paths) + else return [] + where + isProper = not . (== ".") . take 1 + +-- | Check if a timestamp is obsolete compared to the timestamps of a number of +-- files. When they are no files, it is never obsolete. +-- +isObsolete :: ClockTime -- ^ The time to check. + -> [FilePath] -- ^ Dependencies of the cached file. + -> IO Bool +isObsolete _ [] = return False +isObsolete timeStamp depends = do + dependsModified <- mapM getModificationTime depends + return (timeStamp < maximum dependsModified) + +-- | Check if a file is obsolete, given it's dependencies. When the file does +-- not exist, it is always obsolete. Other wise, it is obsolete if any of it's +-- dependencies has a more recent modification time than the file. +-- +isFileObsolete :: FilePath -- ^ The cached file + -> [FilePath] -- ^ Dependencies of the cached file + -> IO Bool +isFileObsolete file depends = do + exists <- doesFileExist file + if not exists + then return True + else do timeStamp <- getModificationTime file + isObsolete timeStamp depends -- cgit v1.2.3 From 427a74003804a29e48022a901e42e0f73311058f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 11:57:19 +0100 Subject: Ignore unexisting files in obsolete check --- src/Hakyll/Core/Util/File.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 355eafb..45f3760 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -8,7 +8,7 @@ module Hakyll.Core.Util.File import System.FilePath (normalise, takeDirectory, ()) import System.Time (ClockTime) -import Control.Monad (forM) +import Control.Monad (forM, filterM) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist , doesFileExist, getModificationTime , getDirectoryContents @@ -48,7 +48,8 @@ isObsolete :: ClockTime -- ^ The time to check. -> IO Bool isObsolete _ [] = return False isObsolete timeStamp depends = do - dependsModified <- mapM getModificationTime depends + depends' <- filterM doesFileExist depends + dependsModified <- mapM getModificationTime depends' return (timeStamp < maximum dependsModified) -- | Check if a file is obsolete, given it's dependencies. When the file does -- cgit v1.2.3 From 36ec2c15b8dece790e4a5e02dc9a4bd1782c7a5f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 11:57:42 +0100 Subject: Add targetFromString compiler function --- src/Hakyll/Core/Compiler.hs | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 42598f6..70006e9 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -8,6 +8,7 @@ module Hakyll.Core.Compiler , runCompiler , require , target + , targetFromString ) where import Control.Arrow (second) @@ -18,6 +19,7 @@ import Data.Set (Set) import qualified Data.Set as S import Hakyll.Core.Identifier +import Hakyll.Core.Target import Hakyll.Core.Target.Internal -- | A set of dependencies @@ -78,3 +80,10 @@ require identifier = do -- target :: TargetM a a -> Compiler a target = return + +-- | Construct a target from a string, this string being the content of the +-- resource. +-- +targetFromString :: (String -> TargetM a a) -- ^ Function to create the target + -> Compiler a -- ^ Resulting compiler +targetFromString = target . (getResourceString >>=) -- cgit v1.2.3 From 7f4b5e542c3f96bc05e329f846b80661b394be90 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 12:31:15 +0100 Subject: Add getIdentifier function in target --- src/Hakyll/Core/Target.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs index 215a53b..b8740bc 100644 --- a/src/Hakyll/Core/Target.hs +++ b/src/Hakyll/Core/Target.hs @@ -6,6 +6,7 @@ module Hakyll.Core.Target , TargetM , Target , runTarget + , getIdentifier , getResourceString ) where @@ -13,13 +14,19 @@ import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) +import Hakyll.Core.Identifier import Hakyll.Core.Target.Internal import Hakyll.Core.ResourceProvider +-- | Get the current identifier +-- +getIdentifier :: TargetM a Identifier +getIdentifier = TargetM $ targetIdentifier <$> ask + -- | Get the resource content as a string -- getResourceString :: TargetM a String getResourceString = TargetM $ do provider <- targetResourceProvider <$> ask - identifier <- targetIdentifier <$> ask + identifier <- unTargetM getIdentifier liftIO $ resourceString provider identifier -- cgit v1.2.3 From ab7c9bef64a433824ba57a04efac98f48884bcd9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 12:31:36 +0100 Subject: Add FileType module --- src/Hakyll/Web/FileType.hs | 55 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 src/Hakyll/Web/FileType.hs (limited to 'src') diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs new file mode 100644 index 0000000..8f0bdcc --- /dev/null +++ b/src/Hakyll/Web/FileType.hs @@ -0,0 +1,55 @@ +-- | A module dealing with common file extensions and associated file types. +-- +module Hakyll.Web.FileType + ( FileType (..) + , fileType + , getFileType + ) where + +import System.FilePath (takeExtension) +import Control.Applicative ((<$>)) + +import Hakyll.Core.Identifier +import Hakyll.Core.Target + +-- | Datatype to represent the different file types Hakyll can deal with by +-- default +-- +data FileType + = Html + | LaTeX + | LiterateHaskell FileType + | Markdown + | ReStructuredText + | PlainText + | Css + | UnknownFileType + deriving (Eq, Ord, Show, Read) + +-- | Get the file type for a certain file. The type is determined by extension. +-- +fileType :: FilePath -> FileType +fileType = fileType' . takeExtension + where + fileType' ".htm" = Html + fileType' ".html" = Html + fileType' ".lhs" = LiterateHaskell Markdown + fileType' ".markdown" = Markdown + fileType' ".md" = Markdown + fileType' ".mdn" = Markdown + fileType' ".mdown" = Markdown + fileType' ".mdwn" = Markdown + fileType' ".mkd" = Markdown + fileType' ".mkdwn" = Markdown + fileType' ".page" = Markdown + fileType' ".rst" = ReStructuredText + fileType' ".tex" = LaTeX + fileType' ".text" = PlainText + fileType' ".txt" = PlainText + fileType' ".css" = Css + fileType' _ = UnknownFileType + +-- | Get the file type for the current file +-- +getFileType :: TargetM a FileType +getFileType = fileType . toFilePath <$> getIdentifier -- cgit v1.2.3 From bd5f6ca5791ab62e7f0753e993e3455cfc9579ba Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 12:32:24 +0100 Subject: UnknownFileType → Binary MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web/FileType.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs index 8f0bdcc..9c1b681 100644 --- a/src/Hakyll/Web/FileType.hs +++ b/src/Hakyll/Web/FileType.hs @@ -23,7 +23,7 @@ data FileType | ReStructuredText | PlainText | Css - | UnknownFileType + | Binary deriving (Eq, Ord, Show, Read) -- | Get the file type for a certain file. The type is determined by extension. @@ -47,7 +47,7 @@ fileType = fileType' . takeExtension fileType' ".text" = PlainText fileType' ".txt" = PlainText fileType' ".css" = Css - fileType' _ = UnknownFileType + fileType' _ = Binary -- Treat unknown files as binary -- | Get the file type for the current file -- -- cgit v1.2.3 From 9939708c66a1a9efe4721d8f7d367c847b7db2a2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 13:21:27 +0100 Subject: Consistent naming: target vs compiler --- src/Hakyll/Core/Compiler.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 70006e9..4e8b642 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -7,8 +7,7 @@ module Hakyll.Core.Compiler , Compiler , runCompiler , require - , target - , targetFromString + , compileFromString ) where import Control.Arrow (second) @@ -76,14 +75,9 @@ require identifier = do addDependency identifier return $ TargetM $ flip targetDependencyLookup identifier <$> ask --- | Construct a target inside a compiler --- -target :: TargetM a a -> Compiler a -target = return - -- | Construct a target from a string, this string being the content of the -- resource. -- -targetFromString :: (String -> TargetM a a) -- ^ Function to create the target - -> Compiler a -- ^ Resulting compiler -targetFromString = target . (getResourceString >>=) +compileFromString :: (String -> TargetM a a) -- ^ Function to create the target + -> Compiler a -- ^ Resulting compiler +compileFromString = return . (getResourceString >>=) -- cgit v1.2.3 From 79ce331869dd64b13970c68e4cdcc026023ef2e6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 13:21:55 +0100 Subject: Consistent naming: ReStructuredText → Rst MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web/FileType.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs index 9c1b681..4da1439 100644 --- a/src/Hakyll/Web/FileType.hs +++ b/src/Hakyll/Web/FileType.hs @@ -20,7 +20,7 @@ data FileType | LaTeX | LiterateHaskell FileType | Markdown - | ReStructuredText + | Rst | PlainText | Css | Binary @@ -42,7 +42,7 @@ fileType = fileType' . takeExtension fileType' ".mkd" = Markdown fileType' ".mkdwn" = Markdown fileType' ".page" = Markdown - fileType' ".rst" = ReStructuredText + fileType' ".rst" = Rst fileType' ".tex" = LaTeX fileType' ".text" = PlainText fileType' ".txt" = PlainText -- cgit v1.2.3 From 515968716f6eaf6915d4fd5ec16aa569bdb5b6da Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 13:22:25 +0100 Subject: Add pandoc bindings --- src/Hakyll/Web/Pandoc.hs | 98 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) create mode 100644 src/Hakyll/Web/Pandoc.hs (limited to 'src') diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs new file mode 100644 index 0000000..52572a7 --- /dev/null +++ b/src/Hakyll/Web/Pandoc.hs @@ -0,0 +1,98 @@ +-- | Module exporting pandoc bindings +-- +module Hakyll.Web.Pandoc + ( readPandoc + , readPandocWith + , writePandoc + , writePandocWith + , targetReadPandoc + , targetReadPandocWith + , targetRenderPandoc + , targetRenderPandocWith + , defaultParserState + , defaultWriterOptions + ) where + +import Control.Applicative ((<$>), (<*>)) + +import Text.Pandoc (Pandoc) +import qualified Text.Pandoc as P + +import Hakyll.Web.FileType +import Hakyll.Core.Target + +-- | Read a string using pandoc, with the default options +-- +readPandoc :: FileType -- ^ File type, determines how parsing happens + -> String -- ^ String to read + -> Pandoc -- ^ Resulting document +readPandoc = readPandocWith defaultParserState + +-- | Read a string using pandoc, with the supplied options +-- +readPandocWith :: P.ParserState -- ^ Parser options + -> FileType -- ^ File type, determines how parsing happens + -> String -- ^ String to read + -> Pandoc -- ^ Resulting document +readPandocWith state fileType' = case fileType' of + Html -> P.readHtml state + LaTeX -> P.readLaTeX state + LiterateHaskell t -> readPandocWith state {P.stateLiterateHaskell = True} t + Markdown -> P.readMarkdown state + Rst -> P.readRST state + t -> error $ + "readPandoc: I don't know how to read " ++ show t + +-- | Write a document (as HTML) using pandoc, with the default options +-- +writePandoc :: Pandoc -- ^ Document to write + -> String -- ^ Resulting HTML +writePandoc = writePandocWith defaultWriterOptions + +-- | Write a document (as HTML) using pandoc, with the supplied options +-- +writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc + -> Pandoc -- ^ Document to write + -> String -- ^ Resulting HTML +writePandocWith = P.writeHtmlString + +-- | Read the resource using pandoc +-- +targetReadPandoc :: TargetM a Pandoc +targetReadPandoc = targetReadPandocWith defaultParserState + +-- | Read the resource using pandoc +-- +targetReadPandocWith :: P.ParserState -> TargetM a Pandoc +targetReadPandocWith state = + readPandocWith state <$> getFileType <*> getResourceString + +-- | Render the resource using pandoc +-- +targetRenderPandoc :: TargetM a String +targetRenderPandoc = + targetRenderPandocWith defaultParserState defaultWriterOptions + +-- | Render the resource using pandoc +-- +targetRenderPandocWith :: P.ParserState -> P.WriterOptions -> TargetM a String +targetRenderPandocWith state options = + writePandocWith options <$> targetReadPandocWith state + +-- | The default reader options for pandoc parsing in hakyll +-- +defaultParserState :: P.ParserState +defaultParserState = P.defaultParserState + { -- The following option causes pandoc to read smart typography, a nice + -- and free bonus. + P.stateSmart = True + } + +-- | The default writer options for pandoc rendering in hakyll +-- +defaultWriterOptions :: P.WriterOptions +defaultWriterOptions = P.defaultWriterOptions + { -- This option causes literate haskell to be written using '>' marks in + -- html, which I think is a good default. + P.writerLiterateHaskell = True + } -- cgit v1.2.3 From b30123f93cd7aa2deadd079e071899ac8f351993 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 16:12:24 +0100 Subject: Add resourceLazyByteString function --- src/Hakyll/Core/ResourceProvider.hs | 8 ++++++-- src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs | 7 +++++-- 2 files changed, 11 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs index 7b4f94a..94dda5b 100644 --- a/src/Hakyll/Core/ResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -8,11 +8,15 @@ module Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier +import qualified Data.ByteString.Lazy as LB + -- | A value responsible for retrieving and listing resources -- data ResourceProvider = ResourceProvider { -- | A list of all resources this provider is able to provide - resourceList :: [Identifier] + resourceList :: [Identifier] , -- | Retrieve a certain resource as string - resourceString :: Identifier -> IO String + resourceString :: Identifier -> IO String + , -- | Retrieve a certain resource as lazy bytestring + resourceLazyByteString :: Identifier -> IO LB.ByteString } diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs index 442ae9a..72d38be 100644 --- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -6,6 +6,8 @@ module Hakyll.Core.ResourceProvider.FileResourceProvider import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy as LB + import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier import Hakyll.Core.Util.File @@ -16,6 +18,7 @@ fileResourceProvider :: IO ResourceProvider fileResourceProvider = do list <- map parseIdentifier <$> getRecursiveContents "." return $ ResourceProvider - { resourceList = list - , resourceString = readFile . toFilePath + { resourceList = list + , resourceString = readFile . toFilePath + , resourceLazyByteString = LB.readFile . toFilePath } -- cgit v1.2.3 From 95f59be5a0be65c4eccdd020fc7938cd9afd7dde Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 16:12:57 +0100 Subject: Simple key-value store --- src/Hakyll/Core/Store.hs | 53 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 src/Hakyll/Core/Store.hs (limited to 'src') diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs new file mode 100644 index 0000000..02b9b4e --- /dev/null +++ b/src/Hakyll/Core/Store.hs @@ -0,0 +1,53 @@ +-- | A store for stroing and retreiving items +-- +module Hakyll.Core.Store + ( Store + , makeStore + , storeSet + , storeGet + ) where + +import Control.Applicative ((<$>)) +import System.FilePath (()) +import System.Directory (doesFileExist) + +import Data.Binary (Binary, encodeFile, decodeFile) + +import Hakyll.Core.Identifier +import Hakyll.Core.Util.File + +-- | Data structure used for the store +-- +data Store = Store + { storeDirectory :: FilePath + } + +-- | Initialize the store +-- +makeStore :: FilePath -> IO Store +makeStore directory = return Store {storeDirectory = directory} + +-- | Create a path +-- +makePath :: Store -> String -> Identifier -> FilePath +makePath store name identifier = + storeDirectory store name toFilePath identifier + +-- | Store an item +-- +storeSet :: Binary a => Store -> String -> Identifier -> a -> IO () +storeSet store name identifier value = do + makeDirectories path + encodeFile path value + where + path = makePath store name identifier + +-- | Load an item +-- +storeGet :: Binary a => Store -> String -> Identifier -> IO (Maybe a) +storeGet store name identifier = do + exists <- doesFileExist path + if exists then Just <$> decodeFile path + else return Nothing + where + path = makePath store name identifier -- cgit v1.2.3 From bc92f7fea561a3f9ae69fd499e817f9244fcb206 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 16:22:05 +0100 Subject: Add resourceDigest function --- src/Hakyll/Core/ResourceProvider.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs index 94dda5b..ba249ca 100644 --- a/src/Hakyll/Core/ResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -4,11 +4,17 @@ -- module Hakyll.Core.ResourceProvider ( ResourceProvider (..) + , resourceDigest ) where -import Hakyll.Core.Identifier +import Control.Monad ((<=<)) +import Data.Word (Word8) import qualified Data.ByteString.Lazy as LB +import OpenSSL.Digest.ByteString.Lazy (digest) +import OpenSSL.Digest (MessageDigest (MD5)) + +import Hakyll.Core.Identifier -- | A value responsible for retrieving and listing resources -- @@ -20,3 +26,8 @@ data ResourceProvider = ResourceProvider , -- | Retrieve a certain resource as lazy bytestring resourceLazyByteString :: Identifier -> IO LB.ByteString } + +-- | Retrieve a digest for a given resource +-- +resourceDigest :: ResourceProvider -> Identifier -> IO [Word8] +resourceDigest provider = digest MD5 <=< resourceLazyByteString provider -- cgit v1.2.3 From e6c758e6dc9709f67d62f42cfa1b1662ceb779ae Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 26 Dec 2010 19:03:03 +0100 Subject: Add Page module --- src/Hakyll/Web/Page.hs | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 src/Hakyll/Web/Page.hs (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs new file mode 100644 index 0000000..151364f --- /dev/null +++ b/src/Hakyll/Web/Page.hs @@ -0,0 +1,31 @@ +-- | A page is an important concept in Hakyll: it has a body (usually of the +-- type 'String') and number of metadata fields. This type is used to represent +-- pages on your website. +-- +module Hakyll.Web.Page + ( Page (..) + , toMap + ) where + +import Data.Map (Map) +import qualified Data.Map as M + +import Hakyll.Core.Writable + +-- | Type used to represent pages +-- +data Page a = Page + { pageMetadata :: Map String String + , pageBody :: a + } + +instance Functor Page where + fmap f (Page m b) = Page m (f b) + +instance Writable a => Writable (Page a) where + write p (Page _ b) = write p b + +-- | Convert a page to a map. The body will be placed in the @body@ key. +-- +toMap :: Page String -> Map String String +toMap (Page m b) = M.insert "body" b m -- cgit v1.2.3 From 4981cfbb7f5e2630f8b41a34a8e55796283d531c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 10:07:07 +0100 Subject: Add string utility module --- src/Hakyll/Web/Util/String.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 src/Hakyll/Web/Util/String.hs (limited to 'src') diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs new file mode 100644 index 0000000..5a8c7c6 --- /dev/null +++ b/src/Hakyll/Web/Util/String.hs @@ -0,0 +1,14 @@ +-- | Miscellaneous string manipulation functions. +-- +module Hakyll.Web.Util.String + ( trim + ) where + +import Data.Char (isSpace) + +-- | Trim a string (drop spaces, tabs and newlines at both sides). +-- +trim :: String -> String +trim = reverse . trim' . reverse . trim' + where + trim' = dropWhile isSpace -- cgit v1.2.3 From c1d16cdab337274a9f5aca40b887371ca1a1f5a1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 10:07:31 +0100 Subject: Add Page parser --- src/Hakyll/Web/Page/Read.hs | 62 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 src/Hakyll/Web/Page/Read.hs (limited to 'src') diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs new file mode 100644 index 0000000..f840eba --- /dev/null +++ b/src/Hakyll/Web/Page/Read.hs @@ -0,0 +1,62 @@ +-- | Module providing a function to parse a page from a file +-- +module Hakyll.Web.Page.Read + ( readPage + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second, (***)) +import Control.Monad.State +import Data.List (isPrefixOf) +import Data.Map (Map) +import qualified Data.Map as M + +import Hakyll.Web.Page +import Hakyll.Web.Util.String + +-- | We're using a simple state monad as parser +-- +type LineParser = State [String] + +-- | Check if the given string is a metadata delimiter. +-- +isPossibleDelimiter :: String -> Bool +isPossibleDelimiter = isPrefixOf "---" + +-- | Read the metadata section from a page +-- +parseMetadata :: LineParser (Map String String) +parseMetadata = get >>= \content -> case content of + -- No lines means no metadata + [] -> return M.empty + -- Check if the file begins with a delimiter + (l : ls) -> if not (isPossibleDelimiter l) + then -- No delimiter means no body + return M.empty + else do -- Break the metadata section + let (metadata, rest) = second (drop 1) $ break (== l) ls + -- Put the rest back + put rest + -- Parse the metadata + return $ M.fromList $ map parseMetadata' metadata + where + parseMetadata' :: String -> (String, String) + parseMetadata' = (trim *** trim . drop 1) . break (== ':') + +-- | Read the body section of a page +-- +parseBody :: LineParser String +parseBody = do + body <- get + put [] + return $ unlines body + +-- | Read an entire page +-- +parsePage :: LineParser (Page String) +parsePage = Page <$> parseMetadata <*> parseBody + +-- | Read a page from a string +-- +readPage :: String -> Page String +readPage = evalState parsePage . lines -- cgit v1.2.3 From d25dcb698e37765f35edf4c6e9b38e1d9dbb578e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 10:12:19 +0100 Subject: Fix typo in comments --- src/Hakyll/Web/Page/Read.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs index f840eba..c886fab 100644 --- a/src/Hakyll/Web/Page/Read.hs +++ b/src/Hakyll/Web/Page/Read.hs @@ -18,11 +18,6 @@ import Hakyll.Web.Util.String -- type LineParser = State [String] --- | Check if the given string is a metadata delimiter. --- -isPossibleDelimiter :: String -> Bool -isPossibleDelimiter = isPrefixOf "---" - -- | Read the metadata section from a page -- parseMetadata :: LineParser (Map String String) @@ -31,7 +26,7 @@ parseMetadata = get >>= \content -> case content of [] -> return M.empty -- Check if the file begins with a delimiter (l : ls) -> if not (isPossibleDelimiter l) - then -- No delimiter means no body + then -- No delimiter means no metadata return M.empty else do -- Break the metadata section let (metadata, rest) = second (drop 1) $ break (== l) ls @@ -40,7 +35,10 @@ parseMetadata = get >>= \content -> case content of -- Parse the metadata return $ M.fromList $ map parseMetadata' metadata where - parseMetadata' :: String -> (String, String) + -- Check if a line can be a delimiter + isPossibleDelimiter = isPrefixOf "---" + + -- Parse a "key: value" string to a (key, value) tupple parseMetadata' = (trim *** trim . drop 1) . break (== ':') -- | Read the body section of a page -- cgit v1.2.3 From bda268273b6cc18d8d1d9fb3170f92a06f6f45b8 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 11:14:04 +0100 Subject: Make pandoc functions work on pages by default --- src/Hakyll/Web/Page/Read.hs | 2 +- src/Hakyll/Web/Pandoc.hs | 46 +++++++++++++++++++++++++++------------------ 2 files changed, 29 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs index c886fab..82224a4 100644 --- a/src/Hakyll/Web/Page/Read.hs +++ b/src/Hakyll/Web/Page/Read.hs @@ -6,7 +6,7 @@ module Hakyll.Web.Page.Read import Control.Applicative ((<$>), (<*>)) import Control.Arrow (second, (***)) -import Control.Monad.State +import Control.Monad.State (State, get, put, evalState) import Data.List (isPrefixOf) import Data.Map (Map) import qualified Data.Map as M diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 52572a7..57fd1ac 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -1,25 +1,31 @@ -- | Module exporting pandoc bindings -- module Hakyll.Web.Pandoc - ( readPandoc + ( -- * The basic building blocks + readPandoc , readPandocWith , writePandoc , writePandocWith - , targetReadPandoc - , targetReadPandocWith - , targetRenderPandoc - , targetRenderPandocWith + + -- * Functions working on pages/targets + , pageReadPandoc + , pageReadPandocWith + , pageRenderPandoc + , pageRenderPandocWith + + -- * Default options , defaultParserState , defaultWriterOptions ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Text.Pandoc (Pandoc) import qualified Text.Pandoc as P -import Hakyll.Web.FileType import Hakyll.Core.Target +import Hakyll.Web.FileType +import Hakyll.Web.Page -- | Read a string using pandoc, with the default options -- @@ -58,26 +64,30 @@ writePandocWith = P.writeHtmlString -- | Read the resource using pandoc -- -targetReadPandoc :: TargetM a Pandoc -targetReadPandoc = targetReadPandocWith defaultParserState +pageReadPandoc :: Page String -> TargetM a (Page Pandoc) +pageReadPandoc = pageReadPandocWith defaultParserState -- | Read the resource using pandoc -- -targetReadPandocWith :: P.ParserState -> TargetM a Pandoc -targetReadPandocWith state = - readPandocWith state <$> getFileType <*> getResourceString +pageReadPandocWith :: P.ParserState -> Page String -> TargetM a (Page Pandoc) +pageReadPandocWith state page = do + fileType' <- getFileType + return $ readPandocWith state fileType' <$> page -- | Render the resource using pandoc -- -targetRenderPandoc :: TargetM a String -targetRenderPandoc = - targetRenderPandocWith defaultParserState defaultWriterOptions +pageRenderPandoc :: Page String -> TargetM a (Page String) +pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions -- | Render the resource using pandoc -- -targetRenderPandocWith :: P.ParserState -> P.WriterOptions -> TargetM a String -targetRenderPandocWith state options = - writePandocWith options <$> targetReadPandocWith state +pageRenderPandocWith :: P.ParserState + -> P.WriterOptions + -> Page String + -> TargetM a (Page String) +pageRenderPandocWith state options page = do + pandoc <- pageReadPandocWith state page + return $ writePandocWith options <$> pandoc -- | The default reader options for pandoc parsing in hakyll -- -- cgit v1.2.3 From e07014b5bd51fba81710d6b454df40ea62b6581a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 17:40:55 +0100 Subject: Targets have access to the store --- src/Hakyll/Core/Run.hs | 13 +++++++------ src/Hakyll/Core/Target/Internal.hs | 6 +++++- 2 files changed, 12 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 4683768..b5d6012 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -3,7 +3,7 @@ module Hakyll.Core.Run where import Control.Arrow ((&&&)) -import Control.Monad (msum, foldM, forM, forM_) +import Control.Monad (foldM, forM_) import qualified Data.Map as M import Hakyll.Core.Route @@ -12,18 +12,19 @@ import Hakyll.Core.ResourceProvider import Hakyll.Core.ResourceProvider.FileResourceProvider import Hakyll.Core.Rules import Hakyll.Core.Target -import Hakyll.Core.Identifier import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable +import Hakyll.Core.Store hakyll :: Writable a => Rules a -> IO () hakyll rules = do + store <- makeStore "_store" provider <- fileResourceProvider - hakyllWith rules provider + hakyllWith rules provider store -hakyllWith :: Writable a => Rules a -> ResourceProvider -> IO () -hakyllWith rules provider = do +hakyllWith :: Writable a => Rules a -> ResourceProvider -> Store -> IO () +hakyllWith rules provider store = do let -- Get the rule set ruleSet = runRules rules provider @@ -63,6 +64,6 @@ hakyllWith rules provider = do putStrLn "DONE." where addTarget map' (id', targ) = do - result <- runTarget targ id' (map' M.!) provider + result <- runTarget targ id' (map' M.!) provider store putStrLn $ "Generated target: " ++ show id' return $ M.insert id' result map' diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs index f40c798..dce4bfe 100644 --- a/src/Hakyll/Core/Target/Internal.hs +++ b/src/Hakyll/Core/Target/Internal.hs @@ -15,6 +15,7 @@ import Control.Monad.Reader (ReaderT, runReaderT) import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider +import Hakyll.Core.Store -- | A lookup with which we can get dependencies -- @@ -26,6 +27,7 @@ data TargetEnvironment a = TargetEnvironment { targetIdentifier :: Identifier -- ^ Identifier , targetDependencyLookup :: DependencyLookup a -- ^ Dependency lookup , targetResourceProvider :: ResourceProvider -- ^ To get resources + , targetStore :: Store -- ^ Store for caching } -- | Monad for targets. In this monad, the user can compose targets and describe @@ -45,11 +47,13 @@ runTarget :: Target a -> Identifier -> DependencyLookup a -> ResourceProvider + -> Store -> IO a -runTarget target id' lookup' provider = runReaderT (unTargetM target) env +runTarget target id' lookup' provider store = runReaderT (unTargetM target) env where env = TargetEnvironment { targetIdentifier = id' , targetDependencyLookup = lookup' , targetResourceProvider = provider + , targetStore = store } -- cgit v1.2.3 From a1043203bb4ef5bc1af4c9a8957af36d163f03fb Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 18:38:46 +0100 Subject: Add a snapshot state to target monad --- src/Hakyll/Core/Target/Internal.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs index dce4bfe..e68de33 100644 --- a/src/Hakyll/Core/Target/Internal.hs +++ b/src/Hakyll/Core/Target/Internal.hs @@ -12,6 +12,7 @@ module Hakyll.Core.Target.Internal import Control.Applicative (Applicative) import Control.Monad.Trans (MonadIO) import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.State (StateT, evalStateT) import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider @@ -30,11 +31,18 @@ data TargetEnvironment a = TargetEnvironment , targetStore :: Store -- ^ Store for caching } +-- | State for the target monad +-- +data TargetState = TargetState + { targetSnapshot :: Int -- ^ Snapshot ID + } + -- | Monad for targets. In this monad, the user can compose targets and describe -- how they should be created. -- -newtype TargetM a b = TargetM {unTargetM :: ReaderT (TargetEnvironment a) IO b} - deriving (Monad, Functor, Applicative, MonadIO) +newtype TargetM a b = TargetM + { unTargetM :: ReaderT (TargetEnvironment a) (StateT TargetState IO) b + } deriving (Monad, Functor, Applicative, MonadIO) -- | Simplification of the 'TargetM' type for concrete cases: the type of the -- returned item should equal the type of the dependencies. @@ -49,7 +57,8 @@ runTarget :: Target a -> ResourceProvider -> Store -> IO a -runTarget target id' lookup' provider store = runReaderT (unTargetM target) env +runTarget target id' lookup' provider store = + evalStateT (runReaderT (unTargetM target) env) state where env = TargetEnvironment { targetIdentifier = id' @@ -57,3 +66,6 @@ runTarget target id' lookup' provider store = runReaderT (unTargetM target) env , targetResourceProvider = provider , targetStore = store } + state = TargetState + { targetSnapshot = 0 + } -- cgit v1.2.3 From 6ffb83d46f0e1e82c38fa959464a98f6087f417f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Dec 2010 18:46:23 +0100 Subject: Binary instance for Page --- src/Hakyll/Web/Page.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 151364f..92303c1 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -7,8 +7,11 @@ module Hakyll.Web.Page , toMap ) where +import Control.Applicative ((<$>), (<*>)) + import Data.Map (Map) import qualified Data.Map as M +import Data.Binary (Binary, get, put) import Hakyll.Core.Writable @@ -22,6 +25,10 @@ data Page a = Page instance Functor Page where fmap f (Page m b) = Page m (f b) +instance Binary a => Binary (Page a) where + put (Page m b) = put m >> put b + get = Page <$> get <*> get + instance Writable a => Writable (Page a) where write p (Page _ b) = write p b -- cgit v1.2.3 From 27ff2eef890d86001c0210dd2d20639d34fbd32c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 28 Dec 2010 11:12:45 +0100 Subject: Use Typeable instead of ADT --- src/Hakyll/Core/CompiledItem.hs | 39 ++++++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Compiler.hs | 29 +++++++++++++++++----------- src/Hakyll/Core/Rules.hs | 39 +++++++++++++++++++++++++------------- src/Hakyll/Core/Run.hs | 34 ++++++++++++++++++++------------- src/Hakyll/Core/Target.hs | 5 ++--- src/Hakyll/Core/Target/Internal.hs | 29 ++++++++++++---------------- src/Hakyll/Web/FileType.hs | 2 +- src/Hakyll/Web/Page.hs | 4 +++- src/Hakyll/Web/Pandoc.hs | 18 +++++++++--------- 9 files changed, 131 insertions(+), 68 deletions(-) create mode 100644 src/Hakyll/Core/CompiledItem.hs (limited to 'src') diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs new file mode 100644 index 0000000..d191e2a --- /dev/null +++ b/src/Hakyll/Core/CompiledItem.hs @@ -0,0 +1,39 @@ +-- | A module containing a box datatype representing a compiled item. This +-- item can be of any type, given that a few restrictions hold (e.g. we want +-- a 'Typeable' instance to perform type-safe casts). +-- +{-# LANGUAGE ExistentialQuantification #-} +module Hakyll.Core.CompiledItem + ( CompiledItem + , compiledItem + , unCompiledItem + ) where + +import Data.Binary (Binary) +import Data.Typeable (Typeable, cast) + +import Hakyll.Core.Writable + +-- | Box type for a compiled item +-- +data CompiledItem = forall a. (Binary a, Typeable a, Writable a) + => CompiledItem a + +instance Writable CompiledItem where + write p (CompiledItem x) = write p x + +-- | Box a value into a 'CompiledItem' +-- +compiledItem :: (Binary a, Typeable a, Writable a) + => a + -> CompiledItem +compiledItem = CompiledItem + +-- | Unbox a value from a 'CompiledItem' +-- +unCompiledItem :: (Binary a, Typeable a, Writable a) + => CompiledItem + -> a +unCompiledItem (CompiledItem x) = case cast x of + Just x' -> x' + Nothing -> error "unCompiledItem: Unsupported type" diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 4e8b642..60c8ecb 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -16,10 +16,14 @@ import Control.Monad.State (State, modify, runState) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Data.Set (Set) import qualified Data.Set as S +import Data.Typeable (Typeable) +import Data.Binary (Binary) import Hakyll.Core.Identifier import Hakyll.Core.Target import Hakyll.Core.Target.Internal +import Hakyll.Core.CompiledItem +import Hakyll.Core.Writable -- | A set of dependencies -- @@ -27,7 +31,7 @@ type Dependencies = Set Identifier -- | Add one dependency -- -addDependency :: Identifier -> CompilerM a () +addDependency :: Identifier -> CompilerM () addDependency dependency = CompilerM $ modify $ addDependency' where addDependency' x = x @@ -36,8 +40,8 @@ addDependency dependency = CompilerM $ modify $ addDependency' -- | Environment in which a compiler runs -- -data CompilerEnvironment a = CompilerEnvironment - { compilerIdentifier :: Identifier -- ^ Target identifier +data CompilerEnvironment = CompilerEnvironment + { compilerIdentifier :: Identifier -- ^ Target identifier } -- | State carried along by a compiler @@ -48,18 +52,18 @@ data CompilerState = CompilerState -- | The compiler monad -- -newtype CompilerM a b = CompilerM - { unCompilerM :: ReaderT (CompilerEnvironment a) (State CompilerState) b +newtype CompilerM a = CompilerM + { unCompilerM :: ReaderT CompilerEnvironment (State CompilerState) a } deriving (Monad, Functor, Applicative) -- | Simplified type for a compiler generating a target (which covers most -- cases) -- -type Compiler a = CompilerM a (TargetM a a) +type Compiler a = CompilerM (TargetM a) -- | Run a compiler, yielding the resulting target and it's dependencies -- -runCompiler :: Compiler a -> Identifier -> (TargetM a a, Dependencies) +runCompiler :: Compiler a -> Identifier -> (TargetM a, Dependencies) runCompiler compiler identifier = second compilerDependencies $ runState (runReaderT (unCompilerM compiler) env) state where @@ -69,15 +73,18 @@ runCompiler compiler identifier = second compilerDependencies $ -- | Require another target. Using this function ensures automatic handling of -- dependencies -- -require :: Identifier +require :: (Binary a, Typeable a, Writable a) + => Identifier -> Compiler a require identifier = do addDependency identifier - return $ TargetM $ flip targetDependencyLookup identifier <$> ask + return $ TargetM $ do + lookup' <- targetDependencyLookup <$> ask + return $ unCompiledItem $ lookup' identifier -- | Construct a target from a string, this string being the content of the -- resource. -- -compileFromString :: (String -> TargetM a a) -- ^ Function to create the target - -> Compiler a -- ^ Resulting compiler +compileFromString :: (String -> TargetM a) -- ^ Function to create the target + -> Compiler a -- ^ Resulting compiler compileFromString = return . (getResourceString >>=) diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index d15b3b9..021af5d 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -15,57 +15,69 @@ module Hakyll.Core.Rules import Control.Applicative (Applicative, (<$>)) import Control.Monad.Writer import Control.Monad.Reader +import Control.Arrow (second) + +import Data.Typeable (Typeable) +import Data.Binary (Binary) import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Compiler import Hakyll.Core.Route +import Hakyll.Core.CompiledItem +import Hakyll.Core.Writable -- | A collection of rules for the compilation process -- -data RuleSet a = RuleSet +data RuleSet = RuleSet { rulesRoute :: Route - , rulesCompilers :: [(Identifier, Compiler a)] + , rulesCompilers :: [(Identifier, Compiler CompiledItem)] } -instance Monoid (RuleSet a) where +instance Monoid RuleSet where mempty = RuleSet mempty mempty mappend (RuleSet r1 c1) (RuleSet r2 c2) = RuleSet (mappend r1 r2) (mappend c1 c2) -- | The monad used to compose rules -- -newtype RulesM a b = RulesM - { unRulesM :: ReaderT ResourceProvider (Writer (RuleSet a)) b +newtype RulesM a = RulesM + { unRulesM :: ReaderT ResourceProvider (Writer RuleSet) a } deriving (Monad, Functor, Applicative) -- | Simplification of the RulesM type; usually, it will not return any -- result. -- -type Rules a = RulesM a () +type Rules = RulesM () -- | Run a Rules monad, resulting in a 'RuleSet' -- -runRules :: Rules a -> ResourceProvider -> RuleSet a +runRules :: Rules -> ResourceProvider -> RuleSet runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider -- | Add a route -- -addRoute :: Route -> Rules a +addRoute :: Route -> Rules addRoute route' = RulesM $ tell $ RuleSet route' mempty -- | Add a number of compilers -- -addCompilers :: [(Identifier, Compiler a)] -> Rules a -addCompilers compilers = RulesM $ tell $ RuleSet mempty compilers +addCompilers :: (Binary a, Typeable a, Writable a) + => [(Identifier, Compiler a)] + -> Rules +addCompilers compilers = RulesM $ tell $ RuleSet mempty $ + map (second boxCompiler) compilers + where + boxCompiler = fmap (fmap compiledItem) -- | Add a compilation rule -- -- This instructs all resources matching the given pattern to be compiled using -- the given compiler -- -compile :: Pattern -> Compiler a -> Rules a +compile :: (Binary a, Typeable a, Writable a) + => Pattern -> Compiler a -> Rules compile pattern compiler = RulesM $ do identifiers <- matches pattern . resourceList <$> ask unRulesM $ addCompilers $ zip identifiers (repeat compiler) @@ -74,10 +86,11 @@ compile pattern compiler = RulesM $ do -- -- This sets a compiler for the given identifier -- -create :: Identifier -> Compiler a -> RulesM a () +create :: (Binary a, Typeable a, Writable a) + => Identifier -> Compiler a -> Rules create identifier compiler = addCompilers [(identifier, compiler)] -- | Add a route -- -route :: Pattern -> Route -> RulesM a () +route :: Pattern -> Route -> Rules route pattern route' = addRoute $ ifMatch pattern route' diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index b5d6012..e2ff9f3 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -5,6 +5,9 @@ module Hakyll.Core.Run where import Control.Arrow ((&&&)) import Control.Monad (foldM, forM_) import qualified Data.Map as M +import Data.Monoid (mempty) +import Data.Typeable (Typeable) +import Data.Binary (Binary) import Hakyll.Core.Route import Hakyll.Core.Compiler @@ -16,14 +19,15 @@ import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable import Hakyll.Core.Store +import Hakyll.Core.CompiledItem -hakyll :: Writable a => Rules a -> IO () +hakyll :: Rules -> IO () hakyll rules = do store <- makeStore "_store" provider <- fileResourceProvider hakyllWith rules provider store -hakyllWith :: Writable a => Rules a -> ResourceProvider -> Store -> IO () +hakyllWith :: Rules -> ResourceProvider -> Store -> IO () hakyllWith rules provider store = do let -- Get the rule set ruleSet = runRules rules provider @@ -48,22 +52,26 @@ hakyllWith rules provider store = do -- Join the order with the targets again orderedTargets = map (id &&& (targetMap M.!)) ordered + -- Fetch the routes + route' = rulesRoute ruleSet + -- Generate all the targets in order - map' <- foldM addTarget M.empty orderedTargets + _ <- foldM (addTarget route') M.empty orderedTargets - let -- Fetch the routes - route' = rulesRoute ruleSet + putStrLn "DONE." + where + addTarget route' map' (id', targ) = do + compiled <- runTarget targ id' (dependencyLookup map') provider store + putStrLn $ "Generated target: " ++ show id' - forM_ (M.toList map') $ \(id', result) -> case runRoute route' id' of Nothing -> return () Just r -> do putStrLn $ "Routing " ++ show id' ++ " to " ++ r - write r result + write r compiled - putStrLn "DONE." - where - addTarget map' (id', targ) = do - result <- runTarget targ id' (map' M.!) provider store - putStrLn $ "Generated target: " ++ show id' - return $ M.insert id' result map' + return $ M.insert id' compiled map' + + dependencyLookup map' id' = case M.lookup id' map' of + Nothing -> error $ "dependencyLookup: " ++ show id' ++ " not found" + Just d -> d diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs index b8740bc..452fb57 100644 --- a/src/Hakyll/Core/Target.hs +++ b/src/Hakyll/Core/Target.hs @@ -4,7 +4,6 @@ module Hakyll.Core.Target ( DependencyLookup , TargetM - , Target , runTarget , getIdentifier , getResourceString @@ -20,12 +19,12 @@ import Hakyll.Core.ResourceProvider -- | Get the current identifier -- -getIdentifier :: TargetM a Identifier +getIdentifier :: TargetM Identifier getIdentifier = TargetM $ targetIdentifier <$> ask -- | Get the resource content as a string -- -getResourceString :: TargetM a String +getResourceString :: TargetM String getResourceString = TargetM $ do provider <- targetResourceProvider <$> ask identifier <- unTargetM getIdentifier diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs index e68de33..62fb4fc 100644 --- a/src/Hakyll/Core/Target/Internal.hs +++ b/src/Hakyll/Core/Target/Internal.hs @@ -1,11 +1,10 @@ -- | Internal structure of a Target, not exported outside of the library -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-} module Hakyll.Core.Target.Internal ( DependencyLookup , TargetEnvironment (..) , TargetM (..) - , Target , runTarget ) where @@ -17,18 +16,19 @@ import Control.Monad.State (StateT, evalStateT) import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Core.Store +import Hakyll.Core.CompiledItem -- | A lookup with which we can get dependencies -- -type DependencyLookup a = Identifier -> a +type DependencyLookup = Identifier -> CompiledItem -- | Environment for the target monad -- -data TargetEnvironment a = TargetEnvironment - { targetIdentifier :: Identifier -- ^ Identifier - , targetDependencyLookup :: DependencyLookup a -- ^ Dependency lookup - , targetResourceProvider :: ResourceProvider -- ^ To get resources - , targetStore :: Store -- ^ Store for caching +data TargetEnvironment = TargetEnvironment + { targetIdentifier :: Identifier -- ^ Identifier + , targetDependencyLookup :: DependencyLookup -- ^ Dependency lookup + , targetResourceProvider :: ResourceProvider -- ^ To get resources + , targetStore :: Store -- ^ Store for caching } -- | State for the target monad @@ -40,20 +40,15 @@ data TargetState = TargetState -- | Monad for targets. In this monad, the user can compose targets and describe -- how they should be created. -- -newtype TargetM a b = TargetM - { unTargetM :: ReaderT (TargetEnvironment a) (StateT TargetState IO) b +newtype TargetM a = TargetM + { unTargetM :: ReaderT TargetEnvironment (StateT TargetState IO) a } deriving (Monad, Functor, Applicative, MonadIO) --- | Simplification of the 'TargetM' type for concrete cases: the type of the --- returned item should equal the type of the dependencies. --- -type Target a = TargetM a a - -- | Run a target, yielding an actual result. -- -runTarget :: Target a +runTarget :: TargetM a -> Identifier - -> DependencyLookup a + -> DependencyLookup -> ResourceProvider -> Store -> IO a diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs index 4da1439..a958fed 100644 --- a/src/Hakyll/Web/FileType.hs +++ b/src/Hakyll/Web/FileType.hs @@ -51,5 +51,5 @@ fileType = fileType' . takeExtension -- | Get the file type for the current file -- -getFileType :: TargetM a FileType +getFileType :: TargetM FileType getFileType = fileType . toFilePath <$> getIdentifier diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 92303c1..78178cb 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -2,6 +2,7 @@ -- type 'String') and number of metadata fields. This type is used to represent -- pages on your website. -- +{-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page ( Page (..) , toMap @@ -12,6 +13,7 @@ import Control.Applicative ((<$>), (<*>)) import Data.Map (Map) import qualified Data.Map as M import Data.Binary (Binary, get, put) +import Data.Typeable (Typeable) import Hakyll.Core.Writable @@ -20,7 +22,7 @@ import Hakyll.Core.Writable data Page a = Page { pageMetadata :: Map String String , pageBody :: a - } + } deriving (Show, Typeable) instance Functor Page where fmap f (Page m b) = Page m (f b) diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 57fd1ac..17cac81 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -29,9 +29,9 @@ import Hakyll.Web.Page -- | Read a string using pandoc, with the default options -- -readPandoc :: FileType -- ^ File type, determines how parsing happens - -> String -- ^ String to read - -> Pandoc -- ^ Resulting document +readPandoc :: FileType -- ^ File type, determines how parsing happens + -> String -- ^ String to read + -> Pandoc -- ^ Resulting document readPandoc = readPandocWith defaultParserState -- | Read a string using pandoc, with the supplied options @@ -51,8 +51,8 @@ readPandocWith state fileType' = case fileType' of -- | Write a document (as HTML) using pandoc, with the default options -- -writePandoc :: Pandoc -- ^ Document to write - -> String -- ^ Resulting HTML +writePandoc :: Pandoc -- ^ Document to write + -> String -- ^ Resulting HTML writePandoc = writePandocWith defaultWriterOptions -- | Write a document (as HTML) using pandoc, with the supplied options @@ -64,19 +64,19 @@ writePandocWith = P.writeHtmlString -- | Read the resource using pandoc -- -pageReadPandoc :: Page String -> TargetM a (Page Pandoc) +pageReadPandoc :: Page String -> TargetM (Page Pandoc) pageReadPandoc = pageReadPandocWith defaultParserState -- | Read the resource using pandoc -- -pageReadPandocWith :: P.ParserState -> Page String -> TargetM a (Page Pandoc) +pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc) pageReadPandocWith state page = do fileType' <- getFileType return $ readPandocWith state fileType' <$> page -- | Render the resource using pandoc -- -pageRenderPandoc :: Page String -> TargetM a (Page String) +pageRenderPandoc :: Page String -> TargetM (Page String) pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions -- | Render the resource using pandoc @@ -84,7 +84,7 @@ pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions pageRenderPandocWith :: P.ParserState -> P.WriterOptions -> Page String - -> TargetM a (Page String) + -> TargetM (Page String) pageRenderPandocWith state options page = do pandoc <- pageReadPandocWith state page return $ writePandocWith options <$> pandoc -- cgit v1.2.3 From bf31c55c99496fe20274df73a831fb1db86591e4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 29 Dec 2010 15:33:22 +0100 Subject: Add requireAll function --- src/Hakyll/Core/Compiler.hs | 28 ++++++++++++++++++++++++---- src/Hakyll/Core/Run.hs | 12 ++++++++++-- 2 files changed, 34 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 60c8ecb..8a87fef 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -7,6 +7,7 @@ module Hakyll.Core.Compiler , Compiler , runCompiler , require + , requireAll , compileFromString ) where @@ -20,10 +21,12 @@ import Data.Typeable (Typeable) import Data.Binary (Binary) import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Target import Hakyll.Core.Target.Internal import Hakyll.Core.CompiledItem import Hakyll.Core.Writable +import Hakyll.Core.ResourceProvider -- | A set of dependencies -- @@ -41,7 +44,8 @@ addDependency dependency = CompilerM $ modify $ addDependency' -- | Environment in which a compiler runs -- data CompilerEnvironment = CompilerEnvironment - { compilerIdentifier :: Identifier -- ^ Target identifier + { compilerIdentifier :: Identifier -- ^ Target identifier + , compilerResourceProvider :: ResourceProvider -- ^ Resource provider } -- | State carried along by a compiler @@ -63,12 +67,17 @@ type Compiler a = CompilerM (TargetM a) -- | Run a compiler, yielding the resulting target and it's dependencies -- -runCompiler :: Compiler a -> Identifier -> (TargetM a, Dependencies) -runCompiler compiler identifier = second compilerDependencies $ +runCompiler :: Compiler a -> Identifier -> ResourceProvider + -> (TargetM a, Dependencies) +runCompiler compiler identifier provider = second compilerDependencies $ runState (runReaderT (unCompilerM compiler) env) state where - env = CompilerEnvironment {compilerIdentifier = identifier} state = CompilerState S.empty + env = CompilerEnvironment + { compilerIdentifier = identifier + , compilerResourceProvider = provider + } + -- | Require another target. Using this function ensures automatic handling of -- dependencies @@ -82,6 +91,17 @@ require identifier = do lookup' <- targetDependencyLookup <$> ask return $ unCompiledItem $ lookup' identifier +-- | Require a number of targets. Using this function ensures automatic handling +-- of dependencies +-- +requireAll :: (Binary a, Typeable a, Writable a) + => Pattern + -> Compiler [a] +requireAll pattern = CompilerM $ do + provider <- compilerResourceProvider <$> ask + r <- unCompilerM $ mapM require $ matches pattern $ resourceList provider + return $ sequence r + -- | Construct a target from a string, this string being the content of the -- resource. -- diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index e2ff9f3..1a79aa9 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -8,14 +8,17 @@ import qualified Data.Map as M import Data.Monoid (mempty) import Data.Typeable (Typeable) import Data.Binary (Binary) +import System.FilePath (()) import Hakyll.Core.Route +import Hakyll.Core.Util.File import Hakyll.Core.Compiler import Hakyll.Core.ResourceProvider import Hakyll.Core.ResourceProvider.FileResourceProvider import Hakyll.Core.Rules import Hakyll.Core.Target import Hakyll.Core.DirectedGraph +import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable import Hakyll.Core.Store @@ -37,7 +40,7 @@ hakyllWith rules provider store = do -- Get all targets targets = flip map compilers $ \(id', compiler) -> - let (targ, deps) = runCompiler compiler id' + let (targ, deps) = runCompiler compiler id' provider in (id', targ, deps) -- Map mapping every identifier to it's target @@ -55,6 +58,9 @@ hakyllWith rules provider store = do -- Fetch the routes route' = rulesRoute ruleSet + putStrLn "Writing dependency graph to dependencies.dot..." + writeDot "dependencies.dot" show graph + -- Generate all the targets in order _ <- foldM (addTarget route') M.empty orderedTargets @@ -68,7 +74,9 @@ hakyllWith rules provider store = do Nothing -> return () Just r -> do putStrLn $ "Routing " ++ show id' ++ " to " ++ r - write r compiled + let path = "_site" r + makeDirectories path + write path compiled return $ M.insert id' compiled map' -- cgit v1.2.3 From 6268e4a4fe961ca810da1ecb2275142a301f0813 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 29 Dec 2010 22:59:38 +0100 Subject: Experimental arrow-based approach --- src/Hakyll/Core/Compiler.hs | 104 ++++++++++++++++++++++++------------- src/Hakyll/Core/Rules.hs | 12 ++--- src/Hakyll/Core/Run.hs | 30 +++++------ src/Hakyll/Core/Target.hs | 31 ----------- src/Hakyll/Core/Target/Internal.hs | 66 ----------------------- src/Hakyll/Web/FileType.hs | 8 +-- src/Hakyll/Web/Pandoc.hs | 6 ++- 7 files changed, 98 insertions(+), 159 deletions(-) delete mode 100644 src/Hakyll/Core/Target.hs delete mode 100644 src/Hakyll/Core/Target/Internal.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 8a87fef..c4a7b06 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -4,26 +4,32 @@ module Hakyll.Core.Compiler ( Dependencies , CompilerM - , Compiler + , Compiler (..) , runCompiler + , getIdentifier + , getResourceString , require - , requireAll - , compileFromString + -- , requireAll + -- , compileFromString ) where -import Control.Arrow (second) +import Prelude hiding ((.), id) +import Control.Arrow (second, (>>>)) import Control.Applicative (Applicative, (<$>)) import Control.Monad.State (State, modify, runState) import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans (liftIO) +import Control.Monad ((<=<)) import Data.Set (Set) import qualified Data.Set as S -import Data.Typeable (Typeable) +import Control.Category (Category, (.), id) +import Control.Arrow (Arrow, arr, first) + import Data.Binary (Binary) +import Data.Typeable (Typeable) import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.Target -import Hakyll.Core.Target.Internal import Hakyll.Core.CompiledItem import Hakyll.Core.Writable import Hakyll.Core.ResourceProvider @@ -32,65 +38,92 @@ import Hakyll.Core.ResourceProvider -- type Dependencies = Set Identifier --- | Add one dependency +-- | A lookup with which we can get dependencies -- -addDependency :: Identifier -> CompilerM () -addDependency dependency = CompilerM $ modify $ addDependency' - where - addDependency' x = x - { compilerDependencies = S.insert dependency $ compilerDependencies x - } +type DependencyLookup = Identifier -> CompiledItem -- | Environment in which a compiler runs -- data CompilerEnvironment = CompilerEnvironment { compilerIdentifier :: Identifier -- ^ Target identifier , compilerResourceProvider :: ResourceProvider -- ^ Resource provider - } - --- | State carried along by a compiler --- -data CompilerState = CompilerState - { compilerDependencies :: Dependencies + , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup } -- | The compiler monad -- newtype CompilerM a = CompilerM - { unCompilerM :: ReaderT CompilerEnvironment (State CompilerState) a + { unCompilerM :: ReaderT CompilerEnvironment IO a } deriving (Monad, Functor, Applicative) --- | Simplified type for a compiler generating a target (which covers most --- cases) +-- | The compiler arrow -- -type Compiler a = CompilerM (TargetM a) +data Compiler a b = Compiler + { -- TODO: Reader ResourceProvider Dependencies + compilerDependencies :: Dependencies + , compilerJob :: a -> CompilerM b + } + +instance Category Compiler where + id = Compiler S.empty return + (Compiler d1 j1) . (Compiler d2 j2) = + Compiler (d1 `S.union` d2) (j1 <=< j2) + +instance Arrow Compiler where + arr f = Compiler S.empty (return . f) + first (Compiler d j) = Compiler d $ \(x, y) -> do + x' <- j x + return (x', y) -- | Run a compiler, yielding the resulting target and it's dependencies -- -runCompiler :: Compiler a -> Identifier -> ResourceProvider - -> (TargetM a, Dependencies) -runCompiler compiler identifier provider = second compilerDependencies $ - runState (runReaderT (unCompilerM compiler) env) state +runCompiler :: Compiler () a + -> Identifier + -> ResourceProvider + -> DependencyLookup + -> IO a +runCompiler compiler identifier provider lookup' = + runReaderT (unCompilerM $ compilerJob compiler ()) env where - state = CompilerState S.empty env = CompilerEnvironment { compilerIdentifier = identifier , compilerResourceProvider = provider + , compilerDependencyLookup = lookup' } +addDependency :: Identifier + -> Compiler b b +addDependency id' = Compiler (S.singleton id') return + +fromCompilerM :: (a -> CompilerM b) + -> Compiler a b +fromCompilerM = Compiler S.empty + +getIdentifier :: Compiler () Identifier +getIdentifier = fromCompilerM $ const $ CompilerM $ + compilerIdentifier <$> ask + +getResourceString :: Compiler () String +getResourceString = getIdentifier >>> getResourceString' + where + getResourceString' = fromCompilerM $ \id' -> CompilerM $ do + provider <- compilerResourceProvider <$> ask + liftIO $ resourceString provider id' -- | Require another target. Using this function ensures automatic handling of -- dependencies -- require :: (Binary a, Typeable a, Writable a) => Identifier - -> Compiler a -require identifier = do - addDependency identifier - return $ TargetM $ do - lookup' <- targetDependencyLookup <$> ask - return $ unCompiledItem $ lookup' identifier + -> (a -> b -> c) + -> Compiler b c +require identifier f = addDependency identifier >>> fromCompilerM require' + where + require' x = CompilerM $ do + lookup' <- compilerDependencyLookup <$> ask + return $ f (unCompiledItem $ lookup' identifier) x +{- -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies -- @@ -108,3 +141,4 @@ requireAll pattern = CompilerM $ do compileFromString :: (String -> TargetM a) -- ^ Function to create the target -> Compiler a -- ^ Resulting compiler compileFromString = return . (getResourceString >>=) +-} diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 021af5d..de7f6d4 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -15,7 +15,7 @@ module Hakyll.Core.Rules import Control.Applicative (Applicative, (<$>)) import Control.Monad.Writer import Control.Monad.Reader -import Control.Arrow (second) +import Control.Arrow (second, (>>>), arr) import Data.Typeable (Typeable) import Data.Binary (Binary) @@ -32,7 +32,7 @@ import Hakyll.Core.Writable -- data RuleSet = RuleSet { rulesRoute :: Route - , rulesCompilers :: [(Identifier, Compiler CompiledItem)] + , rulesCompilers :: [(Identifier, Compiler () CompiledItem)] } instance Monoid RuleSet where @@ -64,12 +64,12 @@ addRoute route' = RulesM $ tell $ RuleSet route' mempty -- | Add a number of compilers -- addCompilers :: (Binary a, Typeable a, Writable a) - => [(Identifier, Compiler a)] + => [(Identifier, Compiler () a)] -> Rules addCompilers compilers = RulesM $ tell $ RuleSet mempty $ map (second boxCompiler) compilers where - boxCompiler = fmap (fmap compiledItem) + boxCompiler = (>>> arr compiledItem) -- | Add a compilation rule -- @@ -77,7 +77,7 @@ addCompilers compilers = RulesM $ tell $ RuleSet mempty $ -- the given compiler -- compile :: (Binary a, Typeable a, Writable a) - => Pattern -> Compiler a -> Rules + => Pattern -> Compiler () a -> Rules compile pattern compiler = RulesM $ do identifiers <- matches pattern . resourceList <$> ask unRulesM $ addCompilers $ zip identifiers (repeat compiler) @@ -87,7 +87,7 @@ compile pattern compiler = RulesM $ do -- This sets a compiler for the given identifier -- create :: (Binary a, Typeable a, Writable a) - => Identifier -> Compiler a -> Rules + => Identifier -> Compiler () a -> Rules create identifier compiler = addCompilers [(identifier, compiler)] -- | Add a route diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 1a79aa9..3bd1e6b 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -11,12 +11,12 @@ import Data.Binary (Binary) import System.FilePath (()) import Hakyll.Core.Route +import Hakyll.Core.Identifier import Hakyll.Core.Util.File import Hakyll.Core.Compiler import Hakyll.Core.ResourceProvider import Hakyll.Core.ResourceProvider.FileResourceProvider import Hakyll.Core.Rules -import Hakyll.Core.Target import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver @@ -38,22 +38,20 @@ hakyllWith rules provider store = do -- Get all identifiers and compilers compilers = rulesCompilers ruleSet - -- Get all targets - targets = flip map compilers $ \(id', compiler) -> - let (targ, deps) = runCompiler compiler id' provider - in (id', targ, deps) + -- Get all dependencies + dependencies = flip map compilers $ \(id', compiler) -> + let deps = compilerDependencies compiler + in (id', deps) - -- Map mapping every identifier to it's target - targetMap = M.fromList $ map (\(i, t, _) -> (i, t)) targets + -- Create a compiler map + compilerMap = M.fromList compilers - -- Create a dependency graph - graph = fromList $ map (\(i, _, d) -> (i, d)) targets - - -- Solve the graph, creating a target order + -- Create and solve the graph, creating a compiler order + graph = fromList dependencies ordered = solveDependencies graph - -- Join the order with the targets again - orderedTargets = map (id &&& (targetMap M.!)) ordered + -- Join the order with the compilers again + orderedCompilers = map (id &&& (compilerMap M.!)) ordered -- Fetch the routes route' = rulesRoute ruleSet @@ -62,12 +60,12 @@ hakyllWith rules provider store = do writeDot "dependencies.dot" show graph -- Generate all the targets in order - _ <- foldM (addTarget route') M.empty orderedTargets + _ <- foldM (addTarget route') M.empty orderedCompilers putStrLn "DONE." where - addTarget route' map' (id', targ) = do - compiled <- runTarget targ id' (dependencyLookup map') provider store + addTarget route' map' (id', comp) = do + compiled <- runCompiler comp id' provider (dependencyLookup map') putStrLn $ "Generated target: " ++ show id' case runRoute route' id' of diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs deleted file mode 100644 index 452fb57..0000000 --- a/src/Hakyll/Core/Target.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | A target represents one compilation unit, e.g. a blog post, a CSS file... --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Hakyll.Core.Target - ( DependencyLookup - , TargetM - , runTarget - , getIdentifier - , getResourceString - ) where - -import Control.Applicative ((<$>)) -import Control.Monad.Reader (ask) -import Control.Monad.Trans (liftIO) - -import Hakyll.Core.Identifier -import Hakyll.Core.Target.Internal -import Hakyll.Core.ResourceProvider - --- | Get the current identifier --- -getIdentifier :: TargetM Identifier -getIdentifier = TargetM $ targetIdentifier <$> ask - --- | Get the resource content as a string --- -getResourceString :: TargetM String -getResourceString = TargetM $ do - provider <- targetResourceProvider <$> ask - identifier <- unTargetM getIdentifier - liftIO $ resourceString provider identifier diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs deleted file mode 100644 index 62fb4fc..0000000 --- a/src/Hakyll/Core/Target/Internal.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | Internal structure of a Target, not exported outside of the library --- -{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-} -module Hakyll.Core.Target.Internal - ( DependencyLookup - , TargetEnvironment (..) - , TargetM (..) - , runTarget - ) where - -import Control.Applicative (Applicative) -import Control.Monad.Trans (MonadIO) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State (StateT, evalStateT) - -import Hakyll.Core.Identifier -import Hakyll.Core.ResourceProvider -import Hakyll.Core.Store -import Hakyll.Core.CompiledItem - --- | A lookup with which we can get dependencies --- -type DependencyLookup = Identifier -> CompiledItem - --- | Environment for the target monad --- -data TargetEnvironment = TargetEnvironment - { targetIdentifier :: Identifier -- ^ Identifier - , targetDependencyLookup :: DependencyLookup -- ^ Dependency lookup - , targetResourceProvider :: ResourceProvider -- ^ To get resources - , targetStore :: Store -- ^ Store for caching - } - --- | State for the target monad --- -data TargetState = TargetState - { targetSnapshot :: Int -- ^ Snapshot ID - } - --- | Monad for targets. In this monad, the user can compose targets and describe --- how they should be created. --- -newtype TargetM a = TargetM - { unTargetM :: ReaderT TargetEnvironment (StateT TargetState IO) a - } deriving (Monad, Functor, Applicative, MonadIO) - --- | Run a target, yielding an actual result. --- -runTarget :: TargetM a - -> Identifier - -> DependencyLookup - -> ResourceProvider - -> Store - -> IO a -runTarget target id' lookup' provider store = - evalStateT (runReaderT (unTargetM target) env) state - where - env = TargetEnvironment - { targetIdentifier = id' - , targetDependencyLookup = lookup' - , targetResourceProvider = provider - , targetStore = store - } - state = TargetState - { targetSnapshot = 0 - } diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs index a958fed..d5a9c56 100644 --- a/src/Hakyll/Web/FileType.hs +++ b/src/Hakyll/Web/FileType.hs @@ -7,10 +7,10 @@ module Hakyll.Web.FileType ) where import System.FilePath (takeExtension) -import Control.Applicative ((<$>)) +import Control.Arrow ((>>>), arr) import Hakyll.Core.Identifier -import Hakyll.Core.Target +import Hakyll.Core.Compiler -- | Datatype to represent the different file types Hakyll can deal with by -- default @@ -51,5 +51,5 @@ fileType = fileType' . takeExtension -- | Get the file type for the current file -- -getFileType :: TargetM FileType -getFileType = fileType . toFilePath <$> getIdentifier +getFileType :: Compiler () FileType +getFileType = getIdentifier >>> arr (fileType . toFilePath) diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 17cac81..653c711 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -8,10 +8,12 @@ module Hakyll.Web.Pandoc , writePandocWith -- * Functions working on pages/targets + {- , pageReadPandoc , pageReadPandocWith , pageRenderPandoc , pageRenderPandocWith + -} -- * Default options , defaultParserState @@ -23,7 +25,7 @@ import Control.Applicative ((<$>)) import Text.Pandoc (Pandoc) import qualified Text.Pandoc as P -import Hakyll.Core.Target +import Hakyll.Core.Compiler import Hakyll.Web.FileType import Hakyll.Web.Page @@ -62,6 +64,7 @@ writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc -> String -- ^ Resulting HTML writePandocWith = P.writeHtmlString +{- -- | Read the resource using pandoc -- pageReadPandoc :: Page String -> TargetM (Page Pandoc) @@ -88,6 +91,7 @@ pageRenderPandocWith :: P.ParserState pageRenderPandocWith state options page = do pandoc <- pageReadPandocWith state page return $ writePandocWith options <$> pandoc +-} -- | The default reader options for pandoc parsing in hakyll -- -- cgit v1.2.3 From 1c1133dfd6adae7c9c667d47eabaabb89cf8bdf9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 10:02:25 +0100 Subject: More arrows --- src/Hakyll/Core/Compiler.hs | 54 ++++++++++++++++++++++++++----------------- src/Hakyll/Core/Run.hs | 2 +- src/Hakyll/Core/Util/Arrow.hs | 28 ++++++++++++++++++++++ src/Hakyll/Web/Pandoc.hs | 31 ++++++++++++------------- 4 files changed, 77 insertions(+), 38 deletions(-) create mode 100644 src/Hakyll/Core/Util/Arrow.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index c4a7b06..a2875ba 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -6,10 +6,11 @@ module Hakyll.Core.Compiler , CompilerM , Compiler (..) , runCompiler + , getDependencies , getIdentifier , getResourceString , require - -- , requireAll + , requireAll -- , compileFromString ) where @@ -17,9 +18,9 @@ import Prelude hiding ((.), id) import Control.Arrow (second, (>>>)) import Control.Applicative (Applicative, (<$>)) import Control.Monad.State (State, modify, runState) -import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) import Control.Monad.Trans (liftIO) -import Control.Monad ((<=<)) +import Control.Monad ((<=<), liftM2) import Data.Set (Set) import qualified Data.Set as S import Control.Category (Category, (.), id) @@ -59,18 +60,17 @@ newtype CompilerM a = CompilerM -- | The compiler arrow -- data Compiler a b = Compiler - { -- TODO: Reader ResourceProvider Dependencies - compilerDependencies :: Dependencies + { compilerDependencies :: Reader ResourceProvider Dependencies , compilerJob :: a -> CompilerM b } instance Category Compiler where - id = Compiler S.empty return + id = Compiler (return S.empty) return (Compiler d1 j1) . (Compiler d2 j2) = - Compiler (d1 `S.union` d2) (j1 <=< j2) + Compiler (liftM2 S.union d1 d2) (j1 <=< j2) instance Arrow Compiler where - arr f = Compiler S.empty (return . f) + arr f = Compiler (return S.empty) (return . f) first (Compiler d j) = Compiler d $ \(x, y) -> do x' <- j x return (x', y) @@ -91,13 +91,19 @@ runCompiler compiler identifier provider lookup' = , compilerDependencyLookup = lookup' } -addDependency :: Identifier - -> Compiler b b -addDependency id' = Compiler (S.singleton id') return +getDependencies :: Compiler () a + -> ResourceProvider + -> Dependencies +getDependencies compiler provider = + runReader (compilerDependencies compiler) provider + +addDependencies :: (ResourceProvider -> [Identifier]) + -> Compiler b b +addDependencies deps = Compiler (S.fromList . deps <$> ask) return fromCompilerM :: (a -> CompilerM b) -> Compiler a b -fromCompilerM = Compiler S.empty +fromCompilerM = Compiler (return S.empty) getIdentifier :: Compiler () Identifier getIdentifier = fromCompilerM $ const $ CompilerM $ @@ -115,26 +121,32 @@ getResourceString = getIdentifier >>> getResourceString' -- require :: (Binary a, Typeable a, Writable a) => Identifier - -> (a -> b -> c) + -> (b -> a -> c) -> Compiler b c -require identifier f = addDependency identifier >>> fromCompilerM require' +require identifier f = + addDependencies (const [identifier]) >>> fromCompilerM require' where require' x = CompilerM $ do lookup' <- compilerDependencyLookup <$> ask - return $ f (unCompiledItem $ lookup' identifier) x + return $ f x $ unCompiledItem $ lookup' identifier -{- -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies -- requireAll :: (Binary a, Typeable a, Writable a) => Pattern - -> Compiler [a] -requireAll pattern = CompilerM $ do - provider <- compilerResourceProvider <$> ask - r <- unCompilerM $ mapM require $ matches pattern $ resourceList provider - return $ sequence r + -> (b -> [a] -> c) + -> Compiler b c +requireAll pattern f = + addDependencies getDeps >>> fromCompilerM requireAll' + where + getDeps = matches pattern . resourceList + requireAll' x = CompilerM $ do + deps <- getDeps . compilerResourceProvider <$> ask + lookup' <- compilerDependencyLookup <$> ask + return $ f x $ map (unCompiledItem . lookup') deps +{- -- | Construct a target from a string, this string being the content of the -- resource. -- diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 3bd1e6b..911e2f9 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -40,7 +40,7 @@ hakyllWith rules provider store = do -- Get all dependencies dependencies = flip map compilers $ \(id', compiler) -> - let deps = compilerDependencies compiler + let deps = getDependencies compiler provider in (id', deps) -- Create a compiler map diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs new file mode 100644 index 0000000..d25bc28 --- /dev/null +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -0,0 +1,28 @@ +-- | Various arrow utility functions +-- +module Hakyll.Core.Util.Arrow + ( sequenceArr + , unitArr + , withUnitArr + ) where + +import Prelude hiding (id) +import Control.Arrow (Arrow, (&&&), (>>>), arr, (***)) +import Control.Category (id) + +sequenceArr :: Arrow a + => [a b c] + -> a b [c] +sequenceArr = foldl reduce $ arr $ const [] + where + reduce la xa = xa &&& la >>> arr (uncurry (:)) + +unitArr :: Arrow a + => a b () +unitArr = arr (const ()) + +withUnitArr :: Arrow a + => a b c + -> a () d + -> a b (c, d) +withUnitArr a1 a2 = a1 &&& unitArr >>> id *** a2 diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 653c711..c03c6ca 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -7,25 +7,27 @@ module Hakyll.Web.Pandoc , writePandoc , writePandocWith - -- * Functions working on pages/targets - {- + -- * Functions working on pages/compilers , pageReadPandoc , pageReadPandocWith , pageRenderPandoc , pageRenderPandocWith - -} -- * Default options , defaultParserState , defaultWriterOptions ) where +import Prelude hiding (id) import Control.Applicative ((<$>)) +import Control.Arrow ((>>>), arr) +import Control.Category (id) import Text.Pandoc (Pandoc) import qualified Text.Pandoc as P import Hakyll.Core.Compiler +import Hakyll.Core.Util.Arrow import Hakyll.Web.FileType import Hakyll.Web.Page @@ -64,34 +66,31 @@ writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc -> String -- ^ Resulting HTML writePandocWith = P.writeHtmlString -{- -- | Read the resource using pandoc -- -pageReadPandoc :: Page String -> TargetM (Page Pandoc) +pageReadPandoc :: Compiler (Page String) (Page Pandoc) pageReadPandoc = pageReadPandocWith defaultParserState -- | Read the resource using pandoc -- -pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc) -pageReadPandocWith state page = do - fileType' <- getFileType - return $ readPandocWith state fileType' <$> page +pageReadPandocWith :: P.ParserState -> Compiler (Page String) (Page Pandoc) +pageReadPandocWith state = + withUnitArr id getFileType >>> arr pageReadPandocWith' + where + pageReadPandocWith' (p, t) = readPandocWith state t <$> p -- | Render the resource using pandoc -- -pageRenderPandoc :: Page String -> TargetM (Page String) +pageRenderPandoc :: Compiler (Page String) (Page String) pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions -- | Render the resource using pandoc -- pageRenderPandocWith :: P.ParserState -> P.WriterOptions - -> Page String - -> TargetM (Page String) -pageRenderPandocWith state options page = do - pandoc <- pageReadPandocWith state page - return $ writePandocWith options <$> pandoc --} + -> Compiler (Page String) (Page String) +pageRenderPandocWith state options = + pageReadPandocWith state >>> arr (fmap $ writePandocWith options) -- | The default reader options for pandoc parsing in hakyll -- -- cgit v1.2.3 From 687c17c6bb1bc312a5660492164a9f00d710212a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 10:11:37 +0100 Subject: Cleanup arrow code --- src/Hakyll/Core/Compiler.hs | 4 ++-- src/Hakyll/Core/Util/Arrow.hs | 37 +++++++++++++++++-------------------- src/Hakyll/Web/FileType.hs | 6 +++--- src/Hakyll/Web/Pandoc.hs | 7 +++---- 4 files changed, 25 insertions(+), 29 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index a2875ba..5a1741c 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -105,11 +105,11 @@ fromCompilerM :: (a -> CompilerM b) -> Compiler a b fromCompilerM = Compiler (return S.empty) -getIdentifier :: Compiler () Identifier +getIdentifier :: Compiler a Identifier getIdentifier = fromCompilerM $ const $ CompilerM $ compilerIdentifier <$> ask -getResourceString :: Compiler () String +getResourceString :: Compiler a String getResourceString = getIdentifier >>> getResourceString' where getResourceString' = fromCompilerM $ \id' -> CompilerM $ do diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index d25bc28..1896e11 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -1,28 +1,25 @@ -- | Various arrow utility functions -- module Hakyll.Core.Util.Arrow - ( sequenceArr - , unitArr - , withUnitArr + ( constA + , sequenceA + , unitA ) where -import Prelude hiding (id) -import Control.Arrow (Arrow, (&&&), (>>>), arr, (***)) -import Control.Category (id) +import Control.Arrow (Arrow, (&&&), arr, (>>^)) -sequenceArr :: Arrow a - => [a b c] - -> a b [c] -sequenceArr = foldl reduce $ arr $ const [] - where - reduce la xa = xa &&& la >>> arr (uncurry (:)) +constA :: Arrow a + => c + -> a b c +constA = arr . const -unitArr :: Arrow a - => a b () -unitArr = arr (const ()) +sequenceA :: Arrow a + => [a b c] + -> a b [c] +sequenceA = foldl reduce $ constA [] + where + reduce la xa = xa &&& la >>^ arr (uncurry (:)) -withUnitArr :: Arrow a - => a b c - -> a () d - -> a b (c, d) -withUnitArr a1 a2 = a1 &&& unitArr >>> id *** a2 +unitA :: Arrow a + => a b () +unitA = constA () diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs index d5a9c56..cd1188a 100644 --- a/src/Hakyll/Web/FileType.hs +++ b/src/Hakyll/Web/FileType.hs @@ -7,7 +7,7 @@ module Hakyll.Web.FileType ) where import System.FilePath (takeExtension) -import Control.Arrow ((>>>), arr) +import Control.Arrow ((>>^)) import Hakyll.Core.Identifier import Hakyll.Core.Compiler @@ -51,5 +51,5 @@ fileType = fileType' . takeExtension -- | Get the file type for the current file -- -getFileType :: Compiler () FileType -getFileType = getIdentifier >>> arr (fileType . toFilePath) +getFileType :: Compiler a FileType +getFileType = getIdentifier >>^ fileType . toFilePath diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index c03c6ca..7fecdc4 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -20,14 +20,13 @@ module Hakyll.Web.Pandoc import Prelude hiding (id) import Control.Applicative ((<$>)) -import Control.Arrow ((>>>), arr) +import Control.Arrow ((>>^), (&&&)) import Control.Category (id) import Text.Pandoc (Pandoc) import qualified Text.Pandoc as P import Hakyll.Core.Compiler -import Hakyll.Core.Util.Arrow import Hakyll.Web.FileType import Hakyll.Web.Page @@ -75,7 +74,7 @@ pageReadPandoc = pageReadPandocWith defaultParserState -- pageReadPandocWith :: P.ParserState -> Compiler (Page String) (Page Pandoc) pageReadPandocWith state = - withUnitArr id getFileType >>> arr pageReadPandocWith' + id &&& getFileType >>^ pageReadPandocWith' where pageReadPandocWith' (p, t) = readPandocWith state t <$> p @@ -90,7 +89,7 @@ pageRenderPandocWith :: P.ParserState -> P.WriterOptions -> Compiler (Page String) (Page String) pageRenderPandocWith state options = - pageReadPandocWith state >>> arr (fmap $ writePandocWith options) + pageReadPandocWith state >>^ (fmap $ writePandocWith options) -- | The default reader options for pandoc parsing in hakyll -- -- cgit v1.2.3 From 86fafe6e61f71428f933f62a3c68cb3819c189c9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 13:49:58 +0100 Subject: Add CopyFile newtype --- src/Hakyll/Core/Writable.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs index d6c3683..a93903f 100644 --- a/src/Hakyll/Core/Writable.hs +++ b/src/Hakyll/Core/Writable.hs @@ -1,10 +1,17 @@ -- | Describes writable items; items that can be saved to the disk -- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, + DeriveDataTypeable #-} module Hakyll.Core.Writable ( Writable (..) + , CopyFile (..) ) where +import System.Directory (copyFile) + +import Data.Binary (Binary) +import Data.Typeable (Typeable) + -- | Describes an item that can be saved to the disk -- class Writable a where @@ -13,3 +20,11 @@ class Writable a where instance Writable [Char] where write = writeFile + +-- | Newtype construct around 'FilePath' which will copy the file directly +-- +newtype CopyFile = CopyFile {unCopyFile :: FilePath} + deriving (Show, Eq, Ord, Binary, Typeable) + +instance Writable CopyFile where + write dst (CopyFile src) = copyFile src dst -- cgit v1.2.3 From 227b186bf2420d027b97f4e1392b206a80a04214 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 15:57:36 +0100 Subject: Remove compileFromString function --- src/Hakyll/Core/Compiler.hs | 10 ---------- 1 file changed, 10 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 5a1741c..7837991 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -11,7 +11,6 @@ module Hakyll.Core.Compiler , getResourceString , require , requireAll - -- , compileFromString ) where import Prelude hiding ((.), id) @@ -145,12 +144,3 @@ requireAll pattern f = deps <- getDeps . compilerResourceProvider <$> ask lookup' <- compilerDependencyLookup <$> ask return $ f x $ map (unCompiledItem . lookup') deps - -{- --- | Construct a target from a string, this string being the content of the --- resource. --- -compileFromString :: (String -> TargetM a) -- ^ Function to create the target - -> Compiler a -- ^ Resulting compiler -compileFromString = return . (getResourceString >>=) --} -- cgit v1.2.3 From da12825066d16884bae2f884029102919dd9a558 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 17:47:31 +0100 Subject: Compiler → {Compiler, Compiler.Internal} MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Core/Compiler.hs | 98 ++++-------------------------------- src/Hakyll/Core/Compiler/Internal.hs | 96 +++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Run.hs | 5 +- 3 files changed, 109 insertions(+), 90 deletions(-) create mode 100644 src/Hakyll/Core/Compiler/Internal.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 7837991..d0e219e 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -2,11 +2,7 @@ -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler - ( Dependencies - , CompilerM - , Compiler (..) - , runCompiler - , getDependencies + ( Compiler , getIdentifier , getResourceString , require @@ -14,16 +10,11 @@ module Hakyll.Core.Compiler ) where import Prelude hiding ((.), id) -import Control.Arrow (second, (>>>)) -import Control.Applicative (Applicative, (<$>)) -import Control.Monad.State (State, modify, runState) -import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) +import Control.Arrow ((>>>)) +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) -import Control.Monad ((<=<), liftM2) -import Data.Set (Set) -import qualified Data.Set as S -import Control.Category (Category, (.), id) -import Control.Arrow (Arrow, arr, first) +import Control.Category (Category, (.)) import Data.Binary (Binary) import Data.Typeable (Typeable) @@ -33,85 +24,16 @@ import Hakyll.Core.Identifier.Pattern import Hakyll.Core.CompiledItem import Hakyll.Core.Writable import Hakyll.Core.ResourceProvider - --- | A set of dependencies --- -type Dependencies = Set Identifier - --- | A lookup with which we can get dependencies --- -type DependencyLookup = Identifier -> CompiledItem - --- | Environment in which a compiler runs --- -data CompilerEnvironment = CompilerEnvironment - { compilerIdentifier :: Identifier -- ^ Target identifier - , compilerResourceProvider :: ResourceProvider -- ^ Resource provider - , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup - } - --- | The compiler monad --- -newtype CompilerM a = CompilerM - { unCompilerM :: ReaderT CompilerEnvironment IO a - } deriving (Monad, Functor, Applicative) - --- | The compiler arrow --- -data Compiler a b = Compiler - { compilerDependencies :: Reader ResourceProvider Dependencies - , compilerJob :: a -> CompilerM b - } - -instance Category Compiler where - id = Compiler (return S.empty) return - (Compiler d1 j1) . (Compiler d2 j2) = - Compiler (liftM2 S.union d1 d2) (j1 <=< j2) - -instance Arrow Compiler where - arr f = Compiler (return S.empty) (return . f) - first (Compiler d j) = Compiler d $ \(x, y) -> do - x' <- j x - return (x', y) - --- | Run a compiler, yielding the resulting target and it's dependencies --- -runCompiler :: Compiler () a - -> Identifier - -> ResourceProvider - -> DependencyLookup - -> IO a -runCompiler compiler identifier provider lookup' = - runReaderT (unCompilerM $ compilerJob compiler ()) env - where - env = CompilerEnvironment - { compilerIdentifier = identifier - , compilerResourceProvider = provider - , compilerDependencyLookup = lookup' - } - -getDependencies :: Compiler () a - -> ResourceProvider - -> Dependencies -getDependencies compiler provider = - runReader (compilerDependencies compiler) provider - -addDependencies :: (ResourceProvider -> [Identifier]) - -> Compiler b b -addDependencies deps = Compiler (S.fromList . deps <$> ask) return - -fromCompilerM :: (a -> CompilerM b) - -> Compiler a b -fromCompilerM = Compiler (return S.empty) +import Hakyll.Core.Compiler.Internal getIdentifier :: Compiler a Identifier -getIdentifier = fromCompilerM $ const $ CompilerM $ +getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask getResourceString :: Compiler a String getResourceString = getIdentifier >>> getResourceString' where - getResourceString' = fromCompilerM $ \id' -> CompilerM $ do + getResourceString' = fromJob $ \id' -> CompilerM $ do provider <- compilerResourceProvider <$> ask liftIO $ resourceString provider id' @@ -123,7 +45,7 @@ require :: (Binary a, Typeable a, Writable a) -> (b -> a -> c) -> Compiler b c require identifier f = - addDependencies (const [identifier]) >>> fromCompilerM require' + fromDependencies (const [identifier]) >>> fromJob require' where require' x = CompilerM $ do lookup' <- compilerDependencyLookup <$> ask @@ -137,7 +59,7 @@ requireAll :: (Binary a, Typeable a, Writable a) -> (b -> [a] -> c) -> Compiler b c requireAll pattern f = - addDependencies getDeps >>> fromCompilerM requireAll' + fromDependencies getDeps >>> fromJob requireAll' where getDeps = matches pattern . resourceList requireAll' x = CompilerM $ do diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs new file mode 100644 index 0000000..fd37343 --- /dev/null +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -0,0 +1,96 @@ +-- | Internally used compiler module +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Compiler.Internal + ( Dependencies + , CompilerEnvironment (..) + , CompilerM (..) + , Compiler (..) + , runCompilerJob + , runCompilerDependencies + , fromJob + , fromDependencies + ) where + +import Prelude hiding ((.), id) +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) +import Control.Monad ((<=<), liftM2) +import Data.Set (Set) +import qualified Data.Set as S +import Control.Category (Category, (.), id) +import Control.Arrow (Arrow, arr, first) + +import Hakyll.Core.Identifier +import Hakyll.Core.CompiledItem +import Hakyll.Core.ResourceProvider + +-- | A set of dependencies +-- +type Dependencies = Set Identifier + +-- | A lookup with which we can get dependencies +-- +type DependencyLookup = Identifier -> CompiledItem + +-- | Environment in which a compiler runs +-- +data CompilerEnvironment = CompilerEnvironment + { compilerIdentifier :: Identifier -- ^ Target identifier + , compilerResourceProvider :: ResourceProvider -- ^ Resource provider + , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup + } + +-- | The compiler monad +-- +newtype CompilerM a = CompilerM + { unCompilerM :: ReaderT CompilerEnvironment IO a + } deriving (Monad, Functor, Applicative) + +-- | The compiler arrow +-- +data Compiler a b = Compiler + { compilerDependencies :: Reader ResourceProvider Dependencies + , compilerJob :: a -> CompilerM b + } + +instance Category Compiler where + id = Compiler (return S.empty) return + (Compiler d1 j1) . (Compiler d2 j2) = + Compiler (liftM2 S.union d1 d2) (j1 <=< j2) + +instance Arrow Compiler where + arr f = Compiler (return S.empty) (return . f) + first (Compiler d j) = Compiler d $ \(x, y) -> do + x' <- j x + return (x', y) + +-- | Run a compiler, yielding the resulting target and it's dependencies +-- +runCompilerJob :: Compiler () a + -> Identifier + -> ResourceProvider + -> DependencyLookup + -> IO a +runCompilerJob compiler identifier provider lookup' = + runReaderT (unCompilerM $ compilerJob compiler ()) env + where + env = CompilerEnvironment + { compilerIdentifier = identifier + , compilerResourceProvider = provider + , compilerDependencyLookup = lookup' + } + +runCompilerDependencies :: Compiler () a + -> ResourceProvider + -> Dependencies +runCompilerDependencies compiler provider = + runReader (compilerDependencies compiler) provider + +fromJob :: (a -> CompilerM b) + -> Compiler a b +fromJob = Compiler (return S.empty) + +fromDependencies :: (ResourceProvider -> [Identifier]) + -> Compiler b b +fromDependencies deps = Compiler (S.fromList . deps <$> ask) return diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 911e2f9..fa88458 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -14,6 +14,7 @@ import Hakyll.Core.Route import Hakyll.Core.Identifier import Hakyll.Core.Util.File import Hakyll.Core.Compiler +import Hakyll.Core.Compiler.Internal import Hakyll.Core.ResourceProvider import Hakyll.Core.ResourceProvider.FileResourceProvider import Hakyll.Core.Rules @@ -40,7 +41,7 @@ hakyllWith rules provider store = do -- Get all dependencies dependencies = flip map compilers $ \(id', compiler) -> - let deps = getDependencies compiler provider + let deps = runCompilerDependencies compiler provider in (id', deps) -- Create a compiler map @@ -65,7 +66,7 @@ hakyllWith rules provider store = do putStrLn "DONE." where addTarget route' map' (id', comp) = do - compiled <- runCompiler comp id' provider (dependencyLookup map') + compiled <- runCompilerJob comp id' provider (dependencyLookup map') putStrLn $ "Generated target: " ++ show id' case runRoute route' id' of -- cgit v1.2.3 From e49cd3b4b071c2e0cb3e553fe8272e7cd2843349 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 21:18:55 +0100 Subject: Cleanup, split up page module --- src/Hakyll/Core/Compiler.hs | 13 +++++++++++-- src/Hakyll/Core/Compiler/Internal.hs | 13 ++++++++----- src/Hakyll/Core/Run.hs | 5 +++-- src/Hakyll/Web/Page.hs | 31 ++++++++++--------------------- src/Hakyll/Web/Page/Internal.hs | 31 +++++++++++++++++++++++++++++++ src/Hakyll/Web/Page/Read.hs | 2 +- src/Hakyll/Web/Util/String.hs | 12 ++++++++++++ 7 files changed, 76 insertions(+), 31 deletions(-) create mode 100644 src/Hakyll/Web/Page/Internal.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index d0e219e..5678b0a 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -4,6 +4,7 @@ module Hakyll.Core.Compiler ( Compiler , getIdentifier + , getRoute , getResourceString , require , requireAll @@ -26,10 +27,18 @@ import Hakyll.Core.Writable import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal +-- | Get the identifier of the item that is currently being compiled +-- getIdentifier :: Compiler a Identifier -getIdentifier = fromJob $ const $ CompilerM $ - compilerIdentifier <$> ask +getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask + +-- | Get the route we are using for this item +-- +getRoute :: Compiler a (Maybe FilePath) +getRoute = fromJob $ const $ CompilerM $ compilerRoute <$> ask +-- | Get the resource we are compiling as a string +-- getResourceString :: Compiler a String getResourceString = getIdentifier >>> getResourceString' where diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index fd37343..eee67ef 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -39,6 +39,7 @@ data CompilerEnvironment = CompilerEnvironment { compilerIdentifier :: Identifier -- ^ Target identifier , compilerResourceProvider :: ResourceProvider -- ^ Resource provider , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup + , compilerRoute :: Maybe FilePath -- ^ Site route } -- | The compiler monad @@ -67,18 +68,20 @@ instance Arrow Compiler where -- | Run a compiler, yielding the resulting target and it's dependencies -- -runCompilerJob :: Compiler () a - -> Identifier - -> ResourceProvider - -> DependencyLookup +runCompilerJob :: Compiler () a -- ^ Compiler to run + -> Identifier -- ^ Target identifier + -> ResourceProvider -- ^ Resource provider + -> DependencyLookup -- ^ Dependency lookup table + -> Maybe FilePath -- ^ Route -> IO a -runCompilerJob compiler identifier provider lookup' = +runCompilerJob compiler identifier provider lookup' route = runReaderT (unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment { compilerIdentifier = identifier , compilerResourceProvider = provider , compilerDependencyLookup = lookup' + , compilerRoute = route } runCompilerDependencies :: Compiler () a diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index fa88458..ccb731c 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -66,10 +66,11 @@ hakyllWith rules provider store = do putStrLn "DONE." where addTarget route' map' (id', comp) = do - compiled <- runCompilerJob comp id' provider (dependencyLookup map') + let url = runRoute route' id' + compiled <- runCompilerJob comp id' provider (dependencyLookup map') url putStrLn $ "Generated target: " ++ show id' - case runRoute route' id' of + case url of Nothing -> return () Just r -> do putStrLn $ "Routing " ++ show id' ++ " to " ++ r diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 78178cb..eea474c 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -6,35 +6,24 @@ module Hakyll.Web.Page ( Page (..) , toMap + , pageRead ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((>>^)) import Data.Map (Map) import qualified Data.Map as M -import Data.Binary (Binary, get, put) -import Data.Typeable (Typeable) -import Hakyll.Core.Writable - --- | Type used to represent pages --- -data Page a = Page - { pageMetadata :: Map String String - , pageBody :: a - } deriving (Show, Typeable) - -instance Functor Page where - fmap f (Page m b) = Page m (f b) - -instance Binary a => Binary (Page a) where - put (Page m b) = put m >> put b - get = Page <$> get <*> get - -instance Writable a => Writable (Page a) where - write p (Page _ b) = write p b +import Hakyll.Core.Compiler +import Hakyll.Web.Page.Internal +import Hakyll.Web.Page.Read -- | Convert a page to a map. The body will be placed in the @body@ key. -- toMap :: Page String -> Map String String toMap (Page m b) = M.insert "body" b m + +-- | Read a page (do not render it) +-- +pageRead :: Compiler a (Page String) +pageRead = getResourceString >>^ readPage diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs new file mode 100644 index 0000000..bac4c51 --- /dev/null +++ b/src/Hakyll/Web/Page/Internal.hs @@ -0,0 +1,31 @@ +-- | Internal representation of the page datatype +-- +{-# LANGUAGE DeriveDataTypeable #-} +module Hakyll.Web.Page.Internal + ( Page (..) + ) where + +import Control.Applicative ((<$>), (<*>)) + +import Data.Map (Map) +import Data.Binary (Binary, get, put) +import Data.Typeable (Typeable) + +import Hakyll.Core.Writable + +-- | Type used to represent pages +-- +data Page a = Page + { pageMetadata :: Map String String + , pageBody :: a + } deriving (Show, Typeable) + +instance Functor Page where + fmap f (Page m b) = Page m (f b) + +instance Binary a => Binary (Page a) where + put (Page m b) = put m >> put b + get = Page <$> get <*> get + +instance Writable a => Writable (Page a) where + write p (Page _ b) = write p b diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs index 82224a4..d72f32a 100644 --- a/src/Hakyll/Web/Page/Read.hs +++ b/src/Hakyll/Web/Page/Read.hs @@ -11,7 +11,7 @@ import Data.List (isPrefixOf) import Data.Map (Map) import qualified Data.Map as M -import Hakyll.Web.Page +import Hakyll.Web.Page.Internal import Hakyll.Web.Util.String -- | We're using a simple state monad as parser diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs index 5a8c7c6..e48580b 100644 --- a/src/Hakyll/Web/Util/String.hs +++ b/src/Hakyll/Web/Util/String.hs @@ -2,13 +2,25 @@ -- module Hakyll.Web.Util.String ( trim + , toSiteRoot ) where import Data.Char (isSpace) +import System.FilePath (splitPath, takeDirectory, joinPath) + -- | Trim a string (drop spaces, tabs and newlines at both sides). -- trim :: String -> String trim = reverse . trim' . reverse . trim' where trim' = dropWhile isSpace + +-- | Get the relative url to the site root, for a given (absolute) url +-- +toSiteRoot :: FilePath -> FilePath +toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory + where + parent = const ".." + emptyException [] = "." + emptyException x = x -- cgit v1.2.3 From 686de03ebf1daafc244ce6d8823be37675843e6d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 21:19:19 +0100 Subject: Add Template module --- src/Hakyll/Web/Template.hs | 49 +++++++++++++++++++++++++++++++++++++ src/Hakyll/Web/Template/Internal.hs | 44 +++++++++++++++++++++++++++++++++ 2 files changed, 93 insertions(+) create mode 100644 src/Hakyll/Web/Template.hs create mode 100644 src/Hakyll/Web/Template/Internal.hs (limited to 'src') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs new file mode 100644 index 0000000..586d0b6 --- /dev/null +++ b/src/Hakyll/Web/Template.hs @@ -0,0 +1,49 @@ +module Hakyll.Web.Template + ( Template + , readTemplate + , applyTemplate + , applySelf + ) where + +import Data.List (isPrefixOf) +import Data.Char (isAlphaNum) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + +import Hakyll.Web.Template.Internal +import Hakyll.Web.Page + +-- | Construct a @Template@ from a string. +-- +readTemplate :: String -> Template +readTemplate = Template . readTemplate' + where + readTemplate' [] = [] + readTemplate' string + | "$$" `isPrefixOf` string = + EscapeCharacter : (readTemplate' $ drop 2 string) + | "$" `isPrefixOf` string = + let (key, rest) = span isAlphaNum $ drop 1 string + in Identifier key : readTemplate' rest + | otherwise = + let (chunk, rest) = break (== '$') string + in Chunk chunk : readTemplate' rest + +-- | Substitutes @$identifiers@ in the given @Template@ by values from the given +-- "Page". When a key is not found, it is left as it is. You can specify +-- the characters used to replace escaped dollars (@$$@) here. +-- +applyTemplate :: Template -> Page String -> Page String +applyTemplate template page = + fmap (const $ substitute =<< unTemplate template) page + where + substitute (Chunk chunk) = chunk + substitute (Identifier key) = + fromMaybe ('$' : key) $ M.lookup key $ toMap page + substitute (EscapeCharacter) = "$" + +-- | 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 diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs new file mode 100644 index 0000000..43df1db --- /dev/null +++ b/src/Hakyll/Web/Template/Internal.hs @@ -0,0 +1,44 @@ +-- | Module containing the template data structure +-- +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +module Hakyll.Web.Template.Internal + ( Template (..) + , TemplateElement (..) + ) where + +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, getWord8, put, putWord8) +import Data.Typeable (Typeable) + +import Hakyll.Core.Writable + +-- | Datatype used for template substitutions. +-- +newtype Template = Template + { unTemplate :: [TemplateElement] + } + deriving (Show, Eq, Binary, Typeable) + +instance Writable Template where + -- Writing a template is impossible + write _ _ = return () + +-- | Elements of a template. +-- +data TemplateElement + = Chunk String + | Identifier String + | EscapeCharacter + deriving (Show, Eq, Typeable) + +instance Binary TemplateElement where + put (Chunk string) = putWord8 0 >> put string + put (Identifier key) = putWord8 1 >> put key + put (EscapeCharacter) = putWord8 2 + + get = getWord8 >>= \tag -> case tag of + 0 -> Chunk <$> get + 1 -> Identifier <$> get + 2 -> return EscapeCharacter + _ -> error "Error reading cached template" -- cgit v1.2.3 From 2b5b27e2e7d40933e59374b1ecd8a080de65a96f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 21:42:23 +0100 Subject: Add $title, $root and $url fields --- src/Hakyll/Web/Page.hs | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index eea474c..6e94d52 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -5,18 +5,34 @@ {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page ( Page (..) + , addField , toMap , pageRead + , addDefaultFields ) where -import Control.Arrow ((>>^)) - +import Prelude hiding (id) +import Control.Category (id) +import Control.Arrow ((>>^), (&&&), (>>>)) +import Control.Applicative ((<$>)) +import System.FilePath (takeBaseName) +import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as M +import Hakyll.Core.Identifier import Hakyll.Core.Compiler import Hakyll.Web.Page.Internal import Hakyll.Web.Page.Read +import Hakyll.Web.Util.String + +-- | Add a metadata field. If the field already exists, it is not overwritten. +-- +addField :: String -- ^ Key + -> String -- ^ Value + -> Page a -- ^ Page to add it to + -> Page a -- ^ Resulting page +addField k v (Page m b) = Page (M.insertWith (flip const) k v m) b -- | Convert a page to a map. The body will be placed in the @body@ key. -- @@ -27,3 +43,19 @@ toMap (Page m b) = M.insert "body" b m -- pageRead :: Compiler a (Page String) pageRead = getResourceString >>^ readPage + +-- | Add a number of default metadata fields to a page. These fields include: +-- +-- * @$url@ +-- +-- * @$root@ +-- +-- * @$title@ +-- +addDefaultFields :: Compiler (Page a) (Page a) +addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) + >>> (getIdentifier &&& id >>^ uncurry addTitle) + where + addRoute r = addField "url" (fromMaybe "?" r) + . addField "root" (fromMaybe "/" $ toSiteRoot <$> r) + addTitle i = addField "title" (takeBaseName $ toFilePath i) -- cgit v1.2.3 From 15f2cee5e444735c4206e0e98e8f2506d9fb8659 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 30 Dec 2010 23:07:07 +0100 Subject: Backport CompressCss module --- src/Hakyll/Web/CompressCss.hs | 56 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 src/Hakyll/Web/CompressCss.hs (limited to 'src') diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs new file mode 100644 index 0000000..cd03237 --- /dev/null +++ b/src/Hakyll/Web/CompressCss.hs @@ -0,0 +1,56 @@ +-- | Module used for CSS compression. The compression is currently in a simple +-- state, but would typically reduce the number of bytes by about 25%. +-- +module Text.Hakyll.Internal.CompressCss + ( compressCss + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe) +import Data.List (isPrefixOf) +import Text.Regex.Posix ((=~~)) + +-- | A simple (but inefficient) regex replace funcion +-- +replaceAll :: String -- ^ Pattern + -> (String -> String) -- ^ Replacement (called on capture) + -> String -- ^ Source string + -> String -- ^ Result +replaceAll pattern f source = + case listToMaybe (source =~~ pattern) of + Nothing -> source + Just (o, l) -> + let (before, tmp) = splitAt o source + (capture, after) = splitAt l tmp + in before ++ f capture ++ replaceAll pattern f after + +-- | Compress CSS to speed up your site. +-- +compressCss :: String -> String +compressCss = compressSeparators + . stripComments + . compressWhitespace + +-- | Compresses certain forms of separators. +-- +compressSeparators :: String -> String +compressSeparators = replaceAll "; *}" (const "}") + . replaceAll " *([{};:]) *" (take 1 . dropWhile isSpace) + . replaceAll ";;*" (const ";") + +-- | Compresses all whitespace. +-- +compressWhitespace :: String -> String +compressWhitespace = replaceAll "[ \t\n][ \t\n]*" (const " ") + +-- | Function that strips CSS comments away. +-- +stripComments :: String -> String +stripComments [] = [] +stripComments str + | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str + | otherwise = head str : stripComments (drop 1 str) + where + eatComments str' | null str' = [] + | isPrefixOf "*/" str' = drop 2 str' + | otherwise = eatComments $ drop 1 str' -- cgit v1.2.3 From 7b84181dab7c45c48be5db5b68e31ad5880b05cc Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Dec 2010 09:04:02 +0100 Subject: Add $category field --- src/Hakyll/Web/Page.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 6e94d52..6fed202 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -14,9 +14,7 @@ module Hakyll.Web.Page import Prelude hiding (id) import Control.Category (id) import Control.Arrow ((>>^), (&&&), (>>>)) -import Control.Applicative ((<$>)) -import System.FilePath (takeBaseName) -import Data.Maybe (fromMaybe) +import System.FilePath (takeBaseName, takeDirectory) import Data.Map (Map) import qualified Data.Map as M @@ -54,8 +52,15 @@ pageRead = getResourceString >>^ readPage -- addDefaultFields :: Compiler (Page a) (Page a) addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) - >>> (getIdentifier &&& id >>^ uncurry addTitle) + >>> (getIdentifier &&& id >>^ uncurry addIdentifier) where - addRoute r = addField "url" (fromMaybe "?" r) - . addField "root" (fromMaybe "/" $ toSiteRoot <$> r) - addTitle i = addField "title" (takeBaseName $ toFilePath i) + -- Add root and url, based on route + addRoute Nothing = id + addRoute (Just r) = addField "url" r + . addField "root" (toSiteRoot r) + + -- Add title and category, based on identifier + addIdentifier i = addField "title" (takeBaseName p) + . addField "category" (takeBaseName $ takeDirectory p) + where + p = toFilePath i -- cgit v1.2.3 From 70c7363b8c1ad250c5f68993867015ef68a8b46c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Dec 2010 12:18:33 +0100 Subject: Add wasModified method --- src/Hakyll/Core/Store.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 02b9b4e..7e57df2 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -5,6 +5,7 @@ module Hakyll.Core.Store , makeStore , storeSet , storeGet + , wasModified ) where import Control.Applicative ((<$>)) @@ -15,6 +16,7 @@ import Data.Binary (Binary, encodeFile, decodeFile) import Hakyll.Core.Identifier import Hakyll.Core.Util.File +import Hakyll.Core.ResourceProvider -- | Data structure used for the store -- @@ -51,3 +53,21 @@ storeGet store name identifier = do else return Nothing where path = makePath store name identifier + +-- | Check if a resource was modified +-- +wasModified :: Store -> ResourceProvider -> Identifier -> IO Bool +wasModified store provider identifier = do + -- Get the latest seen digest from the store + lastDigest <- storeGet store itemName identifier + -- Calculate the digest for the resource + newDigest <- resourceDigest provider identifier + -- Check digests + if Just newDigest == lastDigest + -- All is fine, not modified + then return False + -- Resource modified; store new digest + else do storeSet store itemName identifier newDigest + return True + where + itemName = "Hakyll.Core.Store.wasModified" -- cgit v1.2.3 From 5b67f20eab333a0a63eddae93fa114d8f5158c61 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Dec 2010 12:38:12 +0100 Subject: Prototype of the 'cached' arrow transformer --- src/Hakyll/Core/Compiler.hs | 23 +++++++++++++++++++++++ src/Hakyll/Core/Compiler/Internal.hs | 6 +++++- src/Hakyll/Core/ResourceProvider.hs | 20 ++++++++++++++++++++ src/Hakyll/Core/Run.hs | 3 ++- src/Hakyll/Core/Store.hs | 20 -------------------- 5 files changed, 50 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 5678b0a..67724bd 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -8,6 +8,7 @@ module Hakyll.Core.Compiler , getResourceString , require , requireAll + , cached ) where import Prelude hiding ((.), id) @@ -26,6 +27,7 @@ import Hakyll.Core.CompiledItem import Hakyll.Core.Writable import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Store -- | Get the identifier of the item that is currently being compiled -- @@ -75,3 +77,24 @@ requireAll pattern f = deps <- getDeps . compilerResourceProvider <$> ask lookup' <- compilerDependencyLookup <$> ask return $ f x $ map (unCompiledItem . lookup') deps + +cached :: (Binary a) + => String + -> Compiler () a + -> Compiler () a +cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do + provider <- compilerResourceProvider <$> ask + identifier <- compilerIdentifier <$> ask + store <- compilerStore <$> ask + modified <- liftIO $ resourceModified provider identifier store + liftIO $ putStrLn $ + show identifier ++ ": " ++ if modified then "MODIFIED" else "OK" + if modified + then do v <- unCompilerM $ j () + liftIO $ storeSet store name identifier v + return v + else do v <- liftIO $ storeGet store name identifier + case v of Just v' -> return v' + Nothing -> error' + where + error' = error "Hakyll.Core.Compiler.cached: Cache corrupt!" diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index eee67ef..4209bdc 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -24,6 +24,7 @@ import Control.Arrow (Arrow, arr, first) import Hakyll.Core.Identifier import Hakyll.Core.CompiledItem import Hakyll.Core.ResourceProvider +import Hakyll.Core.Store -- | A set of dependencies -- @@ -40,6 +41,7 @@ data CompilerEnvironment = CompilerEnvironment , compilerResourceProvider :: ResourceProvider -- ^ Resource provider , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup , compilerRoute :: Maybe FilePath -- ^ Site route + , compilerStore :: Store -- ^ Compiler store } -- | The compiler monad @@ -73,8 +75,9 @@ runCompilerJob :: Compiler () a -- ^ Compiler to run -> ResourceProvider -- ^ Resource provider -> DependencyLookup -- ^ Dependency lookup table -> Maybe FilePath -- ^ Route + -> Store -- ^ Store -> IO a -runCompilerJob compiler identifier provider lookup' route = +runCompilerJob compiler identifier provider lookup' route store = runReaderT (unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment @@ -82,6 +85,7 @@ runCompilerJob compiler identifier provider lookup' route = , compilerResourceProvider = provider , compilerDependencyLookup = lookup' , compilerRoute = route + , compilerStore = store } runCompilerDependencies :: Compiler () a diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs index ba249ca..c522ab6 100644 --- a/src/Hakyll/Core/ResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -5,6 +5,7 @@ module Hakyll.Core.ResourceProvider ( ResourceProvider (..) , resourceDigest + , resourceModified ) where import Control.Monad ((<=<)) @@ -15,6 +16,7 @@ import OpenSSL.Digest.ByteString.Lazy (digest) import OpenSSL.Digest (MessageDigest (MD5)) import Hakyll.Core.Identifier +import Hakyll.Core.Store -- | A value responsible for retrieving and listing resources -- @@ -31,3 +33,21 @@ data ResourceProvider = ResourceProvider -- resourceDigest :: ResourceProvider -> Identifier -> IO [Word8] resourceDigest provider = digest MD5 <=< resourceLazyByteString provider + +-- | Check if a resource was modified +-- +resourceModified :: ResourceProvider -> Identifier -> Store -> IO Bool +resourceModified provider identifier store = do + -- Get the latest seen digest from the store + lastDigest <- storeGet store itemName identifier + -- Calculate the digest for the resource + newDigest <- resourceDigest provider identifier + -- Check digests + if Just newDigest == lastDigest + -- All is fine, not modified + then return False + -- Resource modified; store new digest + else do storeSet store itemName identifier newDigest + return True + where + itemName = "Hakyll.Core.ResourceProvider.resourceModified" diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index ccb731c..636f9e4 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -67,7 +67,8 @@ hakyllWith rules provider store = do where addTarget route' map' (id', comp) = do let url = runRoute route' id' - compiled <- runCompilerJob comp id' provider (dependencyLookup map') url + compiled <- runCompilerJob comp id' provider (dependencyLookup map') + url store putStrLn $ "Generated target: " ++ show id' case url of diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 7e57df2..02b9b4e 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -5,7 +5,6 @@ module Hakyll.Core.Store , makeStore , storeSet , storeGet - , wasModified ) where import Control.Applicative ((<$>)) @@ -16,7 +15,6 @@ import Data.Binary (Binary, encodeFile, decodeFile) import Hakyll.Core.Identifier import Hakyll.Core.Util.File -import Hakyll.Core.ResourceProvider -- | Data structure used for the store -- @@ -53,21 +51,3 @@ storeGet store name identifier = do else return Nothing where path = makePath store name identifier - --- | Check if a resource was modified --- -wasModified :: Store -> ResourceProvider -> Identifier -> IO Bool -wasModified store provider identifier = do - -- Get the latest seen digest from the store - lastDigest <- storeGet store itemName identifier - -- Calculate the digest for the resource - newDigest <- resourceDigest provider identifier - -- Check digests - if Just newDigest == lastDigest - -- All is fine, not modified - then return False - -- Resource modified; store new digest - else do storeSet store itemName identifier newDigest - return True - where - itemName = "Hakyll.Core.Store.wasModified" -- cgit v1.2.3 From 8bb4ea5c83fb96842f85d2d167e96c4eae09d4ea Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Dec 2010 13:28:31 +0100 Subject: Add resourceExists function --- src/Hakyll/Core/ResourceProvider.hs | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs index c522ab6..d5f2ea3 100644 --- a/src/Hakyll/Core/ResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -4,6 +4,7 @@ -- module Hakyll.Core.ResourceProvider ( ResourceProvider (..) + , resourceExists , resourceDigest , resourceModified ) where @@ -29,6 +30,11 @@ data ResourceProvider = ResourceProvider resourceLazyByteString :: Identifier -> IO LB.ByteString } +-- | Check if a given resource exists +-- +resourceExists :: ResourceProvider -> Identifier -> Bool +resourceExists provider = flip elem $ resourceList provider + -- | Retrieve a digest for a given resource -- resourceDigest :: ResourceProvider -> Identifier -> IO [Word8] -- cgit v1.2.3 From e54834f4448f4bcc6fb55fb338ffcfd4390fd356 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Dec 2010 15:15:35 +0100 Subject: Check modification only once --- src/Hakyll/Core/Compiler.hs | 3 +-- src/Hakyll/Core/Compiler/Internal.hs | 21 +++++++++++++++------ src/Hakyll/Core/Run.hs | 10 +++++++++- 3 files changed, 25 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 67724bd..fdc7d20 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -83,10 +83,9 @@ cached :: (Binary a) -> Compiler () a -> Compiler () a cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do - provider <- compilerResourceProvider <$> ask identifier <- compilerIdentifier <$> ask store <- compilerStore <$> ask - modified <- liftIO $ resourceModified provider identifier store + modified <- compilerResourceModified <$> ask liftIO $ putStrLn $ show identifier ++ ": " ++ if modified then "MODIFIED" else "OK" if modified diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 4209bdc..a4dd695 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -37,11 +37,18 @@ type DependencyLookup = Identifier -> CompiledItem -- | Environment in which a compiler runs -- data CompilerEnvironment = CompilerEnvironment - { compilerIdentifier :: Identifier -- ^ Target identifier - , compilerResourceProvider :: ResourceProvider -- ^ Resource provider - , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup - , compilerRoute :: Maybe FilePath -- ^ Site route - , compilerStore :: Store -- ^ Compiler store + { -- | Target identifier + compilerIdentifier :: Identifier + , -- | Resource provider + compilerResourceProvider :: ResourceProvider + , -- | Dependency lookup + compilerDependencyLookup :: DependencyLookup + , -- | Site route + compilerRoute :: Maybe FilePath + , -- | Compiler store + compilerStore :: Store + , -- | Flag indicating if the underlying resource was modified + compilerResourceModified :: Bool } -- | The compiler monad @@ -76,8 +83,9 @@ runCompilerJob :: Compiler () a -- ^ Compiler to run -> DependencyLookup -- ^ Dependency lookup table -> Maybe FilePath -- ^ Route -> Store -- ^ Store + -> Bool -- ^ Was the resource modified? -> IO a -runCompilerJob compiler identifier provider lookup' route store = +runCompilerJob compiler identifier provider lookup' route store modified = runReaderT (unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment @@ -86,6 +94,7 @@ runCompilerJob compiler identifier provider lookup' route store = , compilerDependencyLookup = lookup' , compilerRoute = route , compilerStore = store + , compilerResourceModified = modified } runCompilerDependencies :: Compiler () a diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 636f9e4..1b45f38 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -67,8 +67,15 @@ hakyllWith rules provider store = do where addTarget route' map' (id', comp) = do let url = runRoute route' id' + + -- Check if the resource was modified + modified <- if resourceExists provider id' + then resourceModified provider id' store + else return False + + -- Run the compiler compiled <- runCompilerJob comp id' provider (dependencyLookup map') - url store + url store modified putStrLn $ "Generated target: " ++ show id' case url of @@ -79,6 +86,7 @@ hakyllWith rules provider store = do makeDirectories path write path compiled + putStrLn "" return $ M.insert id' compiled map' dependencyLookup map' id' = case M.lookup id' map' of -- cgit v1.2.3 From e1aa9600993363eec55425bc05cb9813b9054f91 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Dec 2010 16:15:57 +0100 Subject: Add Hakyll.Web module --- src/Hakyll/Web.hs | 21 +++++++++++++++++++++ src/Hakyll/Web/Page.hs | 2 +- 2 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 src/Hakyll/Web.hs (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs new file mode 100644 index 0000000..bc7710f --- /dev/null +++ b/src/Hakyll/Web.hs @@ -0,0 +1,21 @@ +-- | Module exporting commonly used web-related functions +-- +module Hakyll.Web + ( defaultPageRead + , defaultTemplateRead + ) where + +import Control.Arrow (arr, (>>>), (>>^)) + +import Hakyll.Core.Compiler +import Hakyll.Web.Page +import Hakyll.Web.Pandoc +import Hakyll.Web.Template + +defaultPageRead :: Compiler () (Page String) +defaultPageRead = cached "Hakyll.Web.defaultPageRead" $ + pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc + +defaultTemplateRead :: Compiler () Template +defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ + getResourceString >>^ readTemplate diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 6fed202..9294231 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -61,6 +61,6 @@ addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) -- Add title and category, based on identifier addIdentifier i = addField "title" (takeBaseName p) - . addField "category" (takeBaseName $ takeDirectory p) + . addField "category" (takeBaseName $ takeDirectory p) where p = toFilePath i -- cgit v1.2.3 From 2d1225104cb5a050a84bc70916e1aadfff25fb00 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Jan 2011 10:22:49 +0100 Subject: Add toUrl, move & optimize replaceAll a bit --- src/Hakyll/Web/CompressCss.hs | 16 +--------------- src/Hakyll/Web/Page.hs | 4 ++-- src/Hakyll/Web/Util/String.hs | 34 +++++++++++++++++++++++++++++++++- 3 files changed, 36 insertions(+), 18 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index cd03237..6e3b6f2 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -6,23 +6,9 @@ module Text.Hakyll.Internal.CompressCss ) where import Data.Char (isSpace) -import Data.Maybe (listToMaybe) import Data.List (isPrefixOf) -import Text.Regex.Posix ((=~~)) --- | A simple (but inefficient) regex replace funcion --- -replaceAll :: String -- ^ Pattern - -> (String -> String) -- ^ Replacement (called on capture) - -> String -- ^ Source string - -> String -- ^ Result -replaceAll pattern f source = - case listToMaybe (source =~~ pattern) of - Nothing -> source - Just (o, l) -> - let (before, tmp) = splitAt o source - (capture, after) = splitAt l tmp - in before ++ f capture ++ replaceAll pattern f after +import Hakyll.Web.Util.String -- | Compress CSS to speed up your site. -- diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 9294231..531c951 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -56,8 +56,8 @@ addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) where -- Add root and url, based on route addRoute Nothing = id - addRoute (Just r) = addField "url" r - . addField "root" (toSiteRoot r) + addRoute (Just r) = addField "url" (toUrl r) + . addField "root" (toSiteRoot $ toUrl r) -- Add title and category, based on identifier addIdentifier i = addField "title" (takeBaseName p) diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs index e48580b..ed8b904 100644 --- a/src/Hakyll/Web/Util/String.hs +++ b/src/Hakyll/Web/Util/String.hs @@ -2,12 +2,16 @@ -- module Hakyll.Web.Util.String ( trim + , replaceAll + , toUrl , toSiteRoot ) where import Data.Char (isSpace) +import Data.Maybe (listToMaybe) import System.FilePath (splitPath, takeDirectory, joinPath) +import Text.Regex.PCRE ((=~~)) -- | Trim a string (drop spaces, tabs and newlines at both sides). -- @@ -16,9 +20,37 @@ trim = reverse . trim' . reverse . trim' where trim' = dropWhile isSpace +-- | A simple (but inefficient) regex replace funcion +-- +replaceAll :: String -- ^ Pattern + -> (String -> String) -- ^ Replacement (called on capture) + -> String -- ^ Source string + -> String -- ^ Result +replaceAll pattern f source = replaceAll' source + where + replaceAll' src = case listToMaybe (src =~~ pattern) of + Nothing -> src + Just (o, l) -> + let (before, tmp) = splitAt o src + (capture, after) = splitAt l tmp + in before ++ f capture ++ replaceAll' after + +-- | Convert a filepath to an URL starting from the site root +-- +-- Example: +-- +-- > toUrl "foo/bar.html" +-- +-- Result: +-- +-- > "/foo/bar.html" +-- +toUrl :: FilePath -> String +toUrl = ('/' :) + -- | Get the relative url to the site root, for a given (absolute) url -- -toSiteRoot :: FilePath -> FilePath +toSiteRoot :: String -> String toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory where parent = const ".." -- cgit v1.2.3 From 220e4b484cb460df0e0a0cb50a309788349745b2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Jan 2011 12:49:43 +0100 Subject: Escaped carries allong it's escaped value --- src/Hakyll/Web/Template.hs | 10 +++++++--- src/Hakyll/Web/Template/Internal.hs | 8 ++++---- 2 files changed, 11 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 586d0b6..b4f2ea5 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -21,14 +21,18 @@ readTemplate = Template . readTemplate' readTemplate' [] = [] readTemplate' string | "$$" `isPrefixOf` string = - EscapeCharacter : (readTemplate' $ drop 2 string) + let (key, rest) = readIdentifier $ drop 2 string + in Escaped key : readTemplate' rest | "$" `isPrefixOf` string = - let (key, rest) = span isAlphaNum $ drop 1 string + let (key, rest) = readIdentifier $ drop 1 string in Identifier key : readTemplate' rest | otherwise = let (chunk, rest) = break (== '$') string in Chunk chunk : readTemplate' rest + -- Parse an identifier into (identifier, rest) + readIdentifier = span isAlphaNum + -- | Substitutes @$identifiers@ in the given @Template@ by values from the given -- "Page". When a key is not found, it is left as it is. You can specify -- the characters used to replace escaped dollars (@$$@) here. @@ -40,7 +44,7 @@ applyTemplate template page = substitute (Chunk chunk) = chunk substitute (Identifier key) = fromMaybe ('$' : key) $ M.lookup key $ toMap page - substitute (EscapeCharacter) = "$" + substitute (Escaped key) = '$' : key -- | Apply a page as it's own template. This is often very useful to fill in -- certain keys like @$root@ and @$url@. diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs index 43df1db..be10881 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -29,16 +29,16 @@ instance Writable Template where data TemplateElement = Chunk String | Identifier String - | EscapeCharacter + | Escaped String deriving (Show, Eq, Typeable) instance Binary TemplateElement where put (Chunk string) = putWord8 0 >> put string put (Identifier key) = putWord8 1 >> put key - put (EscapeCharacter) = putWord8 2 + put (Escaped key) = putWord8 2 >> put key get = getWord8 >>= \tag -> case tag of - 0 -> Chunk <$> get + 0 -> Chunk <$> get 1 -> Identifier <$> get - 2 -> return EscapeCharacter + 2 -> Escaped <$> get _ -> error "Error reading cached template" -- cgit v1.2.3 From 40c75767d4f926de4ce2fd3db688e46987fb8b72 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 3 Jan 2011 11:33:59 +0100 Subject: Store modified flags in a map This allows reuse for actual dependency checking (to be implemented later). --- src/Hakyll/Core/Run.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 1b45f38..6898b3a 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -3,12 +3,13 @@ module Hakyll.Core.Run where import Control.Arrow ((&&&)) -import Control.Monad (foldM, forM_) +import Control.Monad (foldM, forM_, forM) import qualified Data.Map as M import Data.Monoid (mempty) import Data.Typeable (Typeable) import Data.Binary (Binary) import System.FilePath (()) +import Control.Applicative ((<$>)) import Hakyll.Core.Route import Hakyll.Core.Identifier @@ -60,18 +61,23 @@ hakyllWith rules provider store = do putStrLn "Writing dependency graph to dependencies.dot..." writeDot "dependencies.dot" show graph + -- Check which items are up-to-date: modified will be a Map Identifier Bool + modifiedMap <- fmap M.fromList $ forM orderedCompilers $ \(id', _) -> do + modified <- if resourceExists provider id' + then resourceModified provider id' store + else return False + return (id', modified) + -- Generate all the targets in order - _ <- foldM (addTarget route') M.empty orderedCompilers + _ <- foldM (addTarget route' modifiedMap) M.empty orderedCompilers putStrLn "DONE." where - addTarget route' map' (id', comp) = do + addTarget route' modifiedMap map' (id', comp) = do let url = runRoute route' id' -- Check if the resource was modified - modified <- if resourceExists provider id' - then resourceModified provider id' store - else return False + let modified = modifiedMap M.! id' -- Run the compiler compiled <- runCompilerJob comp id' provider (dependencyLookup map') -- cgit v1.2.3 From 2ceb5f59d0728c380ad7b4f319a9282741e715b9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 3 Jan 2011 22:13:04 +0100 Subject: Avoid looking at up-to-date items at all --- src/Hakyll/Core/CompiledItem.hs | 2 +- src/Hakyll/Core/Compiler.hs | 34 ++++++++++++--- src/Hakyll/Core/Compiler/Internal.hs | 2 +- src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs | 6 ++- src/Hakyll/Core/Run.hs | 58 +++++++++++++++++-------- 5 files changed, 74 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs index d191e2a..d12d172 100644 --- a/src/Hakyll/Core/CompiledItem.hs +++ b/src/Hakyll/Core/CompiledItem.hs @@ -4,7 +4,7 @@ -- {-# LANGUAGE ExistentialQuantification #-} module Hakyll.Core.CompiledItem - ( CompiledItem + ( CompiledItem (..) , compiledItem , unCompiledItem ) where diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index fdc7d20..df1caeb 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -6,6 +6,7 @@ module Hakyll.Core.Compiler , getIdentifier , getRoute , getResourceString + , storeResult , require , requireAll , cached @@ -17,6 +18,7 @@ import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) import Control.Category (Category, (.)) +import Data.Maybe (fromMaybe) import Data.Binary (Binary) import Data.Typeable (Typeable) @@ -48,6 +50,28 @@ getResourceString = getIdentifier >>> getResourceString' provider <- compilerResourceProvider <$> ask liftIO $ resourceString provider id' +-- | Store a finished item in the cache +-- +storeResult :: Store -> Identifier -> CompiledItem -> IO () +storeResult store identifier (CompiledItem x) = + storeSet store "Hakyll.Core.Compiler.storeResult" identifier x + +-- | Auxiliary: get a dependency +-- +getDependencyOrResult :: (Binary a, Writable a, Typeable a) + => Identifier -> CompilerM a +getDependencyOrResult identifier = CompilerM $ do + lookup' <- compilerDependencyLookup <$> ask + store <- compilerStore <$> ask + case lookup' identifier of + -- Found in the dependency lookup + Just r -> return $ unCompiledItem r + -- Not found here, try the main cache + Nothing -> fmap (fromMaybe error') $ liftIO $ + storeGet store "Hakyll.Core.Compiler.storeResult" identifier + where + error' = error "Hakyll.Core.Compiler.getDependency: Not found" + -- | Require another target. Using this function ensures automatic handling of -- dependencies -- @@ -58,9 +82,9 @@ require :: (Binary a, Typeable a, Writable a) require identifier f = fromDependencies (const [identifier]) >>> fromJob require' where - require' x = CompilerM $ do - lookup' <- compilerDependencyLookup <$> ask - return $ f x $ unCompiledItem $ lookup' identifier + require' x = do + y <- getDependencyOrResult identifier + return $ f x y -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies @@ -75,8 +99,8 @@ requireAll pattern f = getDeps = matches pattern . resourceList requireAll' x = CompilerM $ do deps <- getDeps . compilerResourceProvider <$> ask - lookup' <- compilerDependencyLookup <$> ask - return $ f x $ map (unCompiledItem . lookup') deps + items <- mapM (unCompilerM . getDependencyOrResult) deps + return $ f x items cached :: (Binary a) => String diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index a4dd695..262cda0 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -32,7 +32,7 @@ type Dependencies = Set Identifier -- | A lookup with which we can get dependencies -- -type DependencyLookup = Identifier -> CompiledItem +type DependencyLookup = Identifier -> Maybe CompiledItem -- | Environment in which a compiler runs -- diff --git a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs index f781819..9aeb2ff 100644 --- a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs +++ b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs @@ -7,6 +7,7 @@ module Hakyll.Core.DirectedGraph.ObsoleteFilter ( filterObsolete ) where +import Data.Set (Set) import qualified Data.Set as S import Hakyll.Core.DirectedGraph @@ -16,10 +17,11 @@ import qualified Hakyll.Core.DirectedGraph as DG -- contains these items -- filterObsolete :: Ord a - => [a] -- ^ List of obsolete items + => Set a -- ^ Obsolete items -> DirectedGraph a -- ^ Dependency graph -> DirectedGraph a -- ^ Resulting dependency graph filterObsolete obsolete graph = let reversed = DG.reverse graph - allObsolete = S.unions $ map (flip reachableNodes reversed) obsolete + allObsolete = S.unions $ map (flip reachableNodes reversed) + $ S.toList obsolete in DG.filter (`S.member` allObsolete) graph diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 6898b3a..e9ec47e 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -3,13 +3,16 @@ module Hakyll.Core.Run where import Control.Arrow ((&&&)) -import Control.Monad (foldM, forM_, forM) +import Control.Monad (foldM, forM_, forM, filterM) +import Data.Map (Map) import qualified Data.Map as M import Data.Monoid (mempty) import Data.Typeable (Typeable) import Data.Binary (Binary) import System.FilePath (()) import Control.Applicative ((<$>)) +import Data.Set (Set) +import qualified Data.Set as S import Hakyll.Core.Route import Hakyll.Core.Identifier @@ -22,6 +25,7 @@ import Hakyll.Core.Rules import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver +import Hakyll.Core.DirectedGraph.ObsoleteFilter import Hakyll.Core.Writable import Hakyll.Core.Store import Hakyll.Core.CompiledItem @@ -48,9 +52,23 @@ hakyllWith rules provider store = do -- Create a compiler map compilerMap = M.fromList compilers - -- Create and solve the graph, creating a compiler order + -- Create the graph graph = fromList dependencies - ordered = solveDependencies graph + + putStrLn "Writing dependency graph to dependencies.dot..." + writeDot "dependencies.dot" show graph + + -- Check which items are up-to-date + modified' <- modified provider store $ map fst compilers + + let -- Try to reduce the graph + reducedGraph = filterObsolete modified' graph + + putStrLn "Writing reduced graph to reduced.dot..." + writeDot "reduced.dot" show reducedGraph + + let -- Solve the graph + ordered = solveDependencies reducedGraph -- Join the order with the compilers again orderedCompilers = map (id &&& (compilerMap M.!)) ordered @@ -58,30 +76,23 @@ hakyllWith rules provider store = do -- Fetch the routes route' = rulesRoute ruleSet - putStrLn "Writing dependency graph to dependencies.dot..." - writeDot "dependencies.dot" show graph - - -- Check which items are up-to-date: modified will be a Map Identifier Bool - modifiedMap <- fmap M.fromList $ forM orderedCompilers $ \(id', _) -> do - modified <- if resourceExists provider id' - then resourceModified provider id' store - else return False - return (id', modified) + putStrLn $ show reducedGraph + putStrLn $ show ordered -- Generate all the targets in order - _ <- foldM (addTarget route' modifiedMap) M.empty orderedCompilers + _ <- foldM (addTarget route' modified') M.empty orderedCompilers putStrLn "DONE." where - addTarget route' modifiedMap map' (id', comp) = do + addTarget route' modified' map' (id', comp) = do let url = runRoute route' id' -- Check if the resource was modified - let modified = modifiedMap M.! id' + let isModified = id' `S.member` modified' -- Run the compiler compiled <- runCompilerJob comp id' provider (dependencyLookup map') - url store modified + url store isModified putStrLn $ "Generated target: " ++ show id' case url of @@ -92,9 +103,18 @@ hakyllWith rules provider store = do makeDirectories path write path compiled + -- Store it in the cache + storeResult store id' compiled + putStrLn "" return $ M.insert id' compiled map' - dependencyLookup map' id' = case M.lookup id' map' of - Nothing -> error $ "dependencyLookup: " ++ show id' ++ " not found" - Just d -> d + dependencyLookup map' id' = M.lookup id' map' + +modified :: ResourceProvider -- ^ Resource provider + -> Store -- ^ Store + -> [Identifier] -- ^ Identifiers to check + -> IO (Set Identifier) -- ^ Modified resources +modified provider store ids = fmap S.fromList $ flip filterM ids $ \id' -> + if resourceExists provider id' then resourceModified provider id' store + else return False -- cgit v1.2.3 From e395b0af9a969b8a1d93ad0d9f0554841beb9298 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 3 Jan 2011 23:24:22 +0100 Subject: Store result automatically using runCompiler --- src/Hakyll/Core/Compiler.hs | 27 +++++++++++++++++++-------- src/Hakyll/Core/Compiler/Internal.hs | 1 + src/Hakyll/Core/Run.hs | 7 ++----- 3 files changed, 22 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index df1caeb..57a6d07 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -3,10 +3,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler ( Compiler + , runCompiler , getIdentifier , getRoute , getResourceString - , storeResult , require , requireAll , cached @@ -31,6 +31,23 @@ import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal import Hakyll.Core.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 + -> Identifier -- ^ Target identifier + -> ResourceProvider -- ^ Resource provider + -> DependencyLookup -- ^ Dependency lookup table + -> Maybe FilePath -- ^ Route + -> Store -- ^ Store + -> Bool -- ^ Was the resource modified? + -> IO CompiledItem -- ^ Resulting item +runCompiler compiler identifier provider lookup' route store modified = do + CompiledItem result <- runCompilerJob + compiler identifier provider lookup' route store modified + storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result + return $ CompiledItem result + -- | Get the identifier of the item that is currently being compiled -- getIdentifier :: Compiler a Identifier @@ -50,12 +67,6 @@ getResourceString = getIdentifier >>> getResourceString' provider <- compilerResourceProvider <$> ask liftIO $ resourceString provider id' --- | Store a finished item in the cache --- -storeResult :: Store -> Identifier -> CompiledItem -> IO () -storeResult store identifier (CompiledItem x) = - storeSet store "Hakyll.Core.Compiler.storeResult" identifier x - -- | Auxiliary: get a dependency -- getDependencyOrResult :: (Binary a, Writable a, Typeable a) @@ -68,7 +79,7 @@ getDependencyOrResult identifier = CompilerM $ do Just r -> return $ unCompiledItem r -- Not found here, try the main cache Nothing -> fmap (fromMaybe error') $ liftIO $ - storeGet store "Hakyll.Core.Compiler.storeResult" identifier + storeGet store "Hakyll.Core.Compiler.runCompiler" identifier where error' = error "Hakyll.Core.Compiler.getDependency: Not found" diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 262cda0..1796565 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal ( Dependencies + , DependencyLookup , CompilerEnvironment (..) , CompilerM (..) , Compiler (..) diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index e9ec47e..c5e6489 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -91,8 +91,8 @@ hakyllWith rules provider store = do let isModified = id' `S.member` modified' -- Run the compiler - compiled <- runCompilerJob comp id' provider (dependencyLookup map') - url store isModified + compiled <- runCompiler comp id' provider (dependencyLookup map') + url store isModified putStrLn $ "Generated target: " ++ show id' case url of @@ -103,9 +103,6 @@ hakyllWith rules provider store = do makeDirectories path write path compiled - -- Store it in the cache - storeResult store id' compiled - putStrLn "" return $ M.insert id' compiled map' -- cgit v1.2.3 From 0969fe41c7c94c34e5663ed231ecbb9e2c4bc051 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 4 Jan 2011 11:13:08 +0100 Subject: Add relativize URL's functionality --- src/Hakyll/Core/Compiler.hs | 7 ++++++- src/Hakyll/Core/Run.hs | 2 ++ src/Hakyll/Web.hs | 13 ++++++++++++- src/Hakyll/Web/Page.hs | 1 - src/Hakyll/Web/RelativizeUrls.hs | 29 +++++++++++++++++++++++++++++ 5 files changed, 49 insertions(+), 3 deletions(-) create mode 100644 src/Hakyll/Web/RelativizeUrls.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 57a6d07..0c13c78 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -43,8 +43,11 @@ runCompiler :: Compiler () CompiledItem -- ^ Compiler to run -> Bool -- ^ Was the resource modified? -> IO CompiledItem -- ^ Resulting item runCompiler compiler identifier provider lookup' route store modified = do + -- Run the compiler job CompiledItem result <- runCompilerJob compiler identifier provider lookup' route store modified + + -- Store a copy in the cache and return storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result return $ CompiledItem result @@ -81,7 +84,9 @@ getDependencyOrResult identifier = CompilerM $ do Nothing -> fmap (fromMaybe error') $ liftIO $ storeGet store "Hakyll.Core.Compiler.runCompiler" identifier where - error' = error "Hakyll.Core.Compiler.getDependency: Not found" + error' = error $ "Hakyll.Core.Compiler.getDependency: " + ++ show identifier + ++ " not found in the cache, the cache might be corrupted" -- | Require another target. Using this function ensures automatic handling of -- dependencies diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index c5e6489..9e6a6ee 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -108,6 +108,8 @@ hakyllWith rules provider store = do dependencyLookup map' id' = M.lookup id' map' +-- | Return a set of modified identifiers +-- modified :: ResourceProvider -- ^ Resource provider -> Store -- ^ Store -> [Identifier] -- ^ Identifiers to check diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index bc7710f..536abda 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -3,19 +3,30 @@ module Hakyll.Web ( defaultPageRead , defaultTemplateRead + , defaultRelativizeUrls ) where -import Control.Arrow (arr, (>>>), (>>^)) +import Prelude hiding (id) +import Control.Category (id) +import Control.Arrow (arr, (>>>), (>>^), (&&&)) import Hakyll.Core.Compiler import Hakyll.Web.Page import Hakyll.Web.Pandoc import Hakyll.Web.Template +import Hakyll.Web.RelativizeUrls +import Hakyll.Web.Util.String defaultPageRead :: Compiler () (Page String) defaultPageRead = cached "Hakyll.Web.defaultPageRead" $ pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc +defaultRelativizeUrls :: Compiler (Page String) (Page String) +defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize + where + relativize Nothing = id + relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) + defaultTemplateRead :: Compiler () Template defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ getResourceString >>^ readTemplate diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 531c951..883da74 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -57,7 +57,6 @@ addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) -- Add root and url, based on route addRoute Nothing = id addRoute (Just r) = addField "url" (toUrl r) - . addField "root" (toSiteRoot $ toUrl r) -- Add title and category, based on identifier addIdentifier i = addField "title" (takeBaseName p) diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs new file mode 100644 index 0000000..2a3b98f --- /dev/null +++ b/src/Hakyll/Web/RelativizeUrls.hs @@ -0,0 +1,29 @@ +module Hakyll.Web.RelativizeUrls + ( relativizeUrls + ) where + +import Data.List (isPrefixOf) +import qualified Data.Set as S + +import Text.HTML.TagSoup + +-- | Relativize URL's in HTML +-- +relativizeUrls :: String -- ^ Path to the site root + -> String -- ^ HTML to relativize + -> String -- ^ Resulting HTML +relativizeUrls root = renderTags . map relativizeUrls' . parseTags + where + relativizeUrls' (TagOpen s a) = TagOpen s $ map (relativizeUrlsAttrs root) a + relativizeUrls' x = x + +-- | Relativize URL's in attributes +-- +relativizeUrlsAttrs :: String -- ^ Path to the site root + -> Attribute String -- ^ Attribute to relativize + -> Attribute String -- ^ Resulting attribute +relativizeUrlsAttrs root (key, value) + | key `S.member` urls && "/" `isPrefixOf` value = (key, root ++ value) + | otherwise = (key, value) + where + urls = S.fromList ["src", "href"] -- cgit v1.2.3 From 77c7d8dc17a86640180b9b233f6e0fd9008c6848 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 4 Jan 2011 13:09:45 +0100 Subject: Add in-memory map to store This allows us to get rid of the dependency lookup map and use one uniform cache/lookup. --- src/Hakyll/Core/Compiler.hs | 24 +++++++---------- src/Hakyll/Core/Compiler/Internal.hs | 12 +-------- src/Hakyll/Core/Run.hs | 10 +++---- src/Hakyll/Core/Store.hs | 51 ++++++++++++++++++++++++++++++------ src/Hakyll/Core/Writable.hs | 5 ++++ 5 files changed, 61 insertions(+), 41 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 0c13c78..e862dd8 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -37,15 +37,14 @@ import Hakyll.Core.Store runCompiler :: Compiler () CompiledItem -- ^ Compiler to run -> Identifier -- ^ Target identifier -> ResourceProvider -- ^ Resource provider - -> DependencyLookup -- ^ Dependency lookup table -> Maybe FilePath -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> IO CompiledItem -- ^ Resulting item -runCompiler compiler identifier provider lookup' route store modified = do +runCompiler compiler identifier provider route store modified = do -- Run the compiler job CompiledItem result <- runCompilerJob - compiler identifier provider lookup' route store modified + compiler identifier provider route store modified -- Store a copy in the cache and return storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result @@ -72,17 +71,12 @@ getResourceString = getIdentifier >>> getResourceString' -- | Auxiliary: get a dependency -- -getDependencyOrResult :: (Binary a, Writable a, Typeable a) +getDependency :: (Binary a, Writable a, Typeable a) => Identifier -> CompilerM a -getDependencyOrResult identifier = CompilerM $ do - lookup' <- compilerDependencyLookup <$> ask +getDependency identifier = CompilerM $ do store <- compilerStore <$> ask - case lookup' identifier of - -- Found in the dependency lookup - Just r -> return $ unCompiledItem r - -- Not found here, try the main cache - Nothing -> fmap (fromMaybe error') $ liftIO $ - storeGet store "Hakyll.Core.Compiler.runCompiler" identifier + fmap (fromMaybe error') $ liftIO $ + storeGet store "Hakyll.Core.Compiler.runCompiler" identifier where error' = error $ "Hakyll.Core.Compiler.getDependency: " ++ show identifier @@ -99,7 +93,7 @@ require identifier f = fromDependencies (const [identifier]) >>> fromJob require' where require' x = do - y <- getDependencyOrResult identifier + y <- getDependency identifier return $ f x y -- | Require a number of targets. Using this function ensures automatic handling @@ -115,10 +109,10 @@ requireAll pattern f = getDeps = matches pattern . resourceList requireAll' x = CompilerM $ do deps <- getDeps . compilerResourceProvider <$> ask - items <- mapM (unCompilerM . getDependencyOrResult) deps + items <- mapM (unCompilerM . getDependency) deps return $ f x items -cached :: (Binary a) +cached :: (Binary a, Typeable a, Writable a) => String -> Compiler () a -> Compiler () a diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 1796565..0642b85 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal ( Dependencies - , DependencyLookup , CompilerEnvironment (..) , CompilerM (..) , Compiler (..) @@ -23,7 +22,6 @@ import Control.Category (Category, (.), id) import Control.Arrow (Arrow, arr, first) import Hakyll.Core.Identifier -import Hakyll.Core.CompiledItem import Hakyll.Core.ResourceProvider import Hakyll.Core.Store @@ -31,10 +29,6 @@ import Hakyll.Core.Store -- type Dependencies = Set Identifier --- | A lookup with which we can get dependencies --- -type DependencyLookup = Identifier -> Maybe CompiledItem - -- | Environment in which a compiler runs -- data CompilerEnvironment = CompilerEnvironment @@ -42,8 +36,6 @@ data CompilerEnvironment = CompilerEnvironment compilerIdentifier :: Identifier , -- | Resource provider compilerResourceProvider :: ResourceProvider - , -- | Dependency lookup - compilerDependencyLookup :: DependencyLookup , -- | Site route compilerRoute :: Maybe FilePath , -- | Compiler store @@ -81,18 +73,16 @@ instance Arrow Compiler where runCompilerJob :: Compiler () a -- ^ Compiler to run -> Identifier -- ^ Target identifier -> ResourceProvider -- ^ Resource provider - -> DependencyLookup -- ^ Dependency lookup table -> Maybe FilePath -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> IO a -runCompilerJob compiler identifier provider lookup' route store modified = +runCompilerJob compiler identifier provider route store modified = runReaderT (unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment { compilerIdentifier = identifier , compilerResourceProvider = provider - , compilerDependencyLookup = lookup' , compilerRoute = route , compilerStore = store , compilerResourceModified = modified diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 9e6a6ee..7121068 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -80,19 +80,18 @@ hakyllWith rules provider store = do putStrLn $ show ordered -- Generate all the targets in order - _ <- foldM (addTarget route' modified') M.empty orderedCompilers + _ <- mapM (addTarget route' modified') orderedCompilers putStrLn "DONE." where - addTarget route' modified' map' (id', comp) = do + addTarget route' modified' (id', comp) = do let url = runRoute route' id' -- Check if the resource was modified let isModified = id' `S.member` modified' -- Run the compiler - compiled <- runCompiler comp id' provider (dependencyLookup map') - url store isModified + compiled <- runCompiler comp id' provider url store isModified putStrLn $ "Generated target: " ++ show id' case url of @@ -104,9 +103,6 @@ hakyllWith rules provider store = do write path compiled putStrLn "" - return $ M.insert id' compiled map' - - dependencyLookup map' id' = M.lookup id' map' -- | Return a set of modified identifiers -- diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 02b9b4e..ab739a1 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -7,25 +7,45 @@ module Hakyll.Core.Store , storeGet ) where -import Control.Applicative ((<$>)) +import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) import System.FilePath (()) import System.Directory (doesFileExist) +import Data.Map (Map) +import qualified Data.Map as M import Data.Binary (Binary, encodeFile, decodeFile) +import Data.Typeable (Typeable) +import Hakyll.Core.CompiledItem +import Hakyll.Core.Writable import Hakyll.Core.Identifier import Hakyll.Core.Util.File -- | Data structure used for the store -- data Store = Store - { storeDirectory :: FilePath + { -- | All items are stored on the filesystem + storeDirectory :: FilePath + , -- | And some items are also kept in-memory + storeMap :: MVar (Map FilePath CompiledItem) } -- | Initialize the store -- makeStore :: FilePath -> IO Store -makeStore directory = return Store {storeDirectory = directory} +makeStore directory = do + mvar <- newMVar M.empty + return Store + { storeDirectory = directory + , storeMap = mvar + } + +-- | Auxiliary: add an item to the map +-- +addToMap :: (Binary a, Typeable a, Writable a) + => Store -> FilePath -> a -> IO () +addToMap store path value = + modifyMVar_ (storeMap store) $ return . M.insert path (compiledItem value) -- | Create a path -- @@ -35,19 +55,34 @@ makePath store name identifier = -- | Store an item -- -storeSet :: Binary a => Store -> String -> Identifier -> a -> IO () +storeSet :: (Binary a, Typeable a, Writable a) + => Store -> String -> Identifier -> a -> IO () storeSet store name identifier value = do makeDirectories path encodeFile path value + addToMap store path value where path = makePath store name identifier -- | Load an item -- -storeGet :: Binary a => Store -> String -> Identifier -> IO (Maybe a) +storeGet :: (Binary a, Typeable a, Writable a) + => Store -> String -> Identifier -> IO (Maybe a) storeGet store name identifier = do - exists <- doesFileExist path - if exists then Just <$> decodeFile path - else return Nothing + -- First check the in-memory map + map' <- readMVar $ storeMap store + case M.lookup path map' of + -- Found in the in-memory map + Just c -> return $ Just $ unCompiledItem c + -- Not found in the map, try the filesystem + Nothing -> do + exists <- doesFileExist path + if not exists + -- Not found in the filesystem either + then return Nothing + -- Found in the filesystem + else do v <- decodeFile path + addToMap store path v + return $ Just v where path = makePath store name identifier diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs index a93903f..db53d9a 100644 --- a/src/Hakyll/Core/Writable.hs +++ b/src/Hakyll/Core/Writable.hs @@ -8,7 +8,9 @@ module Hakyll.Core.Writable ) where import System.Directory (copyFile) +import Data.Word (Word8) +import qualified Data.ByteString as SB import Data.Binary (Binary) import Data.Typeable (Typeable) @@ -21,6 +23,9 @@ class Writable a where instance Writable [Char] where write = writeFile +instance Writable [Word8] where + write p = SB.writeFile p . SB.pack + -- | Newtype construct around 'FilePath' which will copy the file directly -- newtype CopyFile = CopyFile {unCopyFile :: FilePath} -- cgit v1.2.3 From 664648c5f9693fa5160a5c67aeabe8a9d38df03d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 5 Jan 2011 13:12:50 +0100 Subject: Proof-of-concept tag module --- src/Hakyll/Web/Page.hs | 10 ++++++++++ src/Hakyll/Web/Tags.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ src/Hakyll/Web/Util/String.hs | 15 +++++++++++++++ 3 files changed, 67 insertions(+) create mode 100644 src/Hakyll/Web/Tags.hs (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 883da74..00d143e 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page ( Page (..) + , getField , addField , toMap , pageRead @@ -15,6 +16,7 @@ import Prelude hiding (id) import Control.Category (id) import Control.Arrow ((>>^), (&&&), (>>>)) import System.FilePath (takeBaseName, takeDirectory) +import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as M @@ -24,6 +26,14 @@ import Hakyll.Web.Page.Internal import Hakyll.Web.Page.Read import Hakyll.Web.Util.String +-- | Get a metadata field. If the field does not exist, the empty string is +-- returned. +-- +getField :: String -- ^ Key + -> Page a -- ^ Page + -> String -- ^ Value +getField key = fromMaybe "" . M.lookup key . pageMetadata + -- | Add a metadata field. If the field already exists, it is not overwritten. -- addField :: String -- ^ Key diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs new file mode 100644 index 0000000..4986a31 --- /dev/null +++ b/src/Hakyll/Web/Tags.hs @@ -0,0 +1,42 @@ +module Hakyll.Web.Tags + ( Tags (..) + , readTagsWith + , readTags + , readCategories + ) where + +import Data.Map (Map) +import qualified Data.Map as M + +import Hakyll.Web.Page +import Hakyll.Web.Util.String + +-- | Data about tags +-- +data Tags a = Tags + { tagsMap :: Map String [Page a] + } deriving (Show) + +-- | Higher-level function to read tags +-- +readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page + -> [Page a] -- ^ Pages + -> Tags a -- ^ Resulting tags +readTagsWith f pages = Tags + { tagsMap = foldl (M.unionWith (++)) M.empty (map readTagsWith' pages) + } + where + -- Create a tag map for one page + readTagsWith' page = + let tags = f page + in M.fromList $ zip tags $ repeat [page] + +-- | Read a tagmap using the @tags@ metadata field +-- +readTags :: [Page a] -> Tags a +readTags = readTagsWith $ map trim . splitAll "," . getField "tags" + +-- | Read a tagmap using the @category@ metadata field +-- +readCategories :: [Page a] -> Tags a +readCategories = readTagsWith $ return . getField "category" diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs index ed8b904..0dde74a 100644 --- a/src/Hakyll/Web/Util/String.hs +++ b/src/Hakyll/Web/Util/String.hs @@ -3,6 +3,7 @@ module Hakyll.Web.Util.String ( trim , replaceAll + , splitAll , toUrl , toSiteRoot ) where @@ -35,6 +36,20 @@ replaceAll pattern f source = replaceAll' source (capture, after) = splitAt l tmp in before ++ f capture ++ replaceAll' after +-- | A simple regex split function. The resulting list will contain no empty +-- strings. +-- +splitAll :: String -- ^ Pattern + -> String -- ^ String to split + -> [String] -- ^ Result +splitAll pattern = filter (not . null) . splitAll' + where + splitAll' src = case listToMaybe (src =~~ pattern) of + Nothing -> [src] + Just (o, l) -> + let (before, tmp) = splitAt o src + in before : splitAll' (drop l tmp) + -- | Convert a filepath to an URL starting from the site root -- -- Example: -- cgit v1.2.3 From 70fa0c2ff1b50ec905d96b6bfb66546b354b1c01 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 10:14:36 +0100 Subject: Add waitFor directive --- src/Hakyll/Core/Compiler.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index e862dd8..ed38b12 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -7,6 +7,7 @@ module Hakyll.Core.Compiler , getIdentifier , getRoute , getResourceString + , waitFor , require , requireAll , cached @@ -82,6 +83,11 @@ getDependency identifier = CompilerM $ do ++ show identifier ++ " not found in the cache, the cache might be corrupted" +-- | Wait until another compiler has finished before running this compiler +-- +waitFor :: Identifier -> Compiler a a +waitFor = fromDependencies . const . return + -- | Require another target. Using this function ensures automatic handling of -- dependencies -- @@ -90,7 +96,7 @@ require :: (Binary a, Typeable a, Writable a) -> (b -> a -> c) -> Compiler b c require identifier f = - fromDependencies (const [identifier]) >>> fromJob require' + waitFor identifier >>> fromJob require' where require' x = do y <- getDependency identifier -- cgit v1.2.3 From 11d7031da3928b31cf622a8d1c21bced735dddd3 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 12:12:13 +0100 Subject: Add compilers producing compilers --- src/Hakyll/Core/Compiler.hs | 35 +++++++++++++++++++------------ src/Hakyll/Core/Rules.hs | 50 ++++++++++++++++++++++++++++++++++----------- src/Hakyll/Core/Run.hs | 2 +- 3 files changed, 61 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index ed38b12..73ee359 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -31,25 +31,34 @@ import Hakyll.Core.Writable import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal import Hakyll.Core.Store +import Hakyll.Core.Rules -- | 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 - -> Identifier -- ^ Target identifier - -> ResourceProvider -- ^ Resource provider - -> Maybe FilePath -- ^ Route - -> Store -- ^ Store - -> Bool -- ^ Was the resource modified? - -> IO CompiledItem -- ^ Resulting item -runCompiler compiler identifier provider route store modified = do +runCompiler :: Compiler () CompileRule -- ^ Compiler to run + -> Identifier -- ^ Target identifier + -> ResourceProvider -- ^ Resource provider + -> Maybe FilePath -- ^ Route + -> Store -- ^ Store + -> Bool -- ^ Was the resource modified? + -> IO CompileRule -- ^ Resulting item +runCompiler compiler identifier provider route' store modified = do -- Run the compiler job - CompiledItem result <- runCompilerJob - compiler identifier provider route store modified + result <- runCompilerJob compiler identifier provider route' store modified - -- Store a copy in the cache and return - storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result - return $ CompiledItem result + -- Inspect the result + case result of + -- In case we compiled an item, we will store a copy in the cache first, + -- before we return control. This makes sure the compiled item can later + -- be accessed by e.g. require. + ItemRule (CompiledItem x) -> + storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x + + -- Otherwise, we do nothing here + _ -> return () + + return result -- | Get the identifier of the item that is currently being compiled -- diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index de7f6d4..ea3eadc 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -3,19 +3,21 @@ -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Rules - ( RuleSet (..) + ( CompileRule (..) + , RuleSet (..) , RulesM , Rules , runRules , compile , create , route + , addCompilers ) where import Control.Applicative (Applicative, (<$>)) import Control.Monad.Writer import Control.Monad.Reader -import Control.Arrow (second, (>>>), arr) +import Control.Arrow (second, (>>>), arr, (>>^)) import Data.Typeable (Typeable) import Data.Binary (Binary) @@ -23,16 +25,26 @@ import Data.Binary (Binary) import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.Compiler +import Hakyll.Core.Compiler.Internal import Hakyll.Core.Route import Hakyll.Core.CompiledItem import Hakyll.Core.Writable +-- | 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 = ItemRule CompiledItem + | AddCompilersRule [(Identifier, Compiler () CompiledItem)] + -- | A collection of rules for the compilation process -- data RuleSet = RuleSet { rulesRoute :: Route - , rulesCompilers :: [(Identifier, Compiler () CompiledItem)] + , rulesCompilers :: [(Identifier, Compiler () CompileRule)] } instance Monoid RuleSet where @@ -58,18 +70,18 @@ runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider -- | Add a route -- -addRoute :: Route -> Rules -addRoute route' = RulesM $ tell $ RuleSet route' mempty +tellRoute :: Route -> Rules +tellRoute route' = RulesM $ tell $ RuleSet route' mempty -- | Add a number of compilers -- -addCompilers :: (Binary a, Typeable a, Writable a) +tellCompilers :: (Binary a, Typeable a, Writable a) => [(Identifier, Compiler () a)] -> Rules -addCompilers compilers = RulesM $ tell $ RuleSet mempty $ +tellCompilers compilers = RulesM $ tell $ RuleSet mempty $ map (second boxCompiler) compilers where - boxCompiler = (>>> arr compiledItem) + boxCompiler = (>>> arr compiledItem >>> arr ItemRule) -- | Add a compilation rule -- @@ -80,7 +92,7 @@ compile :: (Binary a, Typeable a, Writable a) => Pattern -> Compiler () a -> Rules compile pattern compiler = RulesM $ do identifiers <- matches pattern . resourceList <$> ask - unRulesM $ addCompilers $ zip identifiers (repeat compiler) + unRulesM $ tellCompilers $ zip identifiers (repeat compiler) -- | Add a compilation rule -- @@ -88,9 +100,23 @@ compile pattern compiler = RulesM $ do -- create :: (Binary a, Typeable a, Writable a) => Identifier -> Compiler () a -> Rules -create identifier compiler = addCompilers [(identifier, compiler)] +create identifier compiler = tellCompilers [(identifier, compiler)] -- | Add a route -- route :: Pattern -> Route -> Rules -route pattern route' = addRoute $ ifMatch pattern route' +route pattern route' = tellRoute $ ifMatch pattern route' + +-- | Add a compiler that produces other compilers over time +-- +addCompilers :: (Binary a, Typeable a, Writable a) + => Identifier + -- ^ Identifier for this compiler + -> Compiler () [(Identifier, Compiler () a)] + -- ^ Compiler generating the other compilers + -> Rules + -- ^ Resulting rules +addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty $ + [(identifier, compiler >>^ makeRule)] + where + makeRule = AddCompilersRule . map (second (>>^ compiledItem)) diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 7121068..0b102d8 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -91,7 +91,7 @@ hakyllWith rules provider store = do let isModified = id' `S.member` modified' -- Run the compiler - compiled <- runCompiler comp id' provider url store isModified + ItemRule compiled <- runCompiler comp id' provider url store isModified putStrLn $ "Generated target: " ++ show id' case url of -- cgit v1.2.3 From c7d63835f804334f70cdcfe0afa40be313cb2995 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 12:47:02 +0100 Subject: Move hakyllWith to hakyll monad --- src/Hakyll/Core/Run.hs | 55 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 38 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 0b102d8..2670c8e 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -1,7 +1,12 @@ -- | This is the module which binds it all together -- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Run where +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans import Control.Arrow ((&&&)) import Control.Monad (foldM, forM_, forM, filterM) import Data.Map (Map) @@ -34,10 +39,26 @@ hakyll :: Rules -> IO () hakyll rules = do store <- makeStore "_store" provider <- fileResourceProvider - hakyllWith rules provider store - -hakyllWith :: Rules -> ResourceProvider -> Store -> IO () -hakyllWith rules provider store = do + evalStateT + (runReaderT + (unHakyll (hakyllWith rules provider store)) undefined) undefined + +data HakyllState = HakyllState + { hakyllCompilers :: [(Identifier, Compiler () CompileRule)] + } + +data HakyllEnvironment = HakyllEnvironment + { hakyllRoute :: Route + , hakyllResourceProvider :: ResourceProvider + , hakyllStore :: Store + } + +newtype Hakyll a = Hakyll + { unHakyll :: ReaderT HakyllEnvironment (StateT HakyllState IO) a + } deriving (Functor, Applicative, Monad) + +hakyllWith :: Rules -> ResourceProvider -> Store -> Hakyll () +hakyllWith rules provider store = Hakyll $ do let -- Get the rule set ruleSet = runRules rules provider @@ -55,17 +76,19 @@ hakyllWith rules provider store = do -- Create the graph graph = fromList dependencies - putStrLn "Writing dependency graph to dependencies.dot..." - writeDot "dependencies.dot" show graph + liftIO $ do + putStrLn "Writing dependency graph to dependencies.dot..." + writeDot "dependencies.dot" show graph -- Check which items are up-to-date - modified' <- modified provider store $ map fst compilers + modified' <- liftIO $ modified provider store $ map fst compilers let -- Try to reduce the graph reducedGraph = filterObsolete modified' graph - putStrLn "Writing reduced graph to reduced.dot..." - writeDot "reduced.dot" show reducedGraph + liftIO $ do + putStrLn "Writing reduced graph to reduced.dot..." + writeDot "reduced.dot" show reducedGraph let -- Solve the graph ordered = solveDependencies reducedGraph @@ -76,13 +99,10 @@ hakyllWith rules provider store = do -- Fetch the routes route' = rulesRoute ruleSet - putStrLn $ show reducedGraph - putStrLn $ show ordered - -- Generate all the targets in order _ <- mapM (addTarget route' modified') orderedCompilers - putStrLn "DONE." + liftIO $ putStrLn "DONE." where addTarget route' modified' (id', comp) = do let url = runRoute route' id' @@ -91,18 +111,19 @@ hakyllWith rules provider store = do let isModified = id' `S.member` modified' -- Run the compiler - ItemRule compiled <- runCompiler comp id' provider url store isModified - putStrLn $ "Generated target: " ++ show id' + ItemRule compiled <- liftIO $ + runCompiler comp id' provider url store isModified + liftIO $ putStrLn $ "Generated target: " ++ show id' case url of Nothing -> return () - Just r -> do + Just r -> liftIO $ do putStrLn $ "Routing " ++ show id' ++ " to " ++ r let path = "_site" r makeDirectories path write path compiled - putStrLn "" + liftIO $ putStrLn "" -- | Return a set of modified identifiers -- -- cgit v1.2.3 From 9e88440102842ca7fbed342e7f29ab9ea1dfea6f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 14:22:15 +0100 Subject: Restructure hakyllWith for metacompilers --- src/Hakyll/Core/Run.hs | 141 ++++++++++++++++++++++++++++--------------------- 1 file changed, 81 insertions(+), 60 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 2670c8e..ed9cea6 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -39,98 +39,119 @@ hakyll :: Rules -> IO () hakyll rules = do store <- makeStore "_store" provider <- fileResourceProvider - evalStateT - (runReaderT - (unHakyll (hakyllWith rules provider store)) undefined) undefined - -data HakyllState = HakyllState - { hakyllCompilers :: [(Identifier, Compiler () CompileRule)] - } + let ruleSet = runRules rules provider + compilers = rulesCompilers ruleSet + runReaderT (unHakyll (addNewCompilers [] compilers)) $ + env ruleSet provider store + where + env ruleSet provider store = HakyllEnvironment + { hakyllRoute = rulesRoute ruleSet + , hakyllResourceProvider = provider + , hakyllStore = store + , hakyllModified = S.empty + } data HakyllEnvironment = HakyllEnvironment { hakyllRoute :: Route , hakyllResourceProvider :: ResourceProvider , hakyllStore :: Store + , hakyllModified :: Set Identifier } newtype Hakyll a = Hakyll - { unHakyll :: ReaderT HakyllEnvironment (StateT HakyllState IO) a + { unHakyll :: ReaderT HakyllEnvironment IO a } deriving (Functor, Applicative, Monad) -hakyllWith :: Rules -> ResourceProvider -> Store -> Hakyll () -hakyllWith rules provider store = Hakyll $ do - let -- Get the rule set - ruleSet = runRules rules provider - - -- Get all identifiers and compilers - compilers = rulesCompilers ruleSet +-- | Return a set of modified identifiers +-- +modified :: ResourceProvider -- ^ Resource provider + -> Store -- ^ Store + -> [Identifier] -- ^ Identifiers to check + -> IO (Set Identifier) -- ^ Modified resources +modified provider store ids = fmap S.fromList $ flip filterM ids $ \id' -> + if resourceExists provider id' then resourceModified provider id' store + else return False - -- Get all dependencies +-- | Add a number of compilers and continue using these compilers +-- +addNewCompilers :: [(Identifier, Compiler () CompileRule)] + -- ^ Remaining compilers yet to be run + -> [(Identifier, Compiler () CompileRule)] + -- ^ Compilers to add + -> Hakyll () +addNewCompilers oldCompilers newCompilers = Hakyll $ do + -- Get some information + provider <- hakyllResourceProvider <$> ask + store <- hakyllStore <$> ask + + let -- All compilers + compilers = oldCompilers ++ newCompilers + + -- Get all dependencies for the compilers dependencies = flip map compilers $ \(id', compiler) -> let deps = runCompilerDependencies compiler provider in (id', deps) - -- Create a compiler map + -- Create a compiler map (Id -> Compiler) compilerMap = M.fromList compilers - -- Create the graph + -- Create the dependency graph graph = fromList dependencies - liftIO $ do - putStrLn "Writing dependency graph to dependencies.dot..." - writeDot "dependencies.dot" show graph - - -- Check which items are up-to-date + -- Check which items are up-to-date. This only needs to happen for the new + -- compilers modified' <- liftIO $ modified provider store $ map fst compilers - let -- Try to reduce the graph + let -- Try to reduce the graph using this modified information reducedGraph = filterObsolete modified' graph - liftIO $ do - putStrLn "Writing reduced graph to reduced.dot..." - writeDot "reduced.dot" show reducedGraph - let -- Solve the graph ordered = solveDependencies reducedGraph -- Join the order with the compilers again orderedCompilers = map (id &&& (compilerMap M.!)) ordered - -- Fetch the routes - route' = rulesRoute ruleSet - - -- Generate all the targets in order - _ <- mapM (addTarget route' modified') orderedCompilers - - liftIO $ putStrLn "DONE." + -- Now run the ordered list of compilers + local (updateModified modified') $ unHakyll $ runCompilers orderedCompilers where - addTarget route' modified' (id', comp) = do - let url = runRoute route' id' - + -- Add the modified information for the new compilers + updateModified modified' env = env + { hakyllModified = hakyllModified env `S.union` modified' + } + +runCompilers :: [(Identifier, Compiler () CompileRule)] + -- ^ Ordered list of compilers + -> Hakyll () + -- ^ No result +runCompilers [] = return () +runCompilers ((id', compiler) : compilers) = Hakyll $ do + -- Obtain information + route' <- hakyllRoute <$> ask + provider <- hakyllResourceProvider <$> ask + store <- hakyllStore <$> ask + modified' <- hakyllModified <$> ask + + let -- Determine the URL + url = runRoute route' id' + -- Check if the resource was modified - let isModified = id' `S.member` modified' + isModified = id' `S.member` modified' - -- Run the compiler - ItemRule compiled <- liftIO $ - runCompiler comp id' provider url store isModified - liftIO $ putStrLn $ "Generated target: " ++ show id' + -- Run the compiler + result <- liftIO $ runCompiler compiler id' provider url store isModified + liftIO $ putStrLn $ "Generated target: " ++ show id' - case url of - Nothing -> return () - Just r -> liftIO $ do - putStrLn $ "Routing " ++ show id' ++ " to " ++ r - let path = "_site" r - makeDirectories path - write path compiled + let ItemRule compiled = result - liftIO $ putStrLn "" + case url of + Nothing -> return () + Just r -> liftIO $ do + putStrLn $ "Routing " ++ show id' ++ " to " ++ r + let path = "_site" r + makeDirectories path + write path compiled --- | Return a set of modified identifiers --- -modified :: ResourceProvider -- ^ Resource provider - -> Store -- ^ Store - -> [Identifier] -- ^ Identifiers to check - -> IO (Set Identifier) -- ^ Modified resources -modified provider store ids = fmap S.fromList $ flip filterM ids $ \id' -> - if resourceExists provider id' then resourceModified provider id' store - else return False + liftIO $ putStrLn "" + + -- Continue for the remaining compilers + unHakyll $ runCompilers compilers -- cgit v1.2.3 From f1e726be69b7ed78f7b8f7eed4b41305b125a3bb Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 14:34:31 +0100 Subject: Renaming for consistency --- src/Hakyll/Core/Compiler.hs | 2 +- src/Hakyll/Core/Rules.hs | 8 ++++---- src/Hakyll/Core/Run.hs | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 73ee359..f754860 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -52,7 +52,7 @@ runCompiler compiler identifier provider route' store modified = do -- In case we compiled an item, we will store a copy in the cache first, -- before we return control. This makes sure the compiled item can later -- be accessed by e.g. require. - ItemRule (CompiledItem x) -> + CompileRule (CompiledItem x) -> storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x -- Otherwise, we do nothing here diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index ea3eadc..ccfde53 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -37,8 +37,8 @@ import Hakyll.Core.Writable -- * 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 = ItemRule CompiledItem - | AddCompilersRule [(Identifier, Compiler () CompiledItem)] +data CompileRule = CompileRule CompiledItem + | MetaCompileRule [(Identifier, Compiler () CompiledItem)] -- | A collection of rules for the compilation process -- @@ -81,7 +81,7 @@ tellCompilers :: (Binary a, Typeable a, Writable a) tellCompilers compilers = RulesM $ tell $ RuleSet mempty $ map (second boxCompiler) compilers where - boxCompiler = (>>> arr compiledItem >>> arr ItemRule) + boxCompiler = (>>> arr compiledItem >>> arr CompileRule) -- | Add a compilation rule -- @@ -119,4 +119,4 @@ addCompilers :: (Binary a, Typeable a, Writable a) addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty $ [(identifier, compiler >>^ makeRule)] where - makeRule = AddCompilersRule . map (second (>>^ compiledItem)) + makeRule = MetaCompileRule . map (second (>>^ compiledItem)) diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index ed9cea6..31280db 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -141,7 +141,7 @@ runCompilers ((id', compiler) : compilers) = Hakyll $ do result <- liftIO $ runCompiler compiler id' provider url store isModified liftIO $ putStrLn $ "Generated target: " ++ show id' - let ItemRule compiled = result + let CompileRule compiled = result case url of Nothing -> return () -- cgit v1.2.3 From 1bf95c0028b041ae57a28cf1592db75010fe0f08 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 14:40:33 +0100 Subject: Rank N compilers (compiler in compilers in...) --- src/Hakyll/Core/Rules.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index ccfde53..28ae555 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -38,7 +38,7 @@ import Hakyll.Core.Writable -- added to the runtime if possible, since other items might depend upon them. -- data CompileRule = CompileRule CompiledItem - | MetaCompileRule [(Identifier, Compiler () CompiledItem)] + | MetaCompileRule [(Identifier, Compiler () CompileRule)] -- | A collection of rules for the compilation process -- @@ -119,4 +119,4 @@ addCompilers :: (Binary a, Typeable a, Writable a) addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty $ [(identifier, compiler >>^ makeRule)] where - makeRule = MetaCompileRule . map (second (>>^ compiledItem)) + makeRule = MetaCompileRule . map (second (>>^ CompileRule . compiledItem)) -- cgit v1.2.3 From 7bf3450caf5900a5a3f11c0358dbffbf72f5ef1a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 14:48:47 +0100 Subject: Run metacompilers instead of ignoring them --- src/Hakyll/Core/Run.hs | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 31280db..e850d99 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -141,17 +141,23 @@ runCompilers ((id', compiler) : compilers) = Hakyll $ do result <- liftIO $ runCompiler compiler id' provider url store isModified liftIO $ putStrLn $ "Generated target: " ++ show id' - let CompileRule compiled = result - - case url of - Nothing -> return () - Just r -> liftIO $ do - putStrLn $ "Routing " ++ show id' ++ " to " ++ r - let path = "_site" r - makeDirectories path - write path compiled - - liftIO $ putStrLn "" - - -- Continue for the remaining compilers - unHakyll $ runCompilers compilers + case result of + -- Compile rule for one item, easy stuff + CompileRule compiled -> do + case url of + Nothing -> return () + Just r -> liftIO $ do + putStrLn $ "Routing " ++ show id' ++ " to " ++ r + let path = "_site" r + makeDirectories path + write path compiled + + liftIO $ putStrLn "" + + -- Continue for the remaining compilers + unHakyll $ runCompilers compilers + + -- Metacompiler, slightly more complicated + MetaCompileRule newCompilers -> do + -- Actually I was just kidding, it's not hard at all + unHakyll $ addNewCompilers compilers newCompilers -- cgit v1.2.3 From 672ecb077c7edd6a542958a2c9ede5c8ea14bbc4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 15:09:55 +0100 Subject: Add fromCapture(s) --- src/Hakyll/Core/Identifier.hs | 4 +++- src/Hakyll/Core/Identifier/Pattern.hs | 26 ++++++++++++++++++++++++-- 2 files changed, 27 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs index 609e722..ea03e8c 100644 --- a/src/Hakyll/Core/Identifier.hs +++ b/src/Hakyll/Core/Identifier.hs @@ -10,6 +10,7 @@ -- -- * @error/404@ -- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Identifier ( Identifier (..) , parseIdentifier @@ -17,6 +18,7 @@ module Hakyll.Core.Identifier ) where import Control.Arrow (second) +import Data.Monoid (Monoid) import GHC.Exts (IsString, fromString) import System.FilePath (joinPath) @@ -24,7 +26,7 @@ import System.FilePath (joinPath) -- | An identifier used to uniquely identify a value -- newtype Identifier = Identifier {unIdentifier :: [String]} - deriving (Eq, Ord) + deriving (Eq, Ord, Monoid) instance Show Identifier where show = toFilePath diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index b5f01e5..0590387 100644 --- a/src/Hakyll/Core/Identifier/Pattern.hs +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -34,11 +34,14 @@ module Hakyll.Core.Identifier.Pattern , match , doesMatch , matches + , fromCapture + , fromCaptures ) where import Data.List (intercalate) import Control.Monad (msum) import Data.Maybe (isJust) +import Data.Monoid (mempty, mappend) import GHC.Exts (IsString, fromString) @@ -78,8 +81,8 @@ parsePattern = Pattern . map toPattern . unIdentifier . parseIdentifier -- | Match an identifier against a pattern, generating a list of captures -- -match :: Pattern -> Identifier -> Maybe [[String]] -match (Pattern p) (Identifier i) = match' p i +match :: Pattern -> Identifier -> Maybe [Identifier] +match (Pattern p) (Identifier i) = fmap (map Identifier) $ match' p i -- | Check if an identifier matches a pattern -- @@ -115,3 +118,22 @@ match' (m : ms) (s : ss) = case m of CaptureMany -> let take' (i, t) = fmap (i :) $ match' ms t in msum $ map take' $ splits (s : ss) + +-- | Create an identifier from a pattern by filling in the captures with a given +-- string +-- +fromCapture :: Pattern -> Identifier -> Identifier +fromCapture pattern = fromCaptures pattern . repeat + +-- | Create an identifier from a pattern by filling in the captures with the +-- given list of strings +-- +fromCaptures :: Pattern -> [Identifier] -> Identifier +fromCaptures (Pattern []) _ = mempty +fromCaptures (Pattern (m : ms)) [] = case m of + Literal l -> Identifier [l] `mappend` fromCaptures (Pattern ms) [] + _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures: " + ++ "identifier list exhausted" +fromCaptures (Pattern (m : ms)) ids@(i : is) = case m of + Literal l -> Identifier [l] `mappend` fromCaptures (Pattern ms) ids + _ -> i `mappend` fromCaptures (Pattern ms) is -- cgit v1.2.3 From c443d5c116b5bd62dfb4484bce784529678605e5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 15:12:22 +0100 Subject: Binary/Typeable/Writable instances for Tags --- src/Hakyll/Web/Tags.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 4986a31..cf0d9a5 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Tags ( Tags (..) , readTagsWith @@ -5,17 +6,29 @@ module Hakyll.Web.Tags , readCategories ) where +import Control.Applicative ((<$>)) import Data.Map (Map) import qualified Data.Map as M +import Data.Typeable (Typeable) +import Data.Binary (Binary, get, put) + import Hakyll.Web.Page import Hakyll.Web.Util.String +import Hakyll.Core.Writable -- | Data about tags -- data Tags a = Tags { tagsMap :: Map String [Page a] - } deriving (Show) + } deriving (Show, Typeable) + +instance Binary a => Binary (Tags a) where + get = Tags <$> get + put (Tags m) = put m + +instance Writable (Tags a) where + write _ _ = return () -- | Higher-level function to read tags -- -- cgit v1.2.3 From ddb8ea219319f024df02bafe9ce2ed7d3a7ee41d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 15:44:11 +0100 Subject: Metacompilers now work, except for "modified" --- src/Hakyll/Core/Run.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index e850d99..dea848b 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -100,7 +100,11 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do -- Check which items are up-to-date. This only needs to happen for the new -- compilers - modified' <- liftIO $ modified provider store $ map fst compilers + oldModified <- hakyllModified <$> ask + newModified <- liftIO $ modified provider store $ map fst newCompilers + let modified' = oldModified `S.union` newModified + + liftIO $ putStrLn $ show modified' let -- Try to reduce the graph using this modified information reducedGraph = filterObsolete modified' graph @@ -111,12 +115,14 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do -- Join the order with the compilers again orderedCompilers = map (id &&& (compilerMap M.!)) ordered + liftIO $ putStrLn "Adding compilers..." + -- Now run the ordered list of compilers local (updateModified modified') $ unHakyll $ runCompilers orderedCompilers where -- Add the modified information for the new compilers updateModified modified' env = env - { hakyllModified = hakyllModified env `S.union` modified' + { hakyllModified = modified' } runCompilers :: [(Identifier, Compiler () CompileRule)] -- cgit v1.2.3 From d0939102bf26ed81b4e57dc96f44e5330913ab6f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 7 Jan 2011 19:17:14 +0100 Subject: Metacompilers now work, todo: cleanup --- src/Hakyll/Core/Compiler.hs | 9 ++------- src/Hakyll/Core/Compiler/Internal.hs | 6 ++++++ src/Hakyll/Core/DirectedGraph.hs | 23 +++++++-------------- src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs | 27 ------------------------- src/Hakyll/Core/Rules.hs | 5 +++-- src/Hakyll/Core/Run.hs | 27 ++++++++++++++++--------- 6 files changed, 35 insertions(+), 62 deletions(-) delete mode 100644 src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index f754860..4c624e2 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -7,7 +7,7 @@ module Hakyll.Core.Compiler , getIdentifier , getRoute , getResourceString - , waitFor + , fromDependency , require , requireAll , cached @@ -92,11 +92,6 @@ getDependency identifier = CompilerM $ do ++ show identifier ++ " not found in the cache, the cache might be corrupted" --- | Wait until another compiler has finished before running this compiler --- -waitFor :: Identifier -> Compiler a a -waitFor = fromDependencies . const . return - -- | Require another target. Using this function ensures automatic handling of -- dependencies -- @@ -105,7 +100,7 @@ require :: (Binary a, Typeable a, Writable a) -> (b -> a -> c) -> Compiler b c require identifier f = - waitFor identifier >>> fromJob require' + fromDependency identifier >>> fromJob require' where require' x = do y <- getDependency identifier diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 0642b85..938d81a 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -10,6 +10,7 @@ module Hakyll.Core.Compiler.Internal , runCompilerDependencies , fromJob , fromDependencies + , fromDependency ) where import Prelude hiding ((.), id) @@ -101,3 +102,8 @@ fromJob = Compiler (return S.empty) fromDependencies :: (ResourceProvider -> [Identifier]) -> Compiler b b fromDependencies deps = Compiler (S.fromList . deps <$> ask) return + +-- | Wait until another compiler has finished before running this compiler +-- +fromDependency :: Identifier -> Compiler a a +fromDependency = fromDependencies . const . return diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs index b24ce25..bf52277 100644 --- a/src/Hakyll/Core/DirectedGraph.hs +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -7,11 +7,10 @@ module Hakyll.Core.DirectedGraph , nodes , neighbours , reverse - , filter , reachableNodes ) where -import Prelude hiding (reverse, filter) +import Prelude hiding (reverse) import Data.Monoid (mconcat) import Data.Set (Set) import Data.Maybe (fromMaybe) @@ -53,24 +52,16 @@ reverse = mconcat . map reverse' . M.toList . unDirectedGraph reverse' (id', Node _ neighbours') = fromList $ zip (S.toList neighbours') $ repeat $ S.singleton id' --- | Filter a directed graph (i.e. remove nodes based on a predicate) +-- | Find all reachable nodes from a given set of nodes in the directed graph -- -filter :: Ord a - => (a -> Bool) -- ^ Predicate - -> DirectedGraph a -- ^ Graph - -> DirectedGraph a -- ^ Resulting graph -filter predicate = - DirectedGraph . M.filterWithKey (\k _ -> predicate k) . unDirectedGraph - --- | Find all reachable nodes from a given node in the directed graph --- -reachableNodes :: Ord a => a -> DirectedGraph a -> Set a -reachableNodes x graph = reachable (neighbours x graph) (S.singleton x) +reachableNodes :: Ord a => Set a -> DirectedGraph a -> Set a +reachableNodes set graph = reachable (setNeighbours set) set where reachable next visited | S.null next = visited | otherwise = reachable (sanitize neighbours') (next `S.union` visited) where sanitize = S.filter (`S.notMember` visited) - neighbours' = S.unions $ map (flip neighbours graph) - $ S.toList $ sanitize next + neighbours' = setNeighbours (sanitize next) + + setNeighbours = S.unions . map (flip neighbours graph) . S.toList diff --git a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs b/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs deleted file mode 100644 index 9aeb2ff..0000000 --- a/src/Hakyll/Core/DirectedGraph/ObsoleteFilter.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Module exporting a function that works as a filter on a dependency graph. --- Given a list of obsolete nodes, this filter will reduce the graph so it only --- contains obsolete nodes and nodes that depend (directly or indirectly) on --- obsolete nodes. --- -module Hakyll.Core.DirectedGraph.ObsoleteFilter - ( filterObsolete - ) where - -import Data.Set (Set) -import qualified Data.Set as S - -import Hakyll.Core.DirectedGraph -import qualified Hakyll.Core.DirectedGraph as DG - --- | Given a list of obsolete items, filter the dependency graph so it only --- contains these items --- -filterObsolete :: Ord a - => Set a -- ^ Obsolete items - -> DirectedGraph a -- ^ Dependency graph - -> DirectedGraph a -- ^ Resulting dependency graph -filterObsolete obsolete graph = - let reversed = DG.reverse graph - allObsolete = S.unions $ map (flip reachableNodes reversed) - $ S.toList obsolete - in DG.filter (`S.member` allObsolete) graph diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 28ae555..ae476b7 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -117,6 +117,7 @@ addCompilers :: (Binary a, Typeable a, Writable a) -> Rules -- ^ Resulting rules addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty $ - [(identifier, compiler >>^ makeRule)] + [(identifier, compiler >>> arr makeRule )] where - makeRule = MetaCompileRule . map (second (>>^ CompileRule . compiledItem)) + makeRule = MetaCompileRule . map (second box) + box = (>>> fromDependency identifier >>^ CompileRule . compiledItem) diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index dea848b..324294f 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Run where +import Prelude hiding (reverse) import Control.Applicative import Control.Monad.Reader import Control.Monad.State @@ -30,7 +31,6 @@ import Hakyll.Core.Rules import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver -import Hakyll.Core.DirectedGraph.ObsoleteFilter import Hakyll.Core.Writable import Hakyll.Core.Store import Hakyll.Core.CompiledItem @@ -49,6 +49,7 @@ hakyll rules = do , hakyllResourceProvider = provider , hakyllStore = store , hakyllModified = S.empty + , hakyllObsolete = S.empty } data HakyllEnvironment = HakyllEnvironment @@ -56,6 +57,7 @@ data HakyllEnvironment = HakyllEnvironment , hakyllResourceProvider :: ResourceProvider , hakyllStore :: Store , hakyllModified :: Set Identifier + , hakyllObsolete :: Set Identifier } newtype Hakyll a = Hakyll @@ -98,19 +100,22 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do -- Create the dependency graph graph = fromList dependencies + liftIO $ writeDot "dependencies.dot" show graph + -- Check which items are up-to-date. This only needs to happen for the new -- compilers oldModified <- hakyllModified <$> ask newModified <- liftIO $ modified provider store $ map fst newCompilers - let modified' = oldModified `S.union` newModified + oldObsolete <- hakyllObsolete <$> ask - liftIO $ putStrLn $ show modified' - - let -- Try to reduce the graph using this modified information - reducedGraph = filterObsolete modified' graph + let modified' = oldModified `S.union` newModified + + -- Find obsolete items + obsolete = reachableNodes (oldObsolete `S.union` modified') $ + reverse graph - let -- Solve the graph - ordered = solveDependencies reducedGraph + -- Solve the graph, retain only the obsolete items + ordered = filter (`S.member` obsolete) $ solveDependencies graph -- Join the order with the compilers again orderedCompilers = map (id &&& (compilerMap M.!)) ordered @@ -118,11 +123,13 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do liftIO $ putStrLn "Adding compilers..." -- Now run the ordered list of compilers - local (updateModified modified') $ unHakyll $ runCompilers orderedCompilers + local (updateEnv modified' obsolete) $ + unHakyll $ runCompilers orderedCompilers where -- Add the modified information for the new compilers - updateModified modified' env = env + updateEnv modified' obsolete env = env { hakyllModified = modified' + , hakyllObsolete = obsolete } runCompilers :: [(Identifier, Compiler () CompileRule)] -- cgit v1.2.3 From df8e221aef147ded6e8fe7331619913cc2f51513 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 8 Jan 2011 09:09:11 +0100 Subject: Fully qualified errors --- src/Hakyll/Core/CompiledItem.hs | 2 +- src/Hakyll/Core/DirectedGraph/DependencySolver.hs | 5 ++++- src/Hakyll/Core/DirectedGraph/Internal.hs | 5 ++++- src/Hakyll/Web/Pandoc.hs | 2 +- src/Hakyll/Web/Template/Internal.hs | 3 ++- 5 files changed, 12 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs index d12d172..a803971 100644 --- a/src/Hakyll/Core/CompiledItem.hs +++ b/src/Hakyll/Core/CompiledItem.hs @@ -36,4 +36,4 @@ unCompiledItem :: (Binary a, Typeable a, Writable a) -> a unCompiledItem (CompiledItem x) = case cast x of Just x' -> x' - Nothing -> error "unCompiledItem: Unsupported type" + Nothing -> error "Hakyll.Core.CompiledItem.unCompiledItem: Unsupported type" diff --git a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs index 17a4b69..214211b 100644 --- a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs +++ b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs @@ -60,8 +60,11 @@ order temp stack set graph@(DirectedGraph graph') -- one first... (dep : _) -> if (nodeTag dep) `S.member` set -- The dependency is already in our stack - cycle detected! - then error "order: Cycle detected!" -- TODO: Dump cycle + then cycleError -- Continue with the dependency else order temp (dep : node : stackTail) (S.insert (nodeTag dep) set) graph + where + cycleError = error $ "Hakyll.Core.DirectedGraph.DependencySolver.order: " + ++ "Cycle detected!" -- TODO: Dump cycle diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs index 52a712d..bc9cd92 100644 --- a/src/Hakyll/Core/DirectedGraph/Internal.hs +++ b/src/Hakyll/Core/DirectedGraph/Internal.hs @@ -24,8 +24,11 @@ data Node a = Node -- appendNodes :: Ord a => Node a -> Node a -> Node a appendNodes (Node t1 n1) (Node t2 n2) - | t1 /= t2 = error "appendNodes: Appending differently tagged nodes" + | t1 /= t2 = error' | otherwise = Node t1 (n1 `S.union` n2) + where + error' = error $ "Hakyll.Core.DirectedGraph.Internal.appendNodes: " + ++ "Appending differently tagged nodes" -- | Type used to represent a directed graph -- diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 7fecdc4..2656212 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -50,7 +50,7 @@ readPandocWith state fileType' = case fileType' of Markdown -> P.readMarkdown state Rst -> P.readRST state t -> error $ - "readPandoc: I don't know how to read " ++ show t + "Hakyll.Web.readPandocWith: I don't know how to read " ++ show t -- | Write a document (as HTML) using pandoc, with the default options -- diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs index be10881..096c928 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -41,4 +41,5 @@ instance Binary TemplateElement where 0 -> Chunk <$> get 1 -> Identifier <$> get 2 -> Escaped <$> get - _ -> error "Error reading cached template" + _ -> error $ "Hakyll.Web.Template.Internal: " + ++ "Error reading cached template" -- cgit v1.2.3 From c6710ac09a5ae0155b83a30497af65be17a44b00 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 8 Jan 2011 10:31:08 +0100 Subject: Migrate Reader → Reader, State in Run module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Core/Run.hs | 39 ++++++++++++++++++++++++++------------- 1 file changed, 26 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 324294f..a010af4 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -41,27 +41,39 @@ hakyll rules = do provider <- fileResourceProvider let ruleSet = runRules rules provider compilers = rulesCompilers ruleSet - runReaderT (unHakyll (addNewCompilers [] compilers)) $ - env ruleSet provider store + + -- Extract the reader/state + reader = unHakyll $ addNewCompilers [] compilers + state' = runReaderT reader $ env ruleSet provider store + + evalStateT state' state where env ruleSet provider store = HakyllEnvironment { hakyllRoute = rulesRoute ruleSet , hakyllResourceProvider = provider , hakyllStore = store - , hakyllModified = S.empty - , hakyllObsolete = S.empty + } + + state = HakyllState + { hakyllModified = S.empty + , hakyllObsolete = S.empty + , hakyllGraph = mempty } data HakyllEnvironment = HakyllEnvironment { hakyllRoute :: Route , hakyllResourceProvider :: ResourceProvider , hakyllStore :: Store - , hakyllModified :: Set Identifier - , hakyllObsolete :: Set Identifier + } + +data HakyllState = HakyllState + { hakyllModified :: Set Identifier + , hakyllObsolete :: Set Identifier + , hakyllGraph :: DirectedGraph Identifier } newtype Hakyll a = Hakyll - { unHakyll :: ReaderT HakyllEnvironment IO a + { unHakyll :: ReaderT HakyllEnvironment (StateT HakyllState IO) a } deriving (Functor, Applicative, Monad) -- | Return a set of modified identifiers @@ -104,9 +116,9 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do -- Check which items are up-to-date. This only needs to happen for the new -- compilers - oldModified <- hakyllModified <$> ask + oldModified <- hakyllModified <$> get newModified <- liftIO $ modified provider store $ map fst newCompilers - oldObsolete <- hakyllObsolete <$> ask + oldObsolete <- hakyllObsolete <$> get let modified' = oldModified `S.union` newModified @@ -122,12 +134,13 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do liftIO $ putStrLn "Adding compilers..." + modify $ updateState modified' obsolete + -- Now run the ordered list of compilers - local (updateEnv modified' obsolete) $ - unHakyll $ runCompilers orderedCompilers + unHakyll $ runCompilers orderedCompilers where -- Add the modified information for the new compilers - updateEnv modified' obsolete env = env + updateState modified' obsolete state = state { hakyllModified = modified' , hakyllObsolete = obsolete } @@ -142,7 +155,7 @@ runCompilers ((id', compiler) : compilers) = Hakyll $ do route' <- hakyllRoute <$> ask provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask - modified' <- hakyllModified <$> ask + modified' <- hakyllModified <$> get let -- Determine the URL url = runRoute route' id' -- cgit v1.2.3 From 607b1d7d6303f59bcd6a45473287a36721652162 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 11 Jan 2011 19:55:34 +0100 Subject: sanitize function for DirectedGraph --- src/Hakyll/Core/DirectedGraph.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs index bf52277..66905f7 100644 --- a/src/Hakyll/Core/DirectedGraph.hs +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -8,6 +8,7 @@ module Hakyll.Core.DirectedGraph , neighbours , reverse , reachableNodes + , sanitize ) where import Prelude hiding (reverse) @@ -59,9 +60,17 @@ reachableNodes set graph = reachable (setNeighbours set) set where reachable next visited | S.null next = visited - | otherwise = reachable (sanitize neighbours') (next `S.union` visited) + | otherwise = reachable (sanitize' neighbours') (next `S.union` visited) where - sanitize = S.filter (`S.notMember` visited) - neighbours' = setNeighbours (sanitize next) + sanitize' = S.filter (`S.notMember` visited) + neighbours' = setNeighbours (sanitize' next) setNeighbours = S.unions . map (flip neighbours graph) . S.toList + +-- | Remove all dangling pointers, i.e. references to notes that do +-- not actually exist in the graph. +-- +sanitize :: Ord a => DirectedGraph a -> DirectedGraph a +sanitize (DirectedGraph graph) = DirectedGraph $ M.map sanitize' $ graph + where + sanitize' (Node t n) = Node t $ S.filter (`M.member` graph) n -- cgit v1.2.3 From 3ea3c52f535d3faaa930dfc4ef5812f0ef690ec3 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 11 Jan 2011 20:20:34 +0100 Subject: Rewrite Run module a bit, get rid off obsolete --- src/Hakyll/Core/Run.hs | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index a010af4..77b3fab 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -12,7 +12,7 @@ import Control.Arrow ((&&&)) import Control.Monad (foldM, forM_, forM, filterM) import Data.Map (Map) import qualified Data.Map as M -import Data.Monoid (mempty) +import Data.Monoid (mempty, mappend) import Data.Typeable (Typeable) import Data.Binary (Binary) import System.FilePath (()) @@ -56,7 +56,6 @@ hakyll rules = do state = HakyllState { hakyllModified = S.empty - , hakyllObsolete = S.empty , hakyllGraph = mempty } @@ -68,7 +67,6 @@ data HakyllEnvironment = HakyllEnvironment data HakyllState = HakyllState { hakyllModified :: Set Identifier - , hakyllObsolete :: Set Identifier , hakyllGraph :: DirectedGraph Identifier } @@ -98,7 +96,10 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask - let -- All compilers + let -- Create a set of new compilers + newCompilerIdentifiers = S.fromList $ map fst newCompilers + + -- All compilers compilers = oldCompilers ++ newCompilers -- Get all dependencies for the compilers @@ -110,39 +111,44 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do compilerMap = M.fromList compilers -- Create the dependency graph - graph = fromList dependencies + currentGraph = fromList dependencies + + -- Find the old graph and append the new graph to it. This forms the + -- complete graph + completeGraph <- (mappend currentGraph) . hakyllGraph <$> get - liftIO $ writeDot "dependencies.dot" show graph + liftIO $ writeDot "dependencies.dot" show completeGraph -- Check which items are up-to-date. This only needs to happen for the new -- compilers oldModified <- hakyllModified <$> get newModified <- liftIO $ modified provider store $ map fst newCompilers - oldObsolete <- hakyllObsolete <$> get let modified' = oldModified `S.union` newModified - -- Find obsolete items - obsolete = reachableNodes (oldObsolete `S.union` modified') $ - reverse graph + -- Find obsolete items. Every item that is reachable from a modified + -- item is considered obsolete. From these obsolete items, we are only + -- interested in ones that are in the current subgraph. + obsolete = S.filter (`S.member` newCompilerIdentifiers) + $ reachableNodes modified' $ reverse completeGraph - -- Solve the graph, retain only the obsolete items - ordered = filter (`S.member` obsolete) $ solveDependencies graph + -- Solve the graph and retain only the obsolete items + ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph -- Join the order with the compilers again orderedCompilers = map (id &&& (compilerMap M.!)) ordered liftIO $ putStrLn "Adding compilers..." - modify $ updateState modified' obsolete + modify $ updateState modified' completeGraph -- Now run the ordered list of compilers unHakyll $ runCompilers orderedCompilers where -- Add the modified information for the new compilers - updateState modified' obsolete state = state + updateState modified' graph state = state { hakyllModified = modified' - , hakyllObsolete = obsolete + , hakyllGraph = graph } runCompilers :: [(Identifier, Compiler () CompileRule)] -- cgit v1.2.3 From 6e7dc0e58fd2d7814934e0c041a4e18232102087 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 14 Jan 2011 08:50:34 +0100 Subject: Micro-cleanup --- src/Hakyll/Core/CompiledItem.hs | 7 ++++--- src/Hakyll/Core/Compiler/Internal.hs | 3 +-- src/Hakyll/Core/DirectedGraph.hs | 4 ++-- src/Hakyll/Core/DirectedGraph/DependencySolver.hs | 6 +++--- src/Hakyll/Core/DirectedGraph/Internal.hs | 4 ++-- src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs | 2 +- src/Hakyll/Core/Route.hs | 4 ++-- src/Hakyll/Core/Rules.hs | 2 +- src/Hakyll/Core/Run.hs | 5 ++--- src/Hakyll/Web/Pandoc.hs | 2 +- 10 files changed, 19 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs index a803971..fe6730b 100644 --- a/src/Hakyll/Core/CompiledItem.hs +++ b/src/Hakyll/Core/CompiledItem.hs @@ -11,6 +11,7 @@ module Hakyll.Core.CompiledItem import Data.Binary (Binary) import Data.Typeable (Typeable, cast) +import Data.Maybe (fromMaybe) import Hakyll.Core.Writable @@ -34,6 +35,6 @@ compiledItem = CompiledItem unCompiledItem :: (Binary a, Typeable a, Writable a) => CompiledItem -> a -unCompiledItem (CompiledItem x) = case cast x of - Just x' -> x' - Nothing -> error "Hakyll.Core.CompiledItem.unCompiledItem: Unsupported type" +unCompiledItem (CompiledItem x) = fromMaybe error' $ cast x + where + error' = error "Hakyll.Core.CompiledItem.unCompiledItem: Unsupported type" diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 938d81a..5ae2f5b 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -92,8 +92,7 @@ runCompilerJob compiler identifier provider route store modified = runCompilerDependencies :: Compiler () a -> ResourceProvider -> Dependencies -runCompilerDependencies compiler provider = - runReader (compilerDependencies compiler) provider +runCompilerDependencies compiler = runReader (compilerDependencies compiler) fromJob :: (a -> CompilerM b) -> Compiler a b diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs index 66905f7..a81868e 100644 --- a/src/Hakyll/Core/DirectedGraph.hs +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -65,12 +65,12 @@ reachableNodes set graph = reachable (setNeighbours set) set sanitize' = S.filter (`S.notMember` visited) neighbours' = setNeighbours (sanitize' next) - setNeighbours = S.unions . map (flip neighbours graph) . S.toList + setNeighbours = S.unions . map (`neighbours` graph) . S.toList -- | Remove all dangling pointers, i.e. references to notes that do -- not actually exist in the graph. -- sanitize :: Ord a => DirectedGraph a -> DirectedGraph a -sanitize (DirectedGraph graph) = DirectedGraph $ M.map sanitize' $ graph +sanitize (DirectedGraph graph) = DirectedGraph $ M.map sanitize' graph where sanitize' (Node t n) = Node t $ S.filter (`M.member` graph) n diff --git a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs index 214211b..54826ff 100644 --- a/src/Hakyll/Core/DirectedGraph/DependencySolver.hs +++ b/src/Hakyll/Core/DirectedGraph/DependencySolver.hs @@ -10,7 +10,7 @@ module Hakyll.Core.DirectedGraph.DependencySolver import Prelude import qualified Prelude as P import Data.Set (Set) -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -48,7 +48,7 @@ order temp stack set graph@(DirectedGraph graph') -- Check which dependencies are still in the graph let tag = nodeTag node deps = S.toList $ nodeNeighbours node - unsatisfied = catMaybes $ map (flip M.lookup graph') deps + unsatisfied = mapMaybe (`M.lookup` graph') deps in case unsatisfied of -- All dependencies for node are satisfied, we can return it and @@ -58,7 +58,7 @@ order temp stack set graph@(DirectedGraph graph') -- There is at least one dependency left. We need to solve that -- one first... - (dep : _) -> if (nodeTag dep) `S.member` set + (dep : _) -> if nodeTag dep `S.member` set -- The dependency is already in our stack - cycle detected! then cycleError -- Continue with the dependency diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs index bc9cd92..5b02ad6 100644 --- a/src/Hakyll/Core/DirectedGraph/Internal.hs +++ b/src/Hakyll/Core/DirectedGraph/Internal.hs @@ -16,8 +16,8 @@ import qualified Data.Set as S -- | A node in the directed graph -- data Node a = Node - { nodeTag :: a -- ^ Tag identifying the node - , nodeNeighbours :: (Set a) -- ^ Edges starting at this node + { nodeTag :: a -- ^ Tag identifying the node + , nodeNeighbours :: Set a -- ^ Edges starting at this node } deriving (Show) -- | Append two nodes. Useful for joining graphs. diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs index 72d38be..a2376c2 100644 --- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -17,7 +17,7 @@ import Hakyll.Core.Util.File fileResourceProvider :: IO ResourceProvider fileResourceProvider = do list <- map parseIdentifier <$> getRecursiveContents "." - return $ ResourceProvider + return ResourceProvider { resourceList = list , resourceString = readFile . toFilePath , resourceLazyByteString = LB.readFile . toFilePath diff --git a/src/Hakyll/Core/Route.hs b/src/Hakyll/Core/Route.hs index 195768c..f3f0b7f 100644 --- a/src/Hakyll/Core/Route.hs +++ b/src/Hakyll/Core/Route.hs @@ -59,8 +59,8 @@ idRoute = Route $ Just . toFilePath -- > Just "posts/the-art-of-trolling.html" -- setExtension :: String -> Route -setExtension exension = Route $ fmap (flip replaceExtension exension) - . unRoute idRoute +setExtension extension = Route $ fmap (`replaceExtension` extension) + . unRoute idRoute -- | Modify a route: apply the route if the identifier matches the given -- pattern, fail otherwise. diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index ae476b7..dd0d9a6 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -116,7 +116,7 @@ addCompilers :: (Binary a, Typeable a, Writable a) -- ^ Compiler generating the other compilers -> Rules -- ^ Resulting rules -addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty $ +addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty [(identifier, compiler >>> arr makeRule )] where makeRule = MetaCompileRule . map (second box) diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 77b3fab..c81a5ff 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -16,7 +16,6 @@ import Data.Monoid (mempty, mappend) import Data.Typeable (Typeable) import Data.Binary (Binary) import System.FilePath (()) -import Control.Applicative ((<$>)) import Data.Set (Set) import qualified Data.Set as S @@ -115,7 +114,7 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do -- Find the old graph and append the new graph to it. This forms the -- complete graph - completeGraph <- (mappend currentGraph) . hakyllGraph <$> get + completeGraph <- mappend currentGraph . hakyllGraph <$> get liftIO $ writeDot "dependencies.dot" show completeGraph @@ -190,6 +189,6 @@ runCompilers ((id', compiler) : compilers) = Hakyll $ do unHakyll $ runCompilers compilers -- Metacompiler, slightly more complicated - MetaCompileRule newCompilers -> do + MetaCompileRule newCompilers -> -- Actually I was just kidding, it's not hard at all unHakyll $ addNewCompilers compilers newCompilers diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 2656212..acd5f56 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -89,7 +89,7 @@ pageRenderPandocWith :: P.ParserState -> P.WriterOptions -> Compiler (Page String) (Page String) pageRenderPandocWith state options = - pageReadPandocWith state >>^ (fmap $ writePandocWith options) + pageReadPandocWith state >>^ fmap (writePandocWith options) -- | The default reader options for pandoc parsing in hakyll -- -- cgit v1.2.3 From b867e6f2042b64ba6ca2a3471bb12923f7d37456 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 10:02:46 +0100 Subject: Fix skipping certain compilers error --- src/Hakyll/Core/DirectedGraph.hs | 9 +++++++++ src/Hakyll/Core/Run.hs | 7 ++----- 2 files changed, 11 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs index a81868e..76a030b 100644 --- a/src/Hakyll/Core/DirectedGraph.hs +++ b/src/Hakyll/Core/DirectedGraph.hs @@ -4,6 +4,7 @@ module Hakyll.Core.DirectedGraph ( DirectedGraph , fromList + , member , nodes , neighbours , reverse @@ -27,6 +28,14 @@ fromList :: Ord a -> DirectedGraph a -- ^ Resulting directed graph fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d)) +-- | Check if a node lies in the given graph +-- +member :: Ord a + => a -- ^ Node to check for + -> DirectedGraph a -- ^ Directed graph to check in + -> Bool -- ^ If the node lies in the graph +member n = M.member n . unDirectedGraph + -- | Get all nodes in the graph -- nodes :: Ord a diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index c81a5ff..7e428ae 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -95,10 +95,7 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask - let -- Create a set of new compilers - newCompilerIdentifiers = S.fromList $ map fst newCompilers - - -- All compilers + let -- All compilers compilers = oldCompilers ++ newCompilers -- Get all dependencies for the compilers @@ -128,7 +125,7 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do -- Find obsolete items. Every item that is reachable from a modified -- item is considered obsolete. From these obsolete items, we are only -- interested in ones that are in the current subgraph. - obsolete = S.filter (`S.member` newCompilerIdentifiers) + obsolete = S.filter (`member` currentGraph) $ reachableNodes modified' $ reverse completeGraph -- Solve the graph and retain only the obsolete items -- cgit v1.2.3 From d569ae515606d45b931201cc464fd49b111cb3c9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 10:03:26 +0100 Subject: Add utility mapA function --- src/Hakyll/Core/Util/Arrow.hs | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index 1896e11..d97ba22 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -4,6 +4,7 @@ module Hakyll.Core.Util.Arrow ( constA , sequenceA , unitA + , mapA ) where import Control.Arrow (Arrow, (&&&), arr, (>>^)) @@ -23,3 +24,8 @@ sequenceA = foldl reduce $ constA [] unitA :: Arrow a => a b () unitA = constA () + +mapA :: Arrow a + => (b -> c) + -> a [b] [c] +mapA = arr . map -- cgit v1.2.3 From e3f8856665befcb8d9d3677b625c8959e68153b0 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 10:04:09 +0100 Subject: Add renderTagCloud prototype --- src/Hakyll/Web/Tags.hs | 70 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 69 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index cf0d9a5..14aaab5 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -1,17 +1,52 @@ -{-# LANGUAGE DeriveDataTypeable #-} +-- | Module containing some specialized functions to deal with tags. +-- This Module follows certain conventions. My advice is to stick with them if +-- possible. +-- +-- More concrete: all functions in this module assume that the tags are +-- located in the @tags@ field, and separated by commas. An example file +-- @foo.markdown@ could look like: +-- +-- > --- +-- > author: Philip K. Dick +-- > title: Do androids dream of electric sheep? +-- > tags: future, science fiction, humanoid +-- > --- +-- > The novel is set in a post-apocalyptic near future, where the Earth and +-- > its populations have been damaged greatly by Nuclear... +-- +-- All the following functions would work with such a format. In addition to +-- tags, Hakyll also supports categories. The convention when using categories +-- is to place pages in subdirectories. +-- +-- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@ +-- Tags or categories are read using the @readTags@ and @readCategories@ +-- functions. This module only provides functions to work with tags: +-- categories are represented as tags. This is perfectly possible: categories +-- only have an additional restriction that a page can only have one category +-- (instead of multiple tags). +-- +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Hakyll.Web.Tags ( Tags (..) , readTagsWith , readTags , readCategories + , renderTagCloud ) where import Control.Applicative ((<$>)) import Data.Map (Map) import qualified Data.Map as M +import Data.List (intersperse) +import Control.Arrow (second, (&&&)) import Data.Typeable (Typeable) import Data.Binary (Binary, get, put) +import Data.Monoid (mconcat) +import Text.Blaze.Renderer.String (renderHtml) +import Text.Blaze (Html, (!), toHtml, toValue) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A import Hakyll.Web.Page import Hakyll.Web.Util.String @@ -53,3 +88,36 @@ readTags = readTagsWith $ map trim . splitAll "," . getField "tags" -- readCategories :: [Page a] -> Tags a readCategories = readTagsWith $ return . getField "category" + +-- | Render a tag cloud in HTML +-- +renderTagCloud :: (String -> String) -- ^ Function to produce an url for a tag + -> Double -- ^ Smallest font size, in percent + -> Double -- ^ Biggest font size, in percent + -> Tags a -- ^ Tags structure to render + -> String -- ^ Resulting HTML +renderTagCloud urlFunction minSize maxSize (Tags tags) = renderHtml $ + mconcat $ intersperse " " $ map (uncurry renderTag) withCount + where + -- Tags composed with their count + withCount = map (second $ fromIntegral . length) $ M.toList tags + + -- Render one tag, given it's count + renderTag :: String -> Int -> Html + renderTag tag count = + H.a ! A.style (toValue $ "font-size: " ++ size count) + ! A.href (toValue $ urlFunction tag) + $ toHtml tag + + -- Show the relative size of one 'count' in percent + size count = + let size' = floor $ minSize + relative count * (maxSize - minSize) + in show (size' :: Int) ++ "%" + + -- Find out the relative count of a tag: on a scale from 0 to 1 + relative count = (fromIntegral count - minCount) / (maxCount - minCount) + + -- The minimum and maximum count found, as doubles + (minCount, maxCount) + | null withCount = (0, 1) + | otherwise = (minimum &&& maximum) $ map (fromIntegral . snd) withCount -- cgit v1.2.3 From 78391b9be280b91319b93817d0407d0cae5f8f03 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 16:08:13 +0100 Subject: Clearer error message --- src/Hakyll/Core/Compiler.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 4c624e2..8d7b13c 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -90,7 +90,8 @@ getDependency identifier = CompilerM $ do where error' = error $ "Hakyll.Core.Compiler.getDependency: " ++ show identifier - ++ " not found in the cache, the cache might be corrupted" + ++ " not found in the cache, the cache might be corrupted or" + ++ " the item you are referring to might not exist" -- | Require another target. Using this function ensures automatic handling of -- dependencies -- cgit v1.2.3 From c5764243257c685a680f51df25d33aa1339449ba Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 16:08:37 +0100 Subject: Backport ContextManipulations → Metadata MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web/Page.hs | 31 +++-------- src/Hakyll/Web/Page/Metadata.hs | 110 ++++++++++++++++++++++++++++++++++++++++ src/Hakyll/Web/Tags.hs | 1 + 3 files changed, 119 insertions(+), 23 deletions(-) create mode 100644 src/Hakyll/Web/Page/Metadata.hs (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 00d143e..35a58ff 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -5,8 +5,6 @@ {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page ( Page (..) - , getField - , addField , toMap , pageRead , addDefaultFields @@ -16,7 +14,6 @@ import Prelude hiding (id) import Control.Category (id) import Control.Arrow ((>>^), (&&&), (>>>)) import System.FilePath (takeBaseName, takeDirectory) -import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as M @@ -24,24 +21,9 @@ import Hakyll.Core.Identifier import Hakyll.Core.Compiler import Hakyll.Web.Page.Internal import Hakyll.Web.Page.Read +import Hakyll.Web.Page.Metadata import Hakyll.Web.Util.String --- | Get a metadata field. If the field does not exist, the empty string is --- returned. --- -getField :: String -- ^ Key - -> Page a -- ^ Page - -> String -- ^ Value -getField key = fromMaybe "" . M.lookup key . pageMetadata - --- | Add a metadata field. If the field already exists, it is not overwritten. --- -addField :: String -- ^ Key - -> String -- ^ Value - -> Page a -- ^ Page to add it to - -> Page a -- ^ Resulting page -addField k v (Page m b) = Page (M.insertWith (flip const) k v m) b - -- | Convert a page to a map. The body will be placed in the @body@ key. -- toMap :: Page String -> Map String String @@ -56,20 +38,23 @@ pageRead = getResourceString >>^ readPage -- -- * @$url@ -- --- * @$root@ +-- * @$category@ -- -- * @$title@ -- +-- * @$path@ +-- addDefaultFields :: Compiler (Page a) (Page a) addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) >>> (getIdentifier &&& id >>^ uncurry addIdentifier) where -- Add root and url, based on route addRoute Nothing = id - addRoute (Just r) = addField "url" (toUrl r) + addRoute (Just r) = setField "url" (toUrl r) -- Add title and category, based on identifier - addIdentifier i = addField "title" (takeBaseName p) - . addField "category" (takeBaseName $ takeDirectory p) + addIdentifier i = setField "title" (takeBaseName p) + . setField "category" (takeBaseName $ takeDirectory p) + . setField "path" p where p = toFilePath i diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs new file mode 100644 index 0000000..28be7d5 --- /dev/null +++ b/src/Hakyll/Web/Page/Metadata.hs @@ -0,0 +1,110 @@ +-- | Provides various functions to manipulate the metadata fields of a page +-- +module Hakyll.Web.Page.Metadata + ( getField + , setField + , renderField + , changeField + , copyField + , renderDateField + , renderDateFieldWith + ) where + +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Time.Clock (UTCTime) +import Data.Time.Format (parseTime, formatTime) +import qualified Data.Map as M +import System.FilePath (takeFileName) +import System.Locale (TimeLocale, defaultTimeLocale) + +import Hakyll.Web.Page.Internal +import Hakyll.Web.Util.String + +-- | Get a metadata field. If the field does not exist, the empty string is +-- returned. +-- +getField :: String -- ^ Key + -> Page a -- ^ Page + -> String -- ^ Value +getField key = fromMaybe "" . M.lookup key . pageMetadata + +-- | Add a metadata field. If the field already exists, it is not overwritten. +-- +setField :: String -- ^ Key + -> String -- ^ Value + -> Page a -- ^ Page to add it to + -> Page a -- ^ Resulting page +setField k v (Page m b) = Page (M.insertWith (flip const) k v m) b + +-- | Do something with a metadata value, but keep the old value as well. If the +-- key given is not present in the metadata, nothing will happen. If the source +-- and destination keys are the same, the value will be changed (but you should +-- use 'changeField' for this purpose). +-- +renderField :: String -- ^ Key of which the value should be copied + -> String -- ^ Key the value should be copied to + -> (String -> String) -- ^ Function to apply on the value + -> Page a -- ^ Page on which this should be applied + -> Page a -- ^ Resulting page +renderField src dst f page = case M.lookup src (pageMetadata page) of + Nothing -> page + (Just value) -> setField dst (f value) page + +-- | Change a metadata value. +-- +-- > import Data.Char (toUpper) +-- > changeField "title" (map toUpper) +-- +-- Will put the title in UPPERCASE. +-- +changeField :: String -- ^ Key to change. + -> (String -> String) -- ^ Function to apply on the value. + -> Page a -- ^ Page to change + -> Page a -- ^ Resulting page +changeField key = renderField key key + +-- | Make a copy of a metadata field (put the value belonging to a certain key +-- under some other key as well) +-- +copyField :: String -- ^ Key to copy + -> String -- ^ Destination to copy to + -> Page a -- ^ Page on which this should be applied + -> Page a -- ^ Resulting page +copyField src dst = renderField src dst id + +-- | When the metadata has a field called @path@ in a +-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages), +-- this function can render the date. +-- +-- > renderDate "date" "%B %e, %Y" "Date unknown" +-- +-- Will render something like @January 32, 2010@. +-- +renderDateField :: String -- ^ Key in which the rendered date should be placed + -> String -- ^ Format to use on the date + -> String -- ^ Default value, in case the date cannot be parsed + -> Page a -- ^ Page on which this should be applied + -> Page a -- ^ Resulting page +renderDateField = renderDateFieldWith defaultTimeLocale + +-- | This is an extended version of 'renderDateField' that allows you to +-- specify a time locale that is used for outputting the date. For more +-- details, see 'renderDateField'. +-- +renderDateFieldWith :: TimeLocale -- ^ Output time locale + -> String -- ^ Destination key + -> String -- ^ Format to use on the date + -> String -- ^ Default value + -> Page a -- ^ Target page + -> Page a -- ^ Resulting page +renderDateFieldWith locale key format defaultValue = + renderField "path" key renderDate' + where + renderDate' filePath = fromMaybe defaultValue $ do + let dateString = intercalate "-" $ take 3 + $ splitAll "-" $ takeFileName filePath + time <- parseTime defaultTimeLocale + "%Y-%m-%d" + dateString :: Maybe UTCTime + return $ formatTime locale format time diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 14aaab5..62a99fc 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -49,6 +49,7 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import Hakyll.Web.Page +import Hakyll.Web.Page.Metadata import Hakyll.Web.Util.String import Hakyll.Core.Writable -- cgit v1.2.3 From 2f951598efa4bc879bad22c3ae94991fff41694e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 22:43:44 +0100 Subject: Allow IO operations in compilers --- src/Hakyll/Core/Compiler.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 8d7b13c..a2853a4 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -11,6 +11,7 @@ module Hakyll.Core.Compiler , require , requireAll , cached + , unsafeCompiler ) where import Prelude hiding ((.), id) @@ -142,3 +143,9 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do Nothing -> error' where error' = error "Hakyll.Core.Compiler.cached: Cache corrupt!" + +-- | Create an unsafe compiler from a function in IO +-- +unsafeCompiler :: (a -> IO b) -- ^ Function to lift + -> Compiler a b -- ^ Resulting compiler +unsafeCompiler f = fromJob $ CompilerM . liftIO . f -- cgit v1.2.3 From cea21979242b417e5c79662dc2c8a20bb25dc1f1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Jan 2011 23:21:20 +0100 Subject: Add prototype preview server --- src/Hakyll/Network/Server.hs | 56 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 src/Hakyll/Network/Server.hs (limited to 'src') diff --git a/src/Hakyll/Network/Server.hs b/src/Hakyll/Network/Server.hs new file mode 100644 index 0000000..44f2607 --- /dev/null +++ b/src/Hakyll/Network/Server.hs @@ -0,0 +1,56 @@ +-- | Implements a basic static file server for previewing options +-- +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad.Trans (liftIO) +import Control.Applicative ((<$>)) +import Codec.Binary.UTF8.String +import System.FilePath (()) +import System.Directory (doesFileExist) + +import qualified Data.ByteString as SB +import Snap.Util.FileServe +import Snap.Types +import Snap.Http.Server + +import Hakyll.Web.Util.String (replaceAll) + +-- | The first file in the list that actually exists is returned +-- +findFile :: [FilePath] -> IO (Maybe FilePath) +findFile [] = return Nothing +findFile (x : xs) = do + exists <- doesFileExist x + if exists then return (Just x) else findFile xs + +-- | Serve a given directory +-- +site :: FilePath -- ^ Directory to serve + -> (FilePath -> IO ()) -- ^ Pre-serve hook + -> Snap () +site directory preServe = do + -- Obtain the path + uri <- rqURI <$> getRequest + let filePath = replaceAll "\\?$" (const "") -- Remove trailing ? + $ replaceAll "#[^#]*$" (const "") -- Remove #section + $ replaceAll "^/" (const "") -- Remove leading / + $ decode $ SB.unpack uri + + -- Try to find the requested file + r <- liftIO $ findFile $ map (directory ) $ + [ filePath + , filePath "index.htm" + , filePath "index.html" + ] + + case r of + -- Not found, error + Nothing -> writeBS "Not found" + -- Found, serve + Just f -> do + liftIO $ preServe f + fileServeSingle f + +-- | Main method, runs snap +-- +main :: IO () +main = httpServe defaultConfig $ site "." (\f -> putStrLn $ "Serving " ++ f) -- cgit v1.2.3 From 88b823eb5ee8f97bd7320fbcdec8037f46456d72 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Jan 2011 09:06:54 +0100 Subject: Make static server configurable --- src/Hakyll/Network/Server.hs | 36 ++++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Network/Server.hs b/src/Hakyll/Network/Server.hs index 44f2607..0e25959 100644 --- a/src/Hakyll/Network/Server.hs +++ b/src/Hakyll/Network/Server.hs @@ -1,6 +1,10 @@ -- | Implements a basic static file server for previewing options -- {-# LANGUAGE OverloadedStrings #-} +module Hakyll.Network.Server + ( staticServer + ) where + import Control.Monad.Trans (liftIO) import Control.Applicative ((<$>)) import Codec.Binary.UTF8.String @@ -8,9 +12,11 @@ import System.FilePath (()) import System.Directory (doesFileExist) import qualified Data.ByteString as SB -import Snap.Util.FileServe -import Snap.Types -import Snap.Http.Server +import Snap.Util.FileServe (fileServeSingle) +import Snap.Types (Snap, rqURI, getRequest, writeBS) +import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen + , ConfigListen (..), emptyConfig + ) import Hakyll.Web.Util.String (replaceAll) @@ -24,10 +30,10 @@ findFile (x : xs) = do -- | Serve a given directory -- -site :: FilePath -- ^ Directory to serve - -> (FilePath -> IO ()) -- ^ Pre-serve hook - -> Snap () -site directory preServe = do +static :: FilePath -- ^ Directory to serve + -> (FilePath -> IO ()) -- ^ Pre-serve hook + -> Snap () +static directory preServe = do -- Obtain the path uri <- rqURI <$> getRequest let filePath = replaceAll "\\?$" (const "") -- Remove trailing ? @@ -50,7 +56,17 @@ site directory preServe = do liftIO $ preServe f fileServeSingle f --- | Main method, runs snap +-- | Main method, runs a static server in the given directory -- -main :: IO () -main = httpServe defaultConfig $ site "." (\f -> putStrLn $ "Serving " ++ f) +staticServer :: FilePath -- ^ Directory to serve + -> (FilePath -> IO ()) -- ^ Pre-serve hook + -> Int -- ^ Port to listen on + -> IO () -- ^ Blocks forever +staticServer directory preServe port = + httpServe config $ static directory preServe + where + -- Snap server config + config = addListen (ListenHttp "0.0.0.0" port) + $ setAccessLog Nothing + $ setErrorLog Nothing + $ emptyConfig -- cgit v1.2.3 From 821dd38c138e33194105162f7ad4140c9c46fcf2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Jan 2011 10:33:13 +0100 Subject: Add some more defaults --- src/Hakyll/Web.hs | 11 +++++++++++ src/Hakyll/Web/CompressCss.hs | 2 +- 2 files changed, 12 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 536abda..4172283 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -4,6 +4,8 @@ module Hakyll.Web ( defaultPageRead , defaultTemplateRead , defaultRelativizeUrls + , defaultCopyFile + , defaultCompressCss ) where import Prelude hiding (id) @@ -11,11 +13,14 @@ import Control.Category (id) import Control.Arrow (arr, (>>>), (>>^), (&&&)) import Hakyll.Core.Compiler +import Hakyll.Core.Writable +import Hakyll.Core.Identifier import Hakyll.Web.Page import Hakyll.Web.Pandoc import Hakyll.Web.Template import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String +import Hakyll.Web.CompressCss defaultPageRead :: Compiler () (Page String) defaultPageRead = cached "Hakyll.Web.defaultPageRead" $ @@ -30,3 +35,9 @@ defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize defaultTemplateRead :: Compiler () Template defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ getResourceString >>^ readTemplate + +defaultCopyFile :: Compiler () CopyFile +defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath + +defaultCompressCss :: Compiler () String +defaultCompressCss = getResourceString >>^ compressCss diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index 6e3b6f2..e138ea2 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -1,7 +1,7 @@ -- | Module used for CSS compression. The compression is currently in a simple -- state, but would typically reduce the number of bytes by about 25%. -- -module Text.Hakyll.Internal.CompressCss +module Hakyll.Web.CompressCss ( compressCss ) where -- cgit v1.2.3 From 0bbc01f0128f0c9e0a217f1d33f876ab03d29905 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Jan 2011 13:29:42 +0100 Subject: Backports feeds --- src/Hakyll/Core/Run.hs | 1 + src/Hakyll/Web/Feed.hs | 122 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Hakyll/Web/Page.hs | 6 +++ 3 files changed, 129 insertions(+) create mode 100644 src/Hakyll/Web/Feed.hs (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 7e428ae..494cf25 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -135,6 +135,7 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do orderedCompilers = map (id &&& (compilerMap M.!)) ordered liftIO $ putStrLn "Adding compilers..." + liftIO $ putStrLn $ "Added: " ++ show (map fst orderedCompilers) modify $ updateState modified' completeGraph diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs new file mode 100644 index 0000000..25f31db --- /dev/null +++ b/src/Hakyll/Web/Feed.hs @@ -0,0 +1,122 @@ +-- | A Module that allows easy rendering of RSS feeds. +-- +-- The main rendering functions (@renderRss@, @renderAtom@) all assume that +-- you pass the list of items so that the most recent entry in the feed is the +-- first item in the list. +-- +-- Also note that the pages should have (at least) the following fields to +-- produce a correct feed: +-- +-- - @$title@: Title of the item +-- +-- - @$description@: Description to appear in the feed +-- +-- - @$url@: URL to the item - this is usually set automatically. +-- +-- In addition, the posts should be named according to the rules for +-- 'Hakyll.Page.Metadata.renderDateField'. +-- +module Hakyll.Web.Feed + ( FeedConfiguration (..) + , renderRss + , renderAtom + ) where + +import Prelude hiding (id) +import Control.Category (id) +import Control.Arrow ((>>>), arr, (&&&)) +import Control.Monad ((<=<)) +import Data.Maybe (fromMaybe, listToMaybe) + +import Hakyll.Core.Compiler +import Hakyll.Web.Page +import Hakyll.Web.Page.Metadata +import Hakyll.Web.Template + +import Paths_hakyll + +-- | This is a data structure to keep the configuration of a feed. +data FeedConfiguration = FeedConfiguration + { -- | Title of the feed. + feedTitle :: String + , -- | Description of the feed. + feedDescription :: String + , -- | Name of the feed author. + feedAuthorName :: String + , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@) + feedRoot :: String + } + +-- | This is an auxiliary function to create a listing that is, in fact, a feed. +-- The items should be sorted on date. The @$timestamp@ field should be set. +-- +createFeed :: Template -- ^ Feed template + -> Template -- ^ Item template + -> String -- ^ URL of the feed + -> FeedConfiguration -- ^ Feed configuration + -> [Page String] -- ^ Items to include + -> String -- ^ Resulting feed +createFeed feedTemplate itemTemplate url configuration items = + pageBody $ applyTemplate feedTemplate + $ setField "timestamp" timestamp + $ setField "title" (feedTitle configuration) + $ setField "description" (feedDescription configuration) + $ setField "authorName" (feedDescription configuration) + $ setField "root" (feedRoot configuration) + $ setField "url" url + $ fromBody body + where + -- Preprocess items + items' = flip map items $ applyTemplate itemTemplate + . setField "root" (feedRoot configuration) + + -- Body: concatenated items + body = concat $ map pageBody items' + + -- Take the first timestamp, which should be the most recent + timestamp = fromMaybe "Unknown" $ do + p <- listToMaybe items + return $ getField "timestamp" p + + +-- | Abstract function to render any feed. +-- +renderFeed :: FilePath -- ^ Feed template + -> FilePath -- ^ Item template + -> FeedConfiguration -- ^ Feed configuration + -> Compiler [Page String] String -- ^ Feed compiler +renderFeed feedTemplate itemTemplate configuration = + id &&& getRoute >>> renderFeed' + where + -- Arrow rendering the feed from the items and the URL + renderFeed' = unsafeCompiler $ \(items, url) -> do + feedTemplate' <- loadTemplate feedTemplate + itemTemplate' <- loadTemplate itemTemplate + let url' = fromMaybe noUrl url + return $ createFeed feedTemplate' itemTemplate' url' configuration items + + -- Auxiliary: load a template from a datafile + loadTemplate = fmap readTemplate . readFile <=< getDataFileName + + -- URL is required to have a valid field + noUrl = error "Hakyll.Web.Feed.renderFeed: no route specified" + +-- | Render an RSS feed with a number of items. +-- +renderRss :: FeedConfiguration -- ^ Feed configuration + -> Compiler [Page String] String -- ^ Feed compiler +renderRss configuration = arr (map renderDate) + >>> renderFeed "templates/rss.xml" "templates/rss-item.xml" configuration + where + renderDate = renderDateField "timestamp" "%a, %d %b %Y %H:%M:%S UT" + "No date found." + +-- | Render an Atom feed with a number of items. +-- +renderAtom :: FeedConfiguration -- ^ Feed configuration + -> Compiler [Page String] String -- ^ Feed compiler +renderAtom configuration = arr (map renderDate) + >>> renderFeed "templates/atom.xml" "templates/atom-item.xml" configuration + where + renderDate = renderDateField "timestamp" "%Y-%m-%dT%H:%M:%SZ" + "No date found." diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 35a58ff..a7c237a 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page ( Page (..) + , fromBody , toMap , pageRead , addDefaultFields @@ -24,6 +25,11 @@ import Hakyll.Web.Page.Read import Hakyll.Web.Page.Metadata import Hakyll.Web.Util.String +-- | Create a page from a body, without metadata +-- +fromBody :: a -> Page a +fromBody = Page M.empty + -- | Convert a page to a map. The body will be placed in the @body@ key. -- toMap :: Page String -> Map String String -- cgit v1.2.3 From f104f91182a0850a9432b3a8c79849034220557b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Jan 2011 23:57:58 +0100 Subject: Monoid instance for page --- src/Hakyll/Web/Page/Internal.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs index bac4c51..3192141 100644 --- a/src/Hakyll/Web/Page/Internal.hs +++ b/src/Hakyll/Web/Page/Internal.hs @@ -6,10 +6,12 @@ module Hakyll.Web.Page.Internal ) where import Control.Applicative ((<$>), (<*>)) +import Data.Monoid (Monoid, mempty, mappend) import Data.Map (Map) import Data.Binary (Binary, get, put) import Data.Typeable (Typeable) +import qualified Data.Map as M import Hakyll.Core.Writable @@ -20,6 +22,11 @@ data Page a = Page , pageBody :: a } deriving (Show, Typeable) +instance Monoid a => Monoid (Page a) where + mempty = Page M.empty mempty + mappend (Page m1 b1) (Page m2 b2) = + Page (M.union m1 m2) (mappend b1 b2) + instance Functor Page where fmap f (Page m b) = Page m (f b) -- cgit v1.2.3 From 374a9dde5a3907dd22a1723c8916b578c4f7caf3 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Jan 2011 23:58:16 +0100 Subject: Micro cleanup --- src/Hakyll/Web/Feed.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index 25f31db..17a69eb 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -58,12 +58,12 @@ createFeed :: Template -- ^ Feed template -> String -- ^ Resulting feed createFeed feedTemplate itemTemplate url configuration items = pageBody $ applyTemplate feedTemplate - $ setField "timestamp" timestamp - $ setField "title" (feedTitle configuration) + $ setField "timestamp" timestamp + $ setField "title" (feedTitle configuration) $ setField "description" (feedDescription configuration) - $ setField "authorName" (feedDescription configuration) - $ setField "root" (feedRoot configuration) - $ setField "url" url + $ setField "authorName" (feedDescription configuration) + $ setField "root" (feedRoot configuration) + $ setField "url" url $ fromBody body where -- Preprocess items -- cgit v1.2.3 From 89cd33c7230bae30de5f74afab7fe50b2a6517db Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Jan 2011 23:58:29 +0100 Subject: Add requireA/requireAllA functions --- src/Hakyll/Core/Compiler.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index a2853a4..edb3eeb 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -9,7 +9,9 @@ module Hakyll.Core.Compiler , getResourceString , fromDependency , require + , requireA , requireAll + , requireAllA , cached , unsafeCompiler ) where @@ -108,6 +110,14 @@ require identifier f = y <- getDependency identifier return $ f x y +-- | Arrow-based variant of 'require' +-- +requireA :: (Binary a, Typeable a, Writable a) + => Identifier + -> Compiler (b, a) c + -> Compiler b c +requireA identifier = (require identifier (,) >>>) + -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies -- @@ -124,6 +134,14 @@ requireAll pattern f = items <- mapM (unCompilerM . getDependency) deps return $ f x items +-- | Arrow-based variant of 'require' +-- +requireAllA :: (Binary a, Typeable a, Writable a) + => Pattern + -> Compiler (b, [a]) c + -> Compiler b c +requireAllA pattern = (requireAll pattern (,) >>>) + cached :: (Binary a, Typeable a, Writable a) => String -> Compiler () a -- cgit v1.2.3 From 69f15f55ee422a71f62d29046f82bed4e2101dd4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 19 Jan 2011 08:51:18 +0100 Subject: Fix typo in requireAllA doc (thanks beastaugh) --- src/Hakyll/Core/Compiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index edb3eeb..ab92a68 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -134,7 +134,7 @@ requireAll pattern f = items <- mapM (unCompilerM . getDependency) deps return $ f x items --- | Arrow-based variant of 'require' +-- | Arrow-based variant of 'requireAll' -- requireAllA :: (Binary a, Typeable a, Writable a) => Pattern -- cgit v1.2.3 From 9b3e52412887da7d8864fcbde3af19edabfa9bd4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 24 Jan 2011 13:30:23 +0100 Subject: Define all require functions in arrows TODO: Think of a good naming scheme --- src/Hakyll/Core/Compiler.hs | 49 +++++++++++++++++++++++++++------------------ 1 file changed, 30 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index ab92a68..a0fea37 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -8,8 +8,10 @@ module Hakyll.Core.Compiler , getRoute , getResourceString , fromDependency + , require_ , require , requireA + , requireAll_ , requireAll , requireAllA , cached @@ -17,11 +19,11 @@ module Hakyll.Core.Compiler ) where import Prelude hiding ((.), id) -import Control.Arrow ((>>>)) +import Control.Arrow ((>>>), (&&&), arr) import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) -import Control.Category (Category, (.)) +import Control.Category (Category, (.), id) import Data.Maybe (fromMaybe) import Data.Binary (Binary) @@ -85,7 +87,7 @@ getResourceString = getIdentifier >>> getResourceString' -- | Auxiliary: get a dependency -- getDependency :: (Binary a, Writable a, Typeable a) - => Identifier -> CompilerM a + => Identifier -> CompilerM a getDependency identifier = CompilerM $ do store <- compilerStore <$> ask fmap (fromMaybe error') $ liftIO $ @@ -96,6 +98,15 @@ getDependency identifier = CompilerM $ do ++ " not found in the cache, the cache might be corrupted or" ++ " the item you are referring to might not exist" + +-- | Variant of 'require' which drops the current value +-- +require_ :: (Binary a, Typeable a, Writable a) + => Identifier + -> Compiler b a +require_ identifier = + fromDependency identifier >>> fromJob (const $ getDependency identifier) + -- | Require another target. Using this function ensures automatic handling of -- dependencies -- @@ -103,12 +114,7 @@ require :: (Binary a, Typeable a, Writable a) => Identifier -> (b -> a -> c) -> Compiler b c -require identifier f = - fromDependency identifier >>> fromJob require' - where - require' x = do - y <- getDependency identifier - return $ f x y +require identifier = requireA identifier . arr . uncurry -- | Arrow-based variant of 'require' -- @@ -116,7 +122,19 @@ requireA :: (Binary a, Typeable a, Writable a) => Identifier -> Compiler (b, a) c -> Compiler b c -requireA identifier = (require identifier (,) >>>) +requireA identifier = (id &&& require_ identifier >>>) + +-- | Variant of 'requireAll' which drops the current value +-- +requireAll_ :: (Binary a, Typeable a, Writable a) + => Pattern + -> Compiler b [a] +requireAll_ pattern = fromDependencies getDeps >>> fromJob requireAll_' + where + getDeps = matches pattern . resourceList + requireAll_' = const $ CompilerM $ do + deps <- getDeps . compilerResourceProvider <$> ask + mapM (unCompilerM . getDependency) deps -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies @@ -125,14 +143,7 @@ requireAll :: (Binary a, Typeable a, Writable a) => Pattern -> (b -> [a] -> c) -> Compiler b c -requireAll pattern f = - fromDependencies getDeps >>> fromJob requireAll' - where - getDeps = matches pattern . resourceList - requireAll' x = CompilerM $ do - deps <- getDeps . compilerResourceProvider <$> ask - items <- mapM (unCompilerM . getDependency) deps - return $ f x items +requireAll pattern = requireAllA pattern . arr . uncurry -- | Arrow-based variant of 'requireAll' -- @@ -140,7 +151,7 @@ requireAllA :: (Binary a, Typeable a, Writable a) => Pattern -> Compiler (b, [a]) c -> Compiler b c -requireAllA pattern = (requireAll pattern (,) >>>) +requireAllA pattern = (id &&& requireAll_ pattern >>>) cached :: (Binary a, Typeable a, Writable a) => String -- cgit v1.2.3 From e536a5961c8ba795660c37349091c4a9427876fe Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 25 Jan 2011 11:14:22 +0100 Subject: Functor & Applicative instances for Compiler --- src/Hakyll/Core/Compiler/Internal.hs | 10 +++++++++- src/Hakyll/Core/Rules.hs | 2 ++ 2 files changed, 11 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 5ae2f5b..f1d591d 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -14,7 +14,7 @@ module Hakyll.Core.Compiler.Internal ) where import Prelude hiding ((.), id) -import Control.Applicative (Applicative, (<$>)) +import Control.Applicative (Applicative, pure, (<*>), (<$>)) import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) import Control.Monad ((<=<), liftM2) import Data.Set (Set) @@ -58,6 +58,14 @@ data Compiler a b = Compiler , compilerJob :: a -> CompilerM b } +instance Functor (Compiler a) where + fmap f (Compiler d j) = Compiler d $ fmap f . j + +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 + instance Category Compiler where id = Compiler (return S.empty) return (Compiler d1 j1) . (Compiler d2 j2) = diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index dd0d9a6..1060af9 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -109,6 +109,8 @@ route pattern route' = tellRoute $ ifMatch pattern route' -- | Add a compiler that produces other compilers over time -- +-- TODO: Rename to metaCompile? Auto-generate identifier? +-- addCompilers :: (Binary a, Typeable a, Writable a) => Identifier -- ^ Identifier for this compiler -- cgit v1.2.3 From 7ba1413ea99a8b7c683fedf94de3a3a764277b53 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 25 Jan 2011 13:50:02 +0100 Subject: Add suffix to store files This prevents file/directory clashes. Example: when we have a `tags` item, and a `tags/foo` item, there will be a clash since the store creates: - a file `store/tags`; - a file `store/tags/foo`. The second file requires the first file to be a directory. We simply solve this by adding a suffix to all store files, so it becomes: - a file `store/tags.hakyllstore`; - a file `store/tags/foo.hakyllstore`. --- src/Hakyll/Core/Store.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index ab739a1..12e33a7 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -51,7 +51,7 @@ addToMap store path value = -- makePath :: Store -> String -> Identifier -> FilePath makePath store name identifier = - storeDirectory store name toFilePath identifier + storeDirectory store name toFilePath identifier ".hakyllstore" -- | Store an item -- -- cgit v1.2.3 From 6cecbb890f829e30e533e58287867981ca04d78a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 25 Jan 2011 20:56:10 +0100 Subject: Add `fromCaptureString` function --- src/Hakyll/Core/Identifier/Pattern.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index 0590387..7c88356 100644 --- a/src/Hakyll/Core/Identifier/Pattern.hs +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -35,6 +35,7 @@ module Hakyll.Core.Identifier.Pattern , doesMatch , matches , fromCapture + , fromCaptureString , fromCaptures ) where @@ -122,9 +123,29 @@ match' (m : ms) (s : ss) = case m of -- | Create an identifier from a pattern by filling in the captures with a given -- string -- +-- Example: +-- +-- > fromCapture (parsePattern "tags/*") (parseIdentifier "foo") +-- +-- Result: +-- +-- > "tags/foo" +-- fromCapture :: Pattern -> Identifier -> Identifier fromCapture pattern = fromCaptures pattern . repeat +-- | Simplified version of 'fromCapture' which takes a 'String' instead of an +-- 'Identifier' +-- +-- > fromCaptureString (parsePattern "tags/*") "foo" +-- +-- Result: +-- +-- > "tags/foo" +-- +fromCaptureString :: Pattern -> String -> Identifier +fromCaptureString pattern = fromCapture pattern . parseIdentifier + -- | Create an identifier from a pattern by filling in the captures with the -- given list of strings -- -- cgit v1.2.3 From c691251fc73110bc370e29291533ca2ca6fea0c2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 30 Jan 2011 10:44:42 +0100 Subject: Autogenerate metacompiler indentifiers --- src/Hakyll/Core/Rules.hs | 57 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 43 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 1060af9..d772775 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -1,7 +1,7 @@ -- | This module provides a monadic DSL in which the user can specify the -- different rules used to run the compilers -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} module Hakyll.Core.Rules ( CompileRule (..) , RuleSet (..) @@ -11,13 +11,15 @@ module Hakyll.Core.Rules , compile , create , route - , addCompilers + , metaCompile + , metaCompileWith ) where import Control.Applicative (Applicative, (<$>)) import Control.Monad.Writer import Control.Monad.Reader import Control.Arrow (second, (>>>), arr, (>>^)) +import Control.Monad.State import Data.Typeable (Typeable) import Data.Binary (Binary) @@ -52,10 +54,16 @@ instance Monoid RuleSet where mappend (RuleSet r1 c1) (RuleSet r2 c2) = RuleSet (mappend r1 r2) (mappend c1 c2) +-- | Rule state +-- +data RuleState = RuleState + { rulesMetaCompilerIndex :: Int + } deriving (Show) + -- | The monad used to compose rules -- newtype RulesM a = RulesM - { unRulesM :: ReaderT ResourceProvider (Writer RuleSet) a + { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) a } deriving (Monad, Functor, Applicative) -- | Simplification of the RulesM type; usually, it will not return any @@ -66,7 +74,10 @@ type Rules = RulesM () -- | Run a Rules monad, resulting in a 'RuleSet' -- runRules :: Rules -> ResourceProvider -> RuleSet -runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider +runRules rules provider = + evalState (execWriterT $ runReaderT (unRulesM rules) provider) state + where + state = RuleState {rulesMetaCompilerIndex = 0} -- | Add a route -- @@ -109,16 +120,34 @@ route pattern route' = tellRoute $ ifMatch pattern route' -- | Add a compiler that produces other compilers over time -- --- TODO: Rename to metaCompile? Auto-generate identifier? --- -addCompilers :: (Binary a, Typeable a, Writable a) - => Identifier - -- ^ Identifier for this compiler - -> Compiler () [(Identifier, Compiler () a)] - -- ^ Compiler generating the other compilers - -> Rules - -- ^ Resulting rules -addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty +metaCompile :: (Binary a, Typeable a, Writable a) + => Compiler () [(Identifier, Compiler () a)] + -- ^ Compiler generating the other compilers + -> Rules + -- ^ Resulting rules +metaCompile compiler = RulesM $ do + -- Create an identifier from the state + state <- get + let index = rulesMetaCompilerIndex state + id' = fromCaptureString "Hakyll.Core.Rules.metaCompile/*" (show index) + + -- Update the state with a new identifier + put $ state {rulesMetaCompilerIndex = index + 1} + + -- Fallback to 'metaCompileWith' with now known identifier + unRulesM $ 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, Compiler () a)] + -- ^ Compiler generating the other compilers + -> Rules + -- ^ Resulting rules +metaCompileWith identifier compiler = RulesM $ tell $ RuleSet mempty [(identifier, compiler >>> arr makeRule )] where makeRule = MetaCompileRule . map (second box) -- cgit v1.2.3 From 97ce6cbfa0c2935ec1958dc005b2d57d8a839206 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 30 Jan 2011 15:18:38 +0100 Subject: Add setFieldA function --- src/Hakyll/Web/Page/Metadata.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs index 28be7d5..d601a97 100644 --- a/src/Hakyll/Web/Page/Metadata.hs +++ b/src/Hakyll/Web/Page/Metadata.hs @@ -3,6 +3,7 @@ module Hakyll.Web.Page.Metadata ( getField , setField + , setFieldA , renderField , changeField , copyField @@ -10,6 +11,9 @@ module Hakyll.Web.Page.Metadata , renderDateFieldWith ) where +import Prelude hiding (id) +import Control.Category (id) +import Control.Arrow (Arrow, (>>>), (***), arr) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Time.Clock (UTCTime) @@ -37,6 +41,15 @@ setField :: String -- ^ Key -> Page a -- ^ Resulting page setField k v (Page m b) = Page (M.insertWith (flip const) k v m) b +-- | Arrow-based variant of 'setField'. Because of it's type, this function is +-- very usable together with the different 'require' functions. +-- +setFieldA :: Arrow a + => String -- ^ Key + -> a x String -- ^ Value arrow + -> a (Page String, x) (Page String) -- ^ Resulting arrow +setFieldA k v = id *** v >>> arr (uncurry $ flip $ setField k) + -- | Do something with a metadata value, but keep the old value as well. If the -- key given is not present in the metadata, nothing will happen. If the source -- and destination keys are the same, the value will be changed (but you should @@ -48,8 +61,8 @@ renderField :: String -- ^ Key of which the value should be copied -> Page a -- ^ Page on which this should be applied -> Page a -- ^ Resulting page renderField src dst f page = case M.lookup src (pageMetadata page) of - Nothing -> page - (Just value) -> setField dst (f value) page + Nothing -> page + Just value -> setField dst (f value) page -- | Change a metadata value. -- -- cgit v1.2.3 From 26c95402d8048f88c15aad273cca6a2829098d2a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 3 Feb 2011 11:34:00 +0100 Subject: Add a top-level configuration type --- src/Hakyll/Core/Configuration.hs | 21 +++++++++++++ src/Hakyll/Core/Run.hs | 65 +++++++++++++++++++++------------------- src/Hakyll/Main.hs | 21 +++++++++++++ 3 files changed, 76 insertions(+), 31 deletions(-) create mode 100644 src/Hakyll/Core/Configuration.hs create mode 100644 src/Hakyll/Main.hs (limited to 'src') diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs new file mode 100644 index 0000000..3a7456f --- /dev/null +++ b/src/Hakyll/Core/Configuration.hs @@ -0,0 +1,21 @@ +-- | Exports a datastructure for the top-level hakyll configuration +-- +module Hakyll.Core.Configuration + ( HakyllConfiguration (..) + , defaultHakyllConfiguration + ) where + +data HakyllConfiguration = HakyllConfiguration + { -- | Directory in which the output written + destinationDirectory :: FilePath + , -- | Directory where hakyll's internal store is kept + storeDirectory :: FilePath + } deriving (Show) + +-- | Default configuration for a hakyll application +-- +defaultHakyllConfiguration :: HakyllConfiguration +defaultHakyllConfiguration = HakyllConfiguration + { destinationDirectory = "_site" + , storeDirectory = "_cache" + } diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 494cf25..a21ea33 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -1,20 +1,17 @@ -- | This is the module which binds it all together -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Hakyll.Core.Run where +module Hakyll.Core.Run + ( run + ) where import Prelude hiding (reverse) import Control.Applicative import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Trans import Control.Arrow ((&&&)) -import Control.Monad (foldM, forM_, forM, filterM) -import Data.Map (Map) import qualified Data.Map as M import Data.Monoid (mempty, mappend) -import Data.Typeable (Typeable) -import Data.Binary (Binary) import System.FilePath (()) import Data.Set (Set) import qualified Data.Set as S @@ -32,45 +29,49 @@ import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable import Hakyll.Core.Store -import Hakyll.Core.CompiledItem +import Hakyll.Core.Configuration -hakyll :: Rules -> IO () -hakyll rules = do - store <- makeStore "_store" +-- | Run all rules needed +-- +run :: HakyllConfiguration -> Rules -> IO () +run configuration rules = do + store <- makeStore $ storeDirectory configuration provider <- fileResourceProvider let ruleSet = runRules rules provider compilers = rulesCompilers ruleSet -- Extract the reader/state - reader = unHakyll $ addNewCompilers [] compilers + reader = unRuntime $ addNewCompilers [] compilers state' = runReaderT reader $ env ruleSet provider store evalStateT state' state where - env ruleSet provider store = HakyllEnvironment - { hakyllRoute = rulesRoute ruleSet + env ruleSet provider store = RuntimeEnvironment + { hakyllConfiguration = configuration + , hakyllRoute = rulesRoute ruleSet , hakyllResourceProvider = provider , hakyllStore = store } - state = HakyllState + state = RuntimeState { hakyllModified = S.empty , hakyllGraph = mempty } -data HakyllEnvironment = HakyllEnvironment - { hakyllRoute :: Route +data RuntimeEnvironment = RuntimeEnvironment + { hakyllConfiguration :: HakyllConfiguration + , hakyllRoute :: Route , hakyllResourceProvider :: ResourceProvider , hakyllStore :: Store } -data HakyllState = HakyllState +data RuntimeState = RuntimeState { hakyllModified :: Set Identifier , hakyllGraph :: DirectedGraph Identifier } -newtype Hakyll a = Hakyll - { unHakyll :: ReaderT HakyllEnvironment (StateT HakyllState IO) a +newtype Runtime a = Runtime + { unRuntime :: ReaderT RuntimeEnvironment (StateT RuntimeState IO) a } deriving (Functor, Applicative, Monad) -- | Return a set of modified identifiers @@ -89,8 +90,8 @@ addNewCompilers :: [(Identifier, Compiler () CompileRule)] -- ^ Remaining compilers yet to be run -> [(Identifier, Compiler () CompileRule)] -- ^ Compilers to add - -> Hakyll () -addNewCompilers oldCompilers newCompilers = Hakyll $ do + -> Runtime () +addNewCompilers oldCompilers newCompilers = Runtime $ do -- Get some information provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask @@ -140,7 +141,7 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do modify $ updateState modified' completeGraph -- Now run the ordered list of compilers - unHakyll $ runCompilers orderedCompilers + unRuntime $ runCompilers orderedCompilers where -- Add the modified information for the new compilers updateState modified' graph state = state @@ -150,10 +151,10 @@ addNewCompilers oldCompilers newCompilers = Hakyll $ do runCompilers :: [(Identifier, Compiler () CompileRule)] -- ^ Ordered list of compilers - -> Hakyll () + -> Runtime () -- ^ No result runCompilers [] = return () -runCompilers ((id', compiler) : compilers) = Hakyll $ do +runCompilers ((id', compiler) : compilers) = Runtime $ do -- Obtain information route' <- hakyllRoute <$> ask provider <- hakyllResourceProvider <$> ask @@ -175,18 +176,20 @@ runCompilers ((id', compiler) : compilers) = Hakyll $ do CompileRule compiled -> do case url of Nothing -> return () - Just r -> liftIO $ do - putStrLn $ "Routing " ++ show id' ++ " to " ++ r - let path = "_site" r - makeDirectories path - write path compiled + Just r -> do + liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ r + destination <- + destinationDirectory . hakyllConfiguration <$> ask + let path = destination r + liftIO $ makeDirectories path + liftIO $ write path compiled liftIO $ putStrLn "" -- Continue for the remaining compilers - unHakyll $ runCompilers compilers + unRuntime $ runCompilers compilers -- Metacompiler, slightly more complicated MetaCompileRule newCompilers -> -- Actually I was just kidding, it's not hard at all - unHakyll $ addNewCompilers compilers newCompilers + unRuntime $ addNewCompilers compilers newCompilers diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs new file mode 100644 index 0000000..42b49ae --- /dev/null +++ b/src/Hakyll/Main.hs @@ -0,0 +1,21 @@ +-- | Module providing the main hakyll function and command-line argument parsing +-- +module Hakyll.Main + ( hakyll + , hakyllWith + ) where + +import Hakyll.Core.Configuration +import Hakyll.Core.Run +import Hakyll.Core.Rules + +-- | This usualy is the function with which the user runs the hakyll compiler +-- +hakyll :: Rules -> IO () +hakyll = run defaultHakyllConfiguration + +-- | A variant of 'hakyll' which allows the user to specify a custom +-- configuration +-- +hakyllWith :: HakyllConfiguration -> Rules -> IO () +hakyllWith = run -- cgit v1.2.3 From 5705bb8f88529b4170ffe884c668721abe9fccea Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 3 Feb 2011 14:18:09 +0100 Subject: Add command-line args --- src/Hakyll/Main.hs | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 72 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 42b49ae..36a4010 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -5,17 +5,87 @@ module Hakyll.Main , hakyllWith ) where +import Control.Monad (when) +import System.Environment (getProgName, getArgs) +import System.Directory (doesDirectoryExist, removeDirectoryRecursive) + import Hakyll.Core.Configuration import Hakyll.Core.Run import Hakyll.Core.Rules +import Hakyll.Network.Server -- | This usualy is the function with which the user runs the hakyll compiler -- hakyll :: Rules -> IO () -hakyll = run defaultHakyllConfiguration +hakyll = hakyllWith defaultHakyllConfiguration -- | A variant of 'hakyll' which allows the user to specify a custom -- configuration -- hakyllWith :: HakyllConfiguration -> Rules -> IO () -hakyllWith = run +hakyllWith configuration rules = do + args <- getArgs + case args of + ["build"] -> build configuration rules + ["clean"] -> clean configuration + ["help"] -> help + ["preview"] -> putStrLn "Not implemented" + ["preview", p] -> putStrLn "Not implemented" + ["rebuild"] -> rebuild configuration rules + ["server"] -> server configuration 8000 + ["server", p] -> server configuration (read p) + _ -> help + +-- | Build the site +-- +build :: HakyllConfiguration -> Rules -> IO () +build = run + +-- | Remove the output directories +-- +clean :: HakyllConfiguration -> IO () +clean configuration = do + remove $ destinationDirectory configuration + remove $ storeDirectory configuration + where + remove dir = do + putStrLn $ "Removing " ++ dir ++ "..." + exists <- doesDirectoryExist dir + when exists $ removeDirectoryRecursive dir + +-- | Show usage information. +-- +help :: IO () +help = do + name <- getProgName + mapM_ putStrLn + [ "ABOUT" + , "" + , "This is a Hakyll site generator program. You should always" + , "run it from the project root directory." + , "" + , "USAGE" + , "" + , name ++ " build Generate the site" + , name ++ " clean Clean up and remove cache" + , name ++ " help Show this message" + , name ++ " preview [port] Run a server and autocompile" + , name ++ " rebuild Clean up and build again" + , name ++ " server [port] Run a local test server" + ] + +-- | Rebuild the site +-- +rebuild :: HakyllConfiguration -> Rules -> IO () +rebuild configuration rules = do + clean configuration + build configuration rules + +-- | Start a server +-- +server :: HakyllConfiguration -> Int -> IO () +server configuration port = do + let destination = destinationDirectory configuration + staticServer destination preServeHook port + where + preServeHook _ = return () -- cgit v1.2.3 From c093761e8941c1605b6131c411ca995588c10c2e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 3 Feb 2011 16:07:49 +0100 Subject: Route → Routes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Core/Compiler.hs | 12 ++++-- src/Hakyll/Core/Compiler/Internal.hs | 9 +++-- src/Hakyll/Core/Route.hs | 71 ------------------------------------ src/Hakyll/Core/Routes.hs | 71 ++++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Rules.hs | 8 ++-- src/Hakyll/Core/Run.hs | 25 ++++++------- 6 files changed, 99 insertions(+), 97 deletions(-) delete mode 100644 src/Hakyll/Core/Route.hs create mode 100644 src/Hakyll/Core/Routes.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index a0fea37..7cfc61f 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -37,6 +37,7 @@ import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal import Hakyll.Core.Store import Hakyll.Core.Rules +import Hakyll.Core.Routes -- | Run a compiler, yielding the resulting target and it's dependencies. This -- version of 'runCompilerJob' also stores the result @@ -44,13 +45,13 @@ import Hakyll.Core.Rules runCompiler :: Compiler () CompileRule -- ^ Compiler to run -> Identifier -- ^ Target identifier -> ResourceProvider -- ^ Resource provider - -> Maybe FilePath -- ^ Route + -> Routes -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> IO CompileRule -- ^ Resulting item -runCompiler compiler identifier provider route' store modified = do +runCompiler compiler identifier provider routes store modified = do -- Run the compiler job - result <- runCompilerJob compiler identifier provider route' store modified + result <- runCompilerJob compiler identifier provider routes store modified -- Inspect the result case result of @@ -73,7 +74,10 @@ getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask -- | Get the route we are using for this item -- getRoute :: Compiler a (Maybe FilePath) -getRoute = fromJob $ const $ CompilerM $ compilerRoute <$> ask +getRoute = fromJob $ const $ CompilerM $ do + identifier <- compilerIdentifier <$> ask + routes <- compilerRoutes <$> ask + return $ runRoutes routes identifier -- | Get the resource we are compiling as a string -- diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index f1d591d..ccdd557 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -25,6 +25,7 @@ import Control.Arrow (Arrow, arr, first) import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Core.Store +import Hakyll.Core.Routes -- | A set of dependencies -- @@ -37,8 +38,8 @@ data CompilerEnvironment = CompilerEnvironment compilerIdentifier :: Identifier , -- | Resource provider compilerResourceProvider :: ResourceProvider - , -- | Site route - compilerRoute :: Maybe FilePath + , -- | Site routes + compilerRoutes :: Routes , -- | Compiler store compilerStore :: Store , -- | Flag indicating if the underlying resource was modified @@ -82,7 +83,7 @@ instance Arrow Compiler where runCompilerJob :: Compiler () a -- ^ Compiler to run -> Identifier -- ^ Target identifier -> ResourceProvider -- ^ Resource provider - -> Maybe FilePath -- ^ Route + -> Routes -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> IO a @@ -92,7 +93,7 @@ runCompilerJob compiler identifier provider route store modified = env = CompilerEnvironment { compilerIdentifier = identifier , compilerResourceProvider = provider - , compilerRoute = route + , compilerRoutes = route , compilerStore = store , compilerResourceModified = modified } diff --git a/src/Hakyll/Core/Route.hs b/src/Hakyll/Core/Route.hs deleted file mode 100644 index f3f0b7f..0000000 --- a/src/Hakyll/Core/Route.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | Once a target is compiled, the user usually wants to save it to the disk. --- This is where the 'Route' type comes in; it determines where a certain target --- should be written. --- --- When a route is applied (using 'runRoute'), it either returns a 'Just' --- 'FilePath' (meaning the target should be written to that file path), or --- 'Nothing' (meaning this target should not be written anywhere). --- -module Hakyll.Core.Route - ( Route - , runRoute - , idRoute - , setExtension - , ifMatch - ) where - -import Data.Monoid (Monoid, mempty, mappend) -import Control.Monad (mplus) -import System.FilePath (replaceExtension) - -import Hakyll.Core.Identifier -import Hakyll.Core.Identifier.Pattern - --- | Type used for a route --- -newtype Route = Route {unRoute :: Identifier -> Maybe FilePath} - -instance Monoid Route where - mempty = Route $ const Nothing - mappend (Route f) (Route g) = Route $ \id' -> f id' `mplus` g id' - --- | Apply a route to an identifier --- -runRoute :: Route -> Identifier -> Maybe FilePath -runRoute = unRoute - --- | 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 :: Route -idRoute = Route $ Just . toFilePath - --- | Set (or replace) the extension of a route. --- --- Example: --- --- > runRoute (setExtension "html") "foo/bar" --- --- Result: --- --- > Just "foo/bar.html" --- --- Example: --- --- > runRoute (setExtension "html") "posts/the-art-of-trolling.markdown" --- --- Result: --- --- > Just "posts/the-art-of-trolling.html" --- -setExtension :: String -> Route -setExtension extension = Route $ fmap (`replaceExtension` extension) - . unRoute idRoute - --- | Modify a route: apply the route if the identifier matches the given --- pattern, fail otherwise. --- -ifMatch :: Pattern -> Route -> Route -ifMatch pattern (Route route) = Route $ \id' -> - if doesMatch pattern id' then route id' - else Nothing diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs new file mode 100644 index 0000000..c1a034f --- /dev/null +++ b/src/Hakyll/Core/Routes.hs @@ -0,0 +1,71 @@ +-- | 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. +-- +-- When a route is applied (using 'runRoute'), it either returns a 'Just' +-- 'FilePath' (meaning the target should be written to that file path), or +-- 'Nothing' (meaning this target should not be written anywhere). +-- +module Hakyll.Core.Routes + ( Routes + , runRoutes + , idRoute + , setExtension + , ifMatch + ) where + +import Data.Monoid (Monoid, mempty, mappend) +import Control.Monad (mplus) +import System.FilePath (replaceExtension) + +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern + +-- | Type used for a route +-- +newtype Routes = Routes {unRoutes :: Identifier -> 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 -> 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: +-- +-- > runRoute (setExtension "html") "foo/bar" +-- +-- Result: +-- +-- > Just "foo/bar.html" +-- +-- Example: +-- +-- > runRoute (setExtension "html") "posts/the-art-of-trolling.markdown" +-- +-- Result: +-- +-- > Just "posts/the-art-of-trolling.html" +-- +setExtension :: String -> Routes +setExtension extension = Routes $ fmap (`replaceExtension` extension) + . unRoutes idRoute + +-- | Modify a route: apply the route if the identifier matches the given +-- pattern, fail otherwise. +-- +ifMatch :: Pattern -> Routes -> Routes +ifMatch pattern (Routes route) = Routes $ \id' -> + if doesMatch pattern id' then route id' + else Nothing diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index d772775..4aa497c 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -28,7 +28,7 @@ import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Compiler.Internal -import Hakyll.Core.Route +import Hakyll.Core.Routes import Hakyll.Core.CompiledItem import Hakyll.Core.Writable @@ -45,7 +45,7 @@ data CompileRule = CompileRule CompiledItem -- | A collection of rules for the compilation process -- data RuleSet = RuleSet - { rulesRoute :: Route + { rulesRoutes :: Routes , rulesCompilers :: [(Identifier, Compiler () CompileRule)] } @@ -81,7 +81,7 @@ runRules rules provider = -- | Add a route -- -tellRoute :: Route -> Rules +tellRoute :: Routes -> Rules tellRoute route' = RulesM $ tell $ RuleSet route' mempty -- | Add a number of compilers @@ -115,7 +115,7 @@ create identifier compiler = tellCompilers [(identifier, compiler)] -- | Add a route -- -route :: Pattern -> Route -> Rules +route :: Pattern -> Routes -> Rules route pattern route' = tellRoute $ ifMatch pattern route' -- | Add a compiler that produces other compilers over time diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index a21ea33..17a5f79 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -16,7 +16,7 @@ import System.FilePath (()) import Data.Set (Set) import qualified Data.Set as S -import Hakyll.Core.Route +import Hakyll.Core.Routes import Hakyll.Core.Identifier import Hakyll.Core.Util.File import Hakyll.Core.Compiler @@ -48,7 +48,7 @@ run configuration rules = do where env ruleSet provider store = RuntimeEnvironment { hakyllConfiguration = configuration - , hakyllRoute = rulesRoute ruleSet + , hakyllRoutes = rulesRoutes ruleSet , hakyllResourceProvider = provider , hakyllStore = store } @@ -60,7 +60,7 @@ run configuration rules = do data RuntimeEnvironment = RuntimeEnvironment { hakyllConfiguration :: HakyllConfiguration - , hakyllRoute :: Route + , hakyllRoutes :: Routes , hakyllResourceProvider :: ResourceProvider , hakyllStore :: Store } @@ -156,31 +156,28 @@ runCompilers :: [(Identifier, Compiler () CompileRule)] runCompilers [] = return () runCompilers ((id', compiler) : compilers) = Runtime $ do -- Obtain information - route' <- hakyllRoute <$> ask + routes <- hakyllRoutes <$> ask provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask modified' <- hakyllModified <$> get - let -- Determine the URL - url = runRoute route' id' - - -- Check if the resource was modified + let -- Check if the resource was modified isModified = id' `S.member` modified' -- Run the compiler - result <- liftIO $ runCompiler compiler id' provider url store isModified + result <- liftIO $ runCompiler compiler id' provider routes store isModified liftIO $ putStrLn $ "Generated target: " ++ show id' case result of -- Compile rule for one item, easy stuff CompileRule compiled -> do - case url of - Nothing -> return () - Just r -> do - liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ r + case runRoutes routes id' of + Nothing -> return () + Just url -> do + liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ url destination <- destinationDirectory . hakyllConfiguration <$> ask - let path = destination r + let path = destination url liftIO $ makeDirectories path liftIO $ write path compiled -- cgit v1.2.3 From ec9c1ec0db7a7dfc4650b9d1d68069b3bb32bdc4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 5 Feb 2011 13:38:20 +0100 Subject: Instantiate ArrowChoice for Compiler --- src/Hakyll/Core/Compiler/Internal.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index ccdd557..6737b6a 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -20,7 +20,7 @@ import Control.Monad ((<=<), liftM2) import Data.Set (Set) import qualified Data.Set as S import Control.Category (Category, (.), id) -import Control.Arrow (Arrow, arr, first) +import Control.Arrow (Arrow, ArrowChoice, arr, first, left) import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider @@ -78,6 +78,11 @@ instance Arrow Compiler where x' <- j x return (x', y) +instance ArrowChoice Compiler where + left (Compiler d j) = Compiler d $ \e -> case e of + Left l -> Left <$> j l + Right r -> Right <$> return r + -- | Run a compiler, yielding the resulting target and it's dependencies -- runCompilerJob :: Compiler () a -- ^ Compiler to run -- cgit v1.2.3 From bd261e91511ab7cfdc60310a9150496d75465e91 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 6 Feb 2011 18:32:09 +0100 Subject: Add getRouteFor --- src/Hakyll/Core/Compiler.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 7cfc61f..53daa75 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -6,6 +6,7 @@ module Hakyll.Core.Compiler , runCompiler , getIdentifier , getRoute + , getRouteFor , getResourceString , fromDependency , require_ @@ -74,8 +75,12 @@ getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask -- | Get the route we are using for this item -- getRoute :: Compiler a (Maybe FilePath) -getRoute = fromJob $ const $ CompilerM $ do - identifier <- compilerIdentifier <$> ask +getRoute = getIdentifier >>> getRouteFor + +-- | Get the route for a specified item +-- +getRouteFor :: Compiler Identifier (Maybe FilePath) +getRouteFor = fromJob $ \identifier -> CompilerM $ do routes <- compilerRoutes <$> ask return $ runRoutes routes identifier -- cgit v1.2.3 From 781138a0e79a942b9835b159293f2b4088e98ac1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 6 Feb 2011 22:27:11 +0100 Subject: Backport sargon's fix (6d8154) --- src/Hakyll/Web/Tags.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 62a99fc..9c3d114 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -116,7 +116,7 @@ renderTagCloud urlFunction minSize maxSize (Tags tags) = renderHtml $ in show (size' :: Int) ++ "%" -- Find out the relative count of a tag: on a scale from 0 to 1 - relative count = (fromIntegral count - minCount) / (maxCount - minCount) + relative count = (fromIntegral count - minCount) / (1 + maxCount - minCount) -- The minimum and maximum count found, as doubles (minCount, maxCount) -- cgit v1.2.3 From 986a74b3af664b824a5c67524d2433d7e990f502 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 7 Feb 2011 11:41:09 +0100 Subject: Add mapA --- src/Hakyll/Core/Util/Arrow.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index d97ba22..49cbf2b 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -7,7 +7,9 @@ module Hakyll.Core.Util.Arrow , mapA ) where -import Control.Arrow (Arrow, (&&&), arr, (>>^)) +import Control.Arrow ( Arrow, ArrowChoice, (&&&), arr, (>>^), (|||) + , (>>>), (***) + ) constA :: Arrow a => c @@ -25,7 +27,10 @@ unitA :: Arrow a => a b () unitA = constA () -mapA :: Arrow a - => (b -> c) +mapA :: ArrowChoice a + => a b c -> a [b] [c] -mapA = arr . map +mapA f = arr listEither >>> arr id ||| (f *** mapA f >>> arr (uncurry (:))) + where + listEither [] = Left [] + listEither (x : xs) = Right (x, xs) -- cgit v1.2.3 From f56eb538b6e366202f796c84eee46e620f519ff6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 7 Feb 2011 16:01:09 +0100 Subject: Lazy pattern matching for compiler composition --- src/Hakyll/Core/Compiler/Internal.hs | 2 +- src/Hakyll/Core/Util/Arrow.hs | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 6737b6a..be78412 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -69,7 +69,7 @@ instance Applicative (Compiler a) where instance Category Compiler where id = Compiler (return S.empty) return - (Compiler d1 j1) . (Compiler d2 j2) = + ~(Compiler d1 j1) . ~(Compiler d2 j2) = Compiler (liftM2 S.union d1 d2) (j1 <=< j2) instance Arrow Compiler where diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index 49cbf2b..dfcb7da 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -7,6 +7,8 @@ module Hakyll.Core.Util.Arrow , mapA ) where +import Prelude hiding (id) +import Control.Category (id) import Control.Arrow ( Arrow, ArrowChoice, (&&&), arr, (>>^), (|||) , (>>>), (***) ) @@ -30,7 +32,7 @@ unitA = constA () mapA :: ArrowChoice a => a b c -> a [b] [c] -mapA f = arr listEither >>> arr id ||| (f *** mapA f >>> arr (uncurry (:))) +mapA f = arr listEither >>> id ||| (f *** mapA f >>> arr (uncurry (:))) where listEither [] = Left [] listEither (x : xs) = Right (x, xs) -- cgit v1.2.3 From ee320c61668b532cafce7f4fd0a80ba43b3b512a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 9 Feb 2011 13:02:28 +0100 Subject: Finish tags module --- src/Hakyll/Core/Compiler.hs | 7 ++ src/Hakyll/Core/Compiler/Internal.hs | 8 +-- src/Hakyll/Core/Util/Arrow.hs | 15 +--- src/Hakyll/Web/Page/Metadata.hs | 6 +- src/Hakyll/Web/Tags.hs | 131 +++++++++++++++++++++++++---------- 5 files changed, 108 insertions(+), 59 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 53daa75..5249478 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -17,6 +17,7 @@ module Hakyll.Core.Compiler , requireAllA , cached , unsafeCompiler + , mapCompiler ) where import Prelude hiding ((.), id) @@ -187,3 +188,9 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do unsafeCompiler :: (a -> IO b) -- ^ Function to lift -> Compiler a b -- ^ Resulting compiler unsafeCompiler f = fromJob $ CompilerM . liftIO . f + +-- | Map over a compiler +-- +mapCompiler :: Compiler a b + -> Compiler [a] [b] +mapCompiler (Compiler d j) = Compiler d $ mapM j diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index be78412..a524a66 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -60,11 +60,11 @@ data Compiler a b = Compiler } 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 instance Applicative (Compiler a) where pure = Compiler (return S.empty) . const . return - (Compiler d1 f) <*> (Compiler d2 j) = + ~(Compiler d1 f) <*> ~(Compiler d2 j) = Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x instance Category Compiler where @@ -74,12 +74,12 @@ instance Category Compiler where instance Arrow Compiler where arr f = Compiler (return S.empty) (return . f) - first (Compiler d j) = Compiler d $ \(x, y) -> do + first ~(Compiler d j) = Compiler d $ \(x, y) -> do x' <- j x return (x', y) 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 diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs index dfcb7da..1896e11 100644 --- a/src/Hakyll/Core/Util/Arrow.hs +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -4,14 +4,9 @@ module Hakyll.Core.Util.Arrow ( constA , sequenceA , unitA - , mapA ) where -import Prelude hiding (id) -import Control.Category (id) -import Control.Arrow ( Arrow, ArrowChoice, (&&&), arr, (>>^), (|||) - , (>>>), (***) - ) +import Control.Arrow (Arrow, (&&&), arr, (>>^)) constA :: Arrow a => c @@ -28,11 +23,3 @@ sequenceA = foldl reduce $ constA [] unitA :: Arrow a => a b () unitA = constA () - -mapA :: ArrowChoice a - => a b c - -> a [b] [c] -mapA f = arr listEither >>> id ||| (f *** mapA f >>> arr (uncurry (:))) - where - listEither [] = Left [] - listEither (x : xs) = Right (x, xs) diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs index d601a97..2880ece 100644 --- a/src/Hakyll/Web/Page/Metadata.hs +++ b/src/Hakyll/Web/Page/Metadata.hs @@ -45,9 +45,9 @@ setField k v (Page m b) = Page (M.insertWith (flip const) k v m) b -- very usable together with the different 'require' functions. -- setFieldA :: Arrow a - => String -- ^ Key - -> a x String -- ^ Value arrow - -> a (Page String, x) (Page String) -- ^ Resulting arrow + => String -- ^ Key + -> a x String -- ^ Value arrow + -> a (Page b, x) (Page b) -- ^ Resulting arrow setFieldA k v = id *** v >>> arr (uncurry $ flip $ setField k) -- | Do something with a metadata value, but keep the old value as well. If the diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 9c3d114..77dc440 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -19,32 +19,37 @@ -- is to place pages in subdirectories. -- -- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@ --- Tags or categories are read using the @readTags@ and @readCategories@ +-- Tags or categories are read using the @readTags@ and @readCategory@ -- functions. This module only provides functions to work with tags: -- categories are represented as tags. This is perfectly possible: categories -- only have an additional restriction that a page can only have one category -- (instead of multiple tags). -- -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-} module Hakyll.Web.Tags ( Tags (..) , readTagsWith , readTags - , readCategories + , readCategory , renderTagCloud + , renderTagsField + , renderCategoryField ) where +import Prelude hiding (id) +import Control.Category (id) import Control.Applicative ((<$>)) import Data.Map (Map) import qualified Data.Map as M import Data.List (intersperse) -import Control.Arrow (second, (&&&)) +import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (mconcat) import Data.Typeable (Typeable) import Data.Binary (Binary, get, put) -import Data.Monoid (mconcat) import Text.Blaze.Renderer.String (renderHtml) -import Text.Blaze (Html, (!), toHtml, toValue) +import Text.Blaze ((!), toHtml, toValue) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A @@ -52,6 +57,8 @@ import Hakyll.Web.Page import Hakyll.Web.Page.Metadata import Hakyll.Web.Util.String import Hakyll.Core.Writable +import Hakyll.Core.Identifier +import Hakyll.Core.Compiler -- | Data about tags -- @@ -66,6 +73,16 @@ instance Binary a => Binary (Tags a) where instance Writable (Tags a) where write _ _ = return () +-- | Obtain tags from a page +-- +getTags :: Page a -> [String] +getTags = map trim . splitAll "," . getField "tags" + +-- | Obtain categories from a page +-- +getCategory :: Page a -> [String] +getCategory = return . getField "category" + -- | Higher-level function to read tags -- readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page @@ -83,42 +100,80 @@ readTagsWith f pages = Tags -- | Read a tagmap using the @tags@ metadata field -- readTags :: [Page a] -> Tags a -readTags = readTagsWith $ map trim . splitAll "," . getField "tags" +readTags = readTagsWith getTags -- | Read a tagmap using the @category@ metadata field -- -readCategories :: [Page a] -> Tags a -readCategories = readTagsWith $ return . getField "category" +readCategory :: [Page a] -> Tags a +readCategory = readTagsWith getCategory -- | Render a tag cloud in HTML -- -renderTagCloud :: (String -> String) -- ^ Function to produce an url for a tag - -> Double -- ^ Smallest font size, in percent - -> Double -- ^ Biggest font size, in percent - -> Tags a -- ^ Tags structure to render - -> String -- ^ Resulting HTML -renderTagCloud urlFunction minSize maxSize (Tags tags) = renderHtml $ - mconcat $ intersperse " " $ map (uncurry renderTag) withCount +renderTagCloud :: (String -> Identifier) -- ^ Produce a link for a tag + -> Double -- ^ Smallest font size, in percent + -> Double -- ^ Biggest font size, in percent + -> Compiler (Tags a) String -- ^ Tag cloud renderer +renderTagCloud makeUrl minSize maxSize = proc (Tags tags) -> do + -- In tags' we create a list: [((tag, route), count)] + tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) + -< M.toList tags + + let -- Absolute frequencies of the pages + freqs = map snd tags' + + -- Find out the relative count of a tag: on a scale from 0 to 1 + relative count = (fromIntegral count - min') / (1 + max' - min') + + -- Show the relative size of one 'count' in percent + size count = + let size' = floor $ minSize + relative count * (maxSize - minSize) + in show (size' :: Int) ++ "%" + + -- The minimum and maximum count found, as doubles + (min', max') + | null freqs = (0, 1) + | otherwise = (minimum &&& maximum) $ map fromIntegral freqs + + -- Create a link for one item + makeLink ((tag, url), count) = + H.a ! A.style (toValue $ "font-size: " ++ size count) + ! A.href (toValue $ fromMaybe "/" url) + $ toHtml tag + + -- Render and return the HTML + returnA -< renderHtml $ mconcat $ intersperse " " $ map makeLink tags' + +-- | Render tags with links +-- +renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags + -> String -- ^ Destination key + -> (String -> Identifier) -- ^ Create a link for a tag + -> Compiler (Page a) (Page a) -- ^ Resulting compiler +renderTagsFieldWith tags destination makeUrl = + id &&& arr tags >>> setFieldA destination renderTags where - -- Tags composed with their count - withCount = map (second $ fromIntegral . length) $ M.toList tags - - -- Render one tag, given it's count - renderTag :: String -> Int -> Html - renderTag tag count = - H.a ! A.style (toValue $ "font-size: " ++ size count) - ! A.href (toValue $ urlFunction tag) - $ toHtml tag - - -- Show the relative size of one 'count' in percent - size count = - let size' = floor $ minSize + relative count * (maxSize - minSize) - in show (size' :: Int) ++ "%" - - -- Find out the relative count of a tag: on a scale from 0 to 1 - relative count = (fromIntegral count - minCount) / (1 + maxCount - minCount) - - -- The minimum and maximum count found, as doubles - (minCount, maxCount) - | null withCount = (0, 1) - | otherwise = (minimum &&& maximum) $ map (fromIntegral . snd) withCount + -- Compiler creating a comma-separated HTML string for a list of tags + renderTags :: Compiler [String] String + renderTags = arr (map $ id &&& makeUrl) + >>> mapCompiler (id *** getRouteFor) + >>> arr (map $ uncurry renderLink) + >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes) + + -- Render one tag link + renderLink _ Nothing = Nothing + renderLink tag (Just filePath) = Just $ + H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag + +-- | Render tags with links +-- +renderTagsField :: String -- ^ Destination key + -> (String -> Identifier) -- ^ Create a link for a tag + -> Compiler (Page a) (Page a) -- ^ Resulting compiler +renderTagsField = renderTagsFieldWith getTags + +-- | Render the category in a link +-- +renderCategoryField :: String -- ^ Destination key + -> (String -> Identifier) -- ^ Create a category link + -> Compiler (Page a) (Page a) -- ^ Resulting compiler +renderCategoryField = renderTagsFieldWith getCategory -- cgit v1.2.3 From 9e07d1ba364ca401cc1c6f5704023b1df1006779 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 9 Feb 2011 13:27:45 +0100 Subject: Template syntax: $foo → $foo$ MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web/Template.hs | 19 ++++++++++++------- src/Hakyll/Web/Template/Internal.hs | 6 +++--- 2 files changed, 15 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index b4f2ea5..06fa8d4 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -21,17 +21,22 @@ readTemplate = Template . readTemplate' readTemplate' [] = [] readTemplate' string | "$$" `isPrefixOf` string = - let (key, rest) = readIdentifier $ drop 2 string - in Escaped key : readTemplate' rest + Escaped : readTemplate' (drop 2 string) | "$" `isPrefixOf` string = - let (key, rest) = readIdentifier $ drop 1 string - in Identifier key : readTemplate' rest + case readIdentifier (drop 1 string) of + Just (key, rest) -> Identifier key : readTemplate' rest + Nothing -> Chunk "$" : readTemplate' (drop 1 string) | otherwise = let (chunk, rest) = break (== '$') string in Chunk chunk : readTemplate' rest - -- Parse an identifier into (identifier, rest) - readIdentifier = span isAlphaNum + -- Parse an identifier into (identifier, rest) if it's valid, and return + -- Nothing otherwise + readIdentifier string = + let (identifier, rest) = span isAlphaNum string + in if not (null identifier) && "$" `isPrefixOf` rest + then Just (identifier, drop 1 rest) + else Nothing -- | Substitutes @$identifiers@ in the given @Template@ by values from the given -- "Page". When a key is not found, it is left as it is. You can specify @@ -44,7 +49,7 @@ applyTemplate template page = substitute (Chunk chunk) = chunk substitute (Identifier key) = fromMaybe ('$' : key) $ M.lookup key $ toMap page - substitute (Escaped key) = '$' : key + substitute (Escaped) = "$" -- | Apply a page as it's own template. This is often very useful to fill in -- certain keys like @$root@ and @$url@. diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs index 096c928..d0f6472 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -29,17 +29,17 @@ instance Writable Template where data TemplateElement = Chunk String | Identifier String - | Escaped String + | Escaped deriving (Show, Eq, Typeable) instance Binary TemplateElement where put (Chunk string) = putWord8 0 >> put string put (Identifier key) = putWord8 1 >> put key - put (Escaped key) = putWord8 2 >> put key + put (Escaped) = putWord8 2 get = getWord8 >>= \tag -> case tag of 0 -> Chunk <$> get 1 -> Identifier <$> get - 2 -> Escaped <$> get + 2 -> return Escaped _ -> error $ "Hakyll.Web.Template.Internal: " ++ "Error reading cached template" -- cgit v1.2.3 From 7da7e0b96c245a14122896c24dcee52f038e583a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 9 Feb 2011 16:59:09 +0100 Subject: Add top-level module --- src/Hakyll.hs | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) create mode 100644 src/Hakyll.hs (limited to 'src') diff --git a/src/Hakyll.hs b/src/Hakyll.hs new file mode 100644 index 0000000..93c9ccc --- /dev/null +++ b/src/Hakyll.hs @@ -0,0 +1,47 @@ +-- | Top-level module exporting all modules that are interesting for the user +-- +module Hakyll + ( module Hakyll.Core.Compiler + , module Hakyll.Core.Configuration + , module Hakyll.Core.Identifier + , module Hakyll.Core.Identifier.Pattern + , module Hakyll.Core.Routes + , module Hakyll.Core.Rules + , module Hakyll.Core.Util.Arrow + , module Hakyll.Core.Util.File + , module Hakyll.Core.Writable + , module Hakyll.Web + , module Hakyll.Web.CompressCss + , module Hakyll.Web.Feed + , module Hakyll.Web.FileType + , module Hakyll.Web.Page + , module Hakyll.Web.Page.Metadata + , module Hakyll.Web.Page.Read + , module Hakyll.Web.Pandoc + , module Hakyll.Web.RelativizeUrls + , module Hakyll.Web.Tags + , module Hakyll.Web.Template + , module Hakyll.Web.Util.String + ) where + +import Hakyll.Core.Compiler +import Hakyll.Core.Configuration +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Routes +import Hakyll.Core.Rules +import Hakyll.Core.Util.Arrow +import Hakyll.Core.Util.File +import Hakyll.Core.Writable +import Hakyll.Web +import Hakyll.Web.CompressCss +import Hakyll.Web.Feed +import Hakyll.Web.FileType +import Hakyll.Web.Page +import Hakyll.Web.Page.Metadata +import Hakyll.Web.Page.Read +import Hakyll.Web.Pandoc +import Hakyll.Web.RelativizeUrls +import Hakyll.Web.Tags +import Hakyll.Web.Template +import Hakyll.Web.Util.String -- cgit v1.2.3 From 002cf4de32db979d515c2a9cdcd8c8f42859a797 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 9 Feb 2011 18:11:24 +0100 Subject: Add hamlet templates and restructure tests --- src/Hakyll/Web.hs | 12 ++++++++ src/Hakyll/Web/Page.hs | 7 +++++ src/Hakyll/Web/Template.hs | 33 ++------------------- src/Hakyll/Web/Template/Read/Hakyll.hs | 36 +++++++++++++++++++++++ src/Hakyll/Web/Template/Read/Hamlet.hs | 50 ++++++++++++++++++++++++++++++++ tests/Hakyll/Core/DirectedGraph/Tests.hs | 12 -------- tests/Hakyll/Core/Identifier/Tests.hs | 26 +++++++---------- tests/Hakyll/Core/Route/Tests.hs | 25 ---------------- tests/Hakyll/Core/Routes/Tests.hs | 19 ++++++++++++ tests/Hakyll/Web/Template/Tests.hs | 46 +++++++++++++++++++++++++++++ tests/TestSuite.hs | 9 ++++-- tests/TestSuite/Util.hs | 18 ++++++++++++ 12 files changed, 207 insertions(+), 86 deletions(-) create mode 100644 src/Hakyll/Web/Template/Read/Hakyll.hs create mode 100644 src/Hakyll/Web/Template/Read/Hamlet.hs delete mode 100644 tests/Hakyll/Core/Route/Tests.hs create mode 100644 tests/Hakyll/Core/Routes/Tests.hs create mode 100644 tests/Hakyll/Web/Template/Tests.hs create mode 100644 tests/TestSuite/Util.hs (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 4172283..f991e21 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -12,12 +12,16 @@ import Prelude hiding (id) import Control.Category (id) import Control.Arrow (arr, (>>>), (>>^), (&&&)) +import Text.Hamlet (HamletSettings, defaultHamletSettings) + import Hakyll.Core.Compiler import Hakyll.Core.Writable import Hakyll.Core.Identifier import Hakyll.Web.Page import Hakyll.Web.Pandoc import Hakyll.Web.Template +import Hakyll.Web.Template.Read.Hakyll +import Hakyll.Web.Template.Read.Hamlet import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String import Hakyll.Web.CompressCss @@ -36,6 +40,14 @@ defaultTemplateRead :: Compiler () Template defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ getResourceString >>^ readTemplate +defaultHamletTemplateRead :: Compiler () Template +defaultHamletTemplateRead = defaultHamletTemplateReadWith defaultHamletSettings + +defaultHamletTemplateReadWith :: HamletSettings -> Compiler () Template +defaultHamletTemplateReadWith settings = + cached "Hakyll.Web.defaultHamletTemplateReadWith" $ + getResourceString >>^ readHamletTemplateWith settings + defaultCopyFile :: Compiler () CopyFile defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index a7c237a..c7de026 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -6,6 +6,7 @@ module Hakyll.Web.Page ( Page (..) , fromBody + , fromMap , toMap , pageRead , addDefaultFields @@ -15,6 +16,7 @@ import Prelude hiding (id) import Control.Category (id) import Control.Arrow ((>>^), (&&&), (>>>)) import System.FilePath (takeBaseName, takeDirectory) +import Data.Monoid (Monoid, mempty) import Data.Map (Map) import qualified Data.Map as M @@ -30,6 +32,11 @@ import Hakyll.Web.Util.String fromBody :: a -> Page a fromBody = Page M.empty +-- | Create a metadata page, without a body +-- +fromMap :: Monoid a => Map String String -> Page a +fromMap m = Page m mempty + -- | Convert a page to a map. The body will be placed in the @body@ key. -- toMap :: Page String -> Map String String diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 06fa8d4..83fd7eb 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -1,46 +1,19 @@ module Hakyll.Web.Template ( Template - , readTemplate , applyTemplate , applySelf ) where -import Data.List (isPrefixOf) -import Data.Char (isAlphaNum) import Data.Maybe (fromMaybe) import qualified Data.Map as M import Hakyll.Web.Template.Internal +import Hakyll.Web.Template.Read.Hakyll (readTemplate) import Hakyll.Web.Page --- | Construct a @Template@ from a string. --- -readTemplate :: String -> Template -readTemplate = Template . readTemplate' - where - readTemplate' [] = [] - readTemplate' string - | "$$" `isPrefixOf` string = - Escaped : readTemplate' (drop 2 string) - | "$" `isPrefixOf` string = - case readIdentifier (drop 1 string) of - Just (key, rest) -> Identifier key : readTemplate' rest - Nothing -> Chunk "$" : readTemplate' (drop 1 string) - | otherwise = - let (chunk, rest) = break (== '$') string - in Chunk chunk : readTemplate' rest - - -- Parse an identifier into (identifier, rest) if it's valid, and return - -- Nothing otherwise - readIdentifier string = - let (identifier, rest) = span isAlphaNum string - in if not (null identifier) && "$" `isPrefixOf` rest - then Just (identifier, drop 1 rest) - else Nothing - -- | Substitutes @$identifiers@ in the given @Template@ by values from the given --- "Page". When a key is not found, it is left as it is. You can specify --- the characters used to replace escaped dollars (@$$@) here. +-- "Page". When a key is not found, it is left as it is. You can specify +-- the characters used to replace escaped dollars (@$$@) here. -- applyTemplate :: Template -> Page String -> Page String applyTemplate template page = diff --git a/src/Hakyll/Web/Template/Read/Hakyll.hs b/src/Hakyll/Web/Template/Read/Hakyll.hs new file mode 100644 index 0000000..fbbfee2 --- /dev/null +++ b/src/Hakyll/Web/Template/Read/Hakyll.hs @@ -0,0 +1,36 @@ +-- | Read templates in Hakyll's native format +-- +module Hakyll.Web.Template.Read.Hakyll + ( readTemplate + ) where + +import Data.List (isPrefixOf) +import Data.Char (isAlphaNum) +import Data.Maybe (fromMaybe) + +import Hakyll.Web.Template.Internal + +-- | Construct a @Template@ from a string. +-- +readTemplate :: String -> Template +readTemplate = Template . readTemplate' + where + readTemplate' [] = [] + readTemplate' string + | "$$" `isPrefixOf` string = + Escaped : readTemplate' (drop 2 string) + | "$" `isPrefixOf` string = + case readIdentifier (drop 1 string) of + Just (key, rest) -> Identifier key : readTemplate' rest + Nothing -> Chunk "$" : readTemplate' (drop 1 string) + | otherwise = + let (chunk, rest) = break (== '$') string + in Chunk chunk : readTemplate' rest + + -- Parse an identifier into (identifier, rest) if it's valid, and return + -- Nothing otherwise + readIdentifier string = + let (identifier, rest) = span isAlphaNum string + in if not (null identifier) && "$" `isPrefixOf` rest + then Just (identifier, drop 1 rest) + else Nothing diff --git a/src/Hakyll/Web/Template/Read/Hamlet.hs b/src/Hakyll/Web/Template/Read/Hamlet.hs new file mode 100644 index 0000000..1c9bbf6 --- /dev/null +++ b/src/Hakyll/Web/Template/Read/Hamlet.hs @@ -0,0 +1,50 @@ +-- | Read templates in the hamlet format +-- +{-# LANGUAGE MultiParamTypeClasses #-} +module Hakyll.Web.Template.Read.Hamlet + ( readHamletTemplate + , readHamletTemplateWith + ) where + +import Control.Monad.Trans (liftIO) +import System.FilePath (takeExtension) + +import Text.Hamlet (HamletSettings (..), defaultHamletSettings) +import Text.Hamlet.RT +import Control.Failure + +import Hakyll.Web.Template.Internal + +-- | Read a hamlet template using the default settings +-- +readHamletTemplate :: String -> Template +readHamletTemplate = readHamletTemplateWith defaultHamletSettings + +-- | Read a hamlet template using the specified settings +-- +readHamletTemplateWith :: HamletSettings -> String -> Template +readHamletTemplateWith settings string = + let result = parseHamletRT settings string + in case result of + Just hamlet -> fromHamletRT hamlet + Nothing -> error + "Hakyll.Web.Template.Read.Hamlet.readHamletTemplateWith: \ + \Could not parse Hamlet file" + +-- | Convert a 'HamletRT' to a 'Template' +-- +fromHamletRT :: HamletRT -- ^ Hamlet runtime template + -> Template -- ^ Hakyll template +fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd + where + fromSimpleDoc :: SimpleDoc -> TemplateElement + fromSimpleDoc (SDRaw chunk) = Chunk chunk + fromSimpleDoc (SDVar [var]) = Identifier var + fromSimpleDoc (SDVar _) = error + "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \ + \Hakyll does not support '.' in identifier names when using \ + \hamlet templates." + fromSimpleDoc _ = error + "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \ + \Only simple $key$ identifiers are allowed when using hamlet \ + \templates." diff --git a/tests/Hakyll/Core/DirectedGraph/Tests.hs b/tests/Hakyll/Core/DirectedGraph/Tests.hs index 1a9b406..3e04b49 100644 --- a/tests/Hakyll/Core/DirectedGraph/Tests.hs +++ b/tests/Hakyll/Core/DirectedGraph/Tests.hs @@ -11,13 +11,10 @@ import Test.HUnit hiding (Test) import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.DependencySolver -import Hakyll.Core.DirectedGraph.ObsoleteFilter tests :: [Test] tests = [ testCase "solveDependencies [1]" solveDependencies1 - , testCase "filterObsolete [1]" filterObsolete1 - , testCase "filterObsolete [2]" filterObsolete2 ] node :: Ord a => a -> [a] -> (a, Set a) @@ -37,12 +34,3 @@ solveDependencies1 = result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8] @? "solveDependencies1" where result = solveDependencies testGraph01 - -filterObsolete1 :: Assertion -filterObsolete1 = nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8] - @? "filterObsolete1" - -filterObsolete2 :: Assertion -filterObsolete2 = - nodes (filterObsolete [4] testGraph01) == S.fromList [4, 2, 6, 8] - @? "filterObsolete2" diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs index 910bca3..a7d49e9 100644 --- a/tests/Hakyll/Core/Identifier/Tests.hs +++ b/tests/Hakyll/Core/Identifier/Tests.hs @@ -8,22 +8,16 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import Hakyll.Core.Identifier.Pattern +import TestSuite.Util tests :: [Test] -tests = zipWith testCase names matchCases - where - names = map (\n -> "match [" ++ show n ++ "]") [1 :: Int ..] - --- | Collection of simple cases --- -matchCases :: [Assertion] -matchCases = - [ Just [["bar"]] @=? match "foo/**" "foo/bar" - , Just [["foo", "bar"]] @=? match "**" "foo/bar" - , Nothing @=? match "*" "foo/bar" - , Just [] @=? match "foo" "foo" - , Just [["foo"]] @=? match "*/bar" "foo/bar" - , Just [["foo", "bar"]] @=? match "**/qux" "foo/bar/qux" - , Just [["foo", "bar"], ["qux"]] @=? match "**/*" "foo/bar/qux" - , Just [["foo"], ["bar", "qux"]] @=? match "*/**" "foo/bar/qux" +tests = fromAssertions "match" + [ Just ["bar"] @=? match "foo/**" "foo/bar" + , Just ["foo/bar"] @=? match "**" "foo/bar" + , Nothing @=? match "*" "foo/bar" + , Just [] @=? match "foo" "foo" + , Just ["foo"] @=? match "*/bar" "foo/bar" + , Just ["foo/bar"] @=? match "**/qux" "foo/bar/qux" + , Just ["foo/bar", "qux"] @=? match "**/*" "foo/bar/qux" + , Just ["foo", "bar/qux"] @=? match "*/**" "foo/bar/qux" ] diff --git a/tests/Hakyll/Core/Route/Tests.hs b/tests/Hakyll/Core/Route/Tests.hs deleted file mode 100644 index 17a4123..0000000 --- a/tests/Hakyll/Core/Route/Tests.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Hakyll.Core.Route.Tests - ( tests - ) where - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -import Hakyll.Core.Route - -tests :: [Test] -tests = zipWith testCase names matchCases - where - names = map (\n -> "runRoute [" ++ show n ++ "]") [1 :: Int ..] - --- | Collection of simple cases --- -matchCases :: [Assertion] -matchCases = - [ Just "foo.html" @=? runRoute (setExtension "html") "foo" - , Just "foo.html" @=? runRoute (setExtension ".html") "foo" - , Just "foo.html" @=? runRoute (setExtension "html") "foo.markdown" - , Just "foo.html" @=? runRoute (setExtension ".html") "foo.markdown" - ] diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs new file mode 100644 index 0000000..cca2ee4 --- /dev/null +++ b/tests/Hakyll/Core/Routes/Tests.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Core.Routes.Tests + ( tests + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Hakyll.Core.Routes +import TestSuite.Util + +tests :: [Test] +tests = fromAssertions "runRoutes" + [ Just "foo.html" @=? runRoutes (setExtension "html") "foo" + , Just "foo.html" @=? runRoutes (setExtension ".html") "foo" + , Just "foo.html" @=? runRoutes (setExtension "html") "foo.markdown" + , Just "foo.html" @=? runRoutes (setExtension ".html") "foo.markdown" + ] diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs new file mode 100644 index 0000000..d95b151 --- /dev/null +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Web.Template.Tests + ( tests + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import qualified Data.Map as M + +import Hakyll.Web.Page +import Hakyll.Web.Template +import Hakyll.Web.Template.Read.Hakyll +import Hakyll.Web.Template.Read.Hamlet +import TestSuite.Util + +tests :: [Test] +tests = fromAssertions "applyTemplate" + -- Hakyll templates + [ applyTemplateAssertion readTemplate + "bar" "$foo$" [("foo", "bar")] + + , applyTemplateAssertion readTemplate + "$ barqux" "$$ $foo$$bar$" [("foo", "bar"), ("bar", "qux")] + + -- Hamlet templates + , applyTemplateAssertion readHamletTemplate + "noticeA paragraph" + "#{title}\n\ + \ Template) -- ^ Template parser + -> String -- ^ Expected + -> String -- ^ Template + -> [(String, String)] -- ^ Page + -> Assertion -- ^ Resulting assertion +applyTemplateAssertion parser expected template page = + expected @=? pageBody (applyTemplate (parser template) + (fromMap $ M.fromList page)) diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 68c4f28..aaf4481 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -4,7 +4,8 @@ import Test.Framework (defaultMain, testGroup) import qualified Hakyll.Core.DirectedGraph.Tests import qualified Hakyll.Core.Identifier.Tests -import qualified Hakyll.Core.Route.Tests +import qualified Hakyll.Core.Routes.Tests +import qualified Hakyll.Web.Template.Tests main :: IO () main = defaultMain @@ -12,6 +13,8 @@ main = defaultMain Hakyll.Core.DirectedGraph.Tests.tests , testGroup "Hakyll.Core.Identifier.Tests" Hakyll.Core.Identifier.Tests.tests - , testGroup "Hakyll.Core.Route.Tests" - Hakyll.Core.Route.Tests.tests + , testGroup "Hakyll.Core.Routes.Tests" + Hakyll.Core.Routes.Tests.tests + , testGroup "Hakyll.Web.Template.Tests" + Hakyll.Web.Template.Tests.tests ] diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs new file mode 100644 index 0000000..66f101e --- /dev/null +++ b/tests/TestSuite/Util.hs @@ -0,0 +1,18 @@ +-- | Test utilities +-- +module TestSuite.Util + ( fromAssertions + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Hakyll.Core.Identifier.Pattern + +fromAssertions :: String -- ^ Name + -> [Assertion] -- ^ Cases + -> [Test] -- ^ Result tests +fromAssertions name = zipWith testCase names + where + names = map (\n -> name ++ " [" ++ show n ++ "]") [1 :: Int ..] -- cgit v1.2.3 From d9e0c3e86b03834a03e7ddf37b70cc141eccfe1c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 9 Feb 2011 19:28:53 +0100 Subject: Some tests for the Page module --- src/Hakyll/Web/Page/Internal.hs | 2 +- tests/Hakyll/Web/Page/Tests.hs | 35 +++++++++++++++++++++++++++++++++++ tests/TestSuite.hs | 3 +++ 3 files changed, 39 insertions(+), 1 deletion(-) create mode 100644 tests/Hakyll/Web/Page/Tests.hs (limited to 'src') diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs index 3192141..dd47197 100644 --- a/src/Hakyll/Web/Page/Internal.hs +++ b/src/Hakyll/Web/Page/Internal.hs @@ -20,7 +20,7 @@ import Hakyll.Core.Writable data Page a = Page { pageMetadata :: Map String String , pageBody :: a - } deriving (Show, Typeable) + } deriving (Eq, Show, Typeable) instance Monoid a => Monoid (Page a) where mempty = Page M.empty mempty diff --git a/tests/Hakyll/Web/Page/Tests.hs b/tests/Hakyll/Web/Page/Tests.hs new file mode 100644 index 0000000..14f3d7e --- /dev/null +++ b/tests/Hakyll/Web/Page/Tests.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Web.Page.Tests + ( tests + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import qualified Data.Map as M + +import Hakyll.Web.Page +import Hakyll.Web.Page.Internal +import Hakyll.Web.Page.Read +import TestSuite.Util + +tests :: [Test] +tests = fromAssertions "applyTemplate" + -- Hakyll templates + [ Page (M.singleton "foo" "bar") "body\n" @=? readPage + "--- \n\ + \foo: bar \n\ + \--- \n\ + \body" + + , Page M.empty "line one\nlijn twee\n" @=? readPage + "line one\n\ + \lijn twee" + + , Page (M.fromList [("field1", "unos"), ("veld02", "deux")]) "" @=? readPage + "---\n\ + \veld02: deux\n\ + \field1: unos\n\ + \---" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index aaf4481..5d401d2 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -5,6 +5,7 @@ import Test.Framework (defaultMain, testGroup) import qualified Hakyll.Core.DirectedGraph.Tests import qualified Hakyll.Core.Identifier.Tests import qualified Hakyll.Core.Routes.Tests +import qualified Hakyll.Web.Page.Tests import qualified Hakyll.Web.Template.Tests main :: IO () @@ -15,6 +16,8 @@ main = defaultMain Hakyll.Core.Identifier.Tests.tests , testGroup "Hakyll.Core.Routes.Tests" Hakyll.Core.Routes.Tests.tests + , testGroup "Hakyll.Web.Page.Tests" + Hakyll.Web.Page.Tests.tests , testGroup "Hakyll.Web.Template.Tests" Hakyll.Web.Template.Tests.tests ] -- cgit v1.2.3 From 3532d5f1001c9942f815a1d9411f51a2051a1f96 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 12:30:58 +0100 Subject: Top-level module for reading templates --- src/Hakyll.hs | 2 ++ src/Hakyll/Web.hs | 3 +-- src/Hakyll/Web/Feed.hs | 1 + src/Hakyll/Web/Template.hs | 2 +- src/Hakyll/Web/Template/Read.hs | 10 ++++++++++ src/Hakyll/Web/Template/Read/Hakyll.hs | 1 - src/Hakyll/Web/Template/Read/Hamlet.hs | 4 ---- tests/Hakyll/Web/Template/Tests.hs | 3 +-- 8 files changed, 16 insertions(+), 10 deletions(-) create mode 100644 src/Hakyll/Web/Template/Read.hs (limited to 'src') diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 93c9ccc..64d5330 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -10,6 +10,7 @@ module Hakyll , module Hakyll.Core.Util.Arrow , module Hakyll.Core.Util.File , module Hakyll.Core.Writable + , module Hakyll.Main , module Hakyll.Web , module Hakyll.Web.CompressCss , module Hakyll.Web.Feed @@ -33,6 +34,7 @@ import Hakyll.Core.Rules import Hakyll.Core.Util.Arrow import Hakyll.Core.Util.File import Hakyll.Core.Writable +import Hakyll.Main import Hakyll.Web import Hakyll.Web.CompressCss import Hakyll.Web.Feed diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index f991e21..92cdab5 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -20,8 +20,7 @@ import Hakyll.Core.Identifier import Hakyll.Web.Page import Hakyll.Web.Pandoc import Hakyll.Web.Template -import Hakyll.Web.Template.Read.Hakyll -import Hakyll.Web.Template.Read.Hamlet +import Hakyll.Web.Template.Read import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String import Hakyll.Web.CompressCss diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index 17a69eb..417f484 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -32,6 +32,7 @@ import Hakyll.Core.Compiler import Hakyll.Web.Page import Hakyll.Web.Page.Metadata import Hakyll.Web.Template +import Hakyll.Web.Template.Read.Hakyll (readTemplate) import Paths_hakyll diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 83fd7eb..06794e8 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -8,7 +8,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Map as M import Hakyll.Web.Template.Internal -import Hakyll.Web.Template.Read.Hakyll (readTemplate) +import Hakyll.Web.Template.Read import Hakyll.Web.Page -- | Substitutes @$identifiers@ in the given @Template@ by values from the given diff --git a/src/Hakyll/Web/Template/Read.hs b/src/Hakyll/Web/Template/Read.hs new file mode 100644 index 0000000..421b7e9 --- /dev/null +++ b/src/Hakyll/Web/Template/Read.hs @@ -0,0 +1,10 @@ +-- | Re-exports all different template reading modules +-- +module Hakyll.Web.Template.Read + ( readTemplate + , readHamletTemplate + , readHamletTemplateWith + ) where + +import Hakyll.Web.Template.Read.Hakyll +import Hakyll.Web.Template.Read.Hamlet diff --git a/src/Hakyll/Web/Template/Read/Hakyll.hs b/src/Hakyll/Web/Template/Read/Hakyll.hs index fbbfee2..e0e10f4 100644 --- a/src/Hakyll/Web/Template/Read/Hakyll.hs +++ b/src/Hakyll/Web/Template/Read/Hakyll.hs @@ -6,7 +6,6 @@ module Hakyll.Web.Template.Read.Hakyll import Data.List (isPrefixOf) import Data.Char (isAlphaNum) -import Data.Maybe (fromMaybe) import Hakyll.Web.Template.Internal diff --git a/src/Hakyll/Web/Template/Read/Hamlet.hs b/src/Hakyll/Web/Template/Read/Hamlet.hs index 1c9bbf6..55b73f8 100644 --- a/src/Hakyll/Web/Template/Read/Hamlet.hs +++ b/src/Hakyll/Web/Template/Read/Hamlet.hs @@ -6,12 +6,8 @@ module Hakyll.Web.Template.Read.Hamlet , readHamletTemplateWith ) where -import Control.Monad.Trans (liftIO) -import System.FilePath (takeExtension) - import Text.Hamlet (HamletSettings (..), defaultHamletSettings) import Text.Hamlet.RT -import Control.Failure import Hakyll.Web.Template.Internal diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs index d95b151..a52eb5b 100644 --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -11,8 +11,7 @@ import qualified Data.Map as M import Hakyll.Web.Page import Hakyll.Web.Template -import Hakyll.Web.Template.Read.Hakyll -import Hakyll.Web.Template.Read.Hamlet +import Hakyll.Web.Template.Read import TestSuite.Util tests :: [Test] -- cgit v1.2.3 From 1075096df7268111b2de83f0c52af15921be4ca4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 15:08:26 +0100 Subject: Add sortByBaseName function for pages --- src/Hakyll/Web/Page.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index c7de026..549badc 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -10,6 +10,7 @@ module Hakyll.Web.Page , toMap , pageRead , addDefaultFields + , sortByBaseName ) where import Prelude hiding (id) @@ -19,6 +20,8 @@ import System.FilePath (takeBaseName, takeDirectory) import Data.Monoid (Monoid, mempty) import Data.Map (Map) import qualified Data.Map as M +import Data.List (sortBy) +import Data.Ord (comparing) import Hakyll.Core.Identifier import Hakyll.Core.Compiler @@ -71,3 +74,10 @@ addDefaultFields = (getRoute &&& id >>^ uncurry addRoute) . setField "path" p where p = toFilePath i + +-- | Sort posts based on the basename of the post. This is equivalent to a +-- chronologival sort, because of the @year-month-day-title.extension@ naming +-- convention in Hakyll. +-- +sortByBaseName :: [Page a] -> [Page a] +sortByBaseName = sortBy $ comparing $ takeBaseName . getField "path" -- cgit v1.2.3 From d66155968fa02b85eb751c68f20d3a6bb708b5e6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 16:04:55 +0100 Subject: Move preview server, update to snap 0.4 --- src/Hakyll/Main.hs | 2 +- src/Hakyll/Network/Server.hs | 72 ---------------------------------------- src/Hakyll/Web/Preview/Server.hs | 72 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+), 73 deletions(-) delete mode 100644 src/Hakyll/Network/Server.hs create mode 100644 src/Hakyll/Web/Preview/Server.hs (limited to 'src') diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 36a4010..1d60e47 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -12,7 +12,7 @@ import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import Hakyll.Core.Configuration import Hakyll.Core.Run import Hakyll.Core.Rules -import Hakyll.Network.Server +import Hakyll.Web.Preview.Server -- | This usualy is the function with which the user runs the hakyll compiler -- diff --git a/src/Hakyll/Network/Server.hs b/src/Hakyll/Network/Server.hs deleted file mode 100644 index 0e25959..0000000 --- a/src/Hakyll/Network/Server.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | Implements a basic static file server for previewing options --- -{-# LANGUAGE OverloadedStrings #-} -module Hakyll.Network.Server - ( staticServer - ) where - -import Control.Monad.Trans (liftIO) -import Control.Applicative ((<$>)) -import Codec.Binary.UTF8.String -import System.FilePath (()) -import System.Directory (doesFileExist) - -import qualified Data.ByteString as SB -import Snap.Util.FileServe (fileServeSingle) -import Snap.Types (Snap, rqURI, getRequest, writeBS) -import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen - , ConfigListen (..), emptyConfig - ) - -import Hakyll.Web.Util.String (replaceAll) - --- | The first file in the list that actually exists is returned --- -findFile :: [FilePath] -> IO (Maybe FilePath) -findFile [] = return Nothing -findFile (x : xs) = do - exists <- doesFileExist x - if exists then return (Just x) else findFile xs - --- | Serve a given directory --- -static :: FilePath -- ^ Directory to serve - -> (FilePath -> IO ()) -- ^ Pre-serve hook - -> Snap () -static directory preServe = do - -- Obtain the path - uri <- rqURI <$> getRequest - let filePath = replaceAll "\\?$" (const "") -- Remove trailing ? - $ replaceAll "#[^#]*$" (const "") -- Remove #section - $ replaceAll "^/" (const "") -- Remove leading / - $ decode $ SB.unpack uri - - -- Try to find the requested file - r <- liftIO $ findFile $ map (directory ) $ - [ filePath - , filePath "index.htm" - , filePath "index.html" - ] - - case r of - -- Not found, error - Nothing -> writeBS "Not found" - -- Found, serve - Just f -> do - liftIO $ preServe f - fileServeSingle f - --- | Main method, runs a static server in the given directory --- -staticServer :: FilePath -- ^ Directory to serve - -> (FilePath -> IO ()) -- ^ Pre-serve hook - -> Int -- ^ Port to listen on - -> IO () -- ^ Blocks forever -staticServer directory preServe port = - httpServe config $ static directory preServe - where - -- Snap server config - config = addListen (ListenHttp "0.0.0.0" port) - $ setAccessLog Nothing - $ setErrorLog Nothing - $ emptyConfig diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs new file mode 100644 index 0000000..77b3cb0 --- /dev/null +++ b/src/Hakyll/Web/Preview/Server.hs @@ -0,0 +1,72 @@ +-- | Implements a basic static file server for previewing options +-- +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Web.Preview.Server + ( staticServer + ) where + +import Control.Monad.Trans (liftIO) +import Control.Applicative ((<$>)) +import Codec.Binary.UTF8.String +import System.FilePath (()) +import System.Directory (doesFileExist) + +import qualified Data.ByteString as SB +import Snap.Util.FileServe (serveFile) +import Snap.Types (Snap, rqURI, getRequest, writeBS) +import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen + , ConfigListen (..), emptyConfig + ) + +import Hakyll.Web.Util.String (replaceAll) + +-- | The first file in the list that actually exists is returned +-- +findFile :: [FilePath] -> IO (Maybe FilePath) +findFile [] = return Nothing +findFile (x : xs) = do + exists <- doesFileExist x + if exists then return (Just x) else findFile xs + +-- | Serve a given directory +-- +static :: FilePath -- ^ Directory to serve + -> (FilePath -> IO ()) -- ^ Pre-serve hook + -> Snap () +static directory preServe = do + -- Obtain the path + uri <- rqURI <$> getRequest + let filePath = replaceAll "\\?$" (const "") -- Remove trailing ? + $ replaceAll "#[^#]*$" (const "") -- Remove #section + $ replaceAll "^/" (const "") -- Remove leading / + $ decode $ SB.unpack uri + + -- Try to find the requested file + r <- liftIO $ findFile $ map (directory ) $ + [ filePath + , filePath "index.htm" + , filePath "index.html" + ] + + case r of + -- Not found, error + Nothing -> writeBS "Not found" + -- Found, serve + Just f -> do + liftIO $ preServe f + serveFile f + +-- | Main method, runs a static server in the given directory +-- +staticServer :: FilePath -- ^ Directory to serve + -> (FilePath -> IO ()) -- ^ Pre-serve hook + -> Int -- ^ Port to listen on + -> IO () -- ^ Blocks forever +staticServer directory preServe port = + httpServe config $ static directory preServe + where + -- Snap server config + config = addListen (ListenHttp "0.0.0.0" port) + $ setAccessLog Nothing + $ setErrorLog Nothing + $ emptyConfig -- cgit v1.2.3 From 48da85b3418e7805d27cd2703f83570027d66a2a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 16:42:26 +0100 Subject: Add isFileInternal --- src/Hakyll/Core/Util/File.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 45f3760..71de322 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -4,15 +4,21 @@ module Hakyll.Core.Util.File ( makeDirectories , getRecursiveContents , isFileObsolete + , isFileInternal ) where -import System.FilePath (normalise, takeDirectory, ()) import System.Time (ClockTime) import Control.Monad (forM, filterM) +import Data.List (isPrefixOf) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist , doesFileExist, getModificationTime , getDirectoryContents ) +import System.FilePath ( normalise, takeDirectory, splitPath + , dropTrailingPathSeparator, () + ) + +import Hakyll.Core.Configuration -- | Given a path to a file, try to make the path writable by making -- all directories on the path. @@ -65,3 +71,17 @@ isFileObsolete file depends = do then return True else do timeStamp <- getModificationTime file isObsolete timeStamp depends + +-- | Check if a file is meant for Hakyll internal use, i.e. if it is located in +-- the destination or store directory +-- +isFileInternal :: HakyllConfiguration -- ^ Configuration + -> FilePath -- ^ File to check + -> Bool -- ^ If the given file is internal +isFileInternal configuration file = + any (`isPrefixOf` split file) dirs + where + split = map dropTrailingPathSeparator . splitPath + dirs = map (split . ($ configuration)) [ destinationDirectory + , storeDirectory + ] -- cgit v1.2.3 From 77f37c1443293b791841538bf860e346536e306d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 18:59:16 +0100 Subject: getRecursiveContents can return directories --- .../Core/ResourceProvider/FileResourceProvider.hs | 2 +- src/Hakyll/Core/Util/File.hs | 31 ++++++++++++---------- 2 files changed, 18 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs index a2376c2..7343855 100644 --- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -16,7 +16,7 @@ import Hakyll.Core.Util.File -- fileResourceProvider :: IO ResourceProvider fileResourceProvider = do - list <- map parseIdentifier <$> getRecursiveContents "." + list <- map parseIdentifier <$> getRecursiveContents False "." return ResourceProvider { resourceList = list , resourceString = readFile . toFilePath diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 71de322..9babc8b 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -7,6 +7,7 @@ module Hakyll.Core.Util.File , isFileInternal ) where +import Control.Applicative ((<$>)) import System.Time (ClockTime) import Control.Monad (forM, filterM) import Data.List (isPrefixOf) @@ -27,22 +28,24 @@ makeDirectories :: FilePath -> IO () makeDirectories = createDirectoryIfMissing True . takeDirectory -- | Get all contents of a directory. Note that files starting with a dot (.) --- will be ignored. +-- will be ignored. -- -getRecursiveContents :: FilePath -> IO [FilePath] -getRecursiveContents topdir = do +getRecursiveContents :: Bool -- ^ Include directories? + -> FilePath -- ^ Directory to search + -> IO [FilePath] -- ^ List of files found +getRecursiveContents includeDirs topdir = do topdirExists <- doesDirectoryExist topdir - if topdirExists - then do names <- getDirectoryContents topdir - let properNames = filter isProper names - paths <- forM properNames $ \name -> do - let path = topdir name - isDirectory <- doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [normalise path] - return (concat paths) - else return [] + if not topdirExists + then return [] + else do + names <- filter isProper <$> getDirectoryContents topdir + paths <- forM names $ \name -> do + let path = normalise $ topdir name + isDirectory <- doesDirectoryExist path + if isDirectory then getRecursiveContents includeDirs path + else return [path] + return $ if includeDirs then topdir : concat paths + else concat paths where isProper = not . (== ".") . take 1 -- cgit v1.2.3 From c03607e08751c3ce0e7c4cb70f9168f7f0237663 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 20:05:50 +0100 Subject: Add prototype inotify backend --- src/Hakyll/Core/Run.hs | 3 -- src/Hakyll/Main.hs | 16 +++++++++-- src/Hakyll/Web/Preview/INotify.hs | 60 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 5 deletions(-) create mode 100644 src/Hakyll/Web/Preview/INotify.hs (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 17a5f79..407a2b1 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -25,7 +25,6 @@ import Hakyll.Core.ResourceProvider import Hakyll.Core.ResourceProvider.FileResourceProvider import Hakyll.Core.Rules import Hakyll.Core.DirectedGraph -import Hakyll.Core.DirectedGraph.Dot import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable import Hakyll.Core.Store @@ -114,8 +113,6 @@ addNewCompilers oldCompilers newCompilers = Runtime $ do -- complete graph completeGraph <- mappend currentGraph . hakyllGraph <$> get - liftIO $ writeDot "dependencies.dot" show completeGraph - -- Check which items are up-to-date. This only needs to happen for the new -- compilers oldModified <- hakyllModified <$> get diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 1d60e47..64800c2 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -5,6 +5,7 @@ module Hakyll.Main , hakyllWith ) where +import Control.Concurrent (forkIO) import Control.Monad (when) import System.Environment (getProgName, getArgs) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) @@ -12,6 +13,7 @@ import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import Hakyll.Core.Configuration import Hakyll.Core.Run import Hakyll.Core.Rules +import Hakyll.Web.Preview.INotify import Hakyll.Web.Preview.Server -- | This usualy is the function with which the user runs the hakyll compiler @@ -29,8 +31,8 @@ hakyllWith configuration rules = do ["build"] -> build configuration rules ["clean"] -> clean configuration ["help"] -> help - ["preview"] -> putStrLn "Not implemented" - ["preview", p] -> putStrLn "Not implemented" + ["preview"] -> preview configuration rules 8000 + ["preview", p] -> preview configuration rules (read p) ["rebuild"] -> rebuild configuration rules ["server"] -> server configuration 8000 ["server", p] -> server configuration (read p) @@ -74,6 +76,16 @@ help = do , name ++ " server [port] Run a local test server" ] +-- | Preview the site +-- +preview :: HakyllConfiguration -> Rules -> Int -> IO () +preview configuration rules port = do + -- Fork a thread polling for changes + _ <- forkIO $ previewPoll configuration "." $ build configuration rules + + -- Run the server in the main thread + server configuration port + -- | Rebuild the site -- rebuild :: HakyllConfiguration -> Rules -> IO () diff --git a/src/Hakyll/Web/Preview/INotify.hs b/src/Hakyll/Web/Preview/INotify.hs new file mode 100644 index 0000000..fb3a7de --- /dev/null +++ b/src/Hakyll/Web/Preview/INotify.hs @@ -0,0 +1,60 @@ +-- | Filesystem polling with an inotify backend. Works only on linux. +-- +module Hakyll.Web.Preview.INotify + ( previewPoll + ) where + +import Control.Monad (forM_, when, unless) +import System.Directory (doesDirectoryExist) +import System.FilePath (()) +import Data.List (isPrefixOf) + +import System.INotify + +import Hakyll.Core.Util.File +import Hakyll.Core.Configuration + +-- | Calls the given callback when the directory tree changes +-- +previewPoll :: HakyllConfiguration -- ^ Configuration + -> FilePath -- ^ Root directory + -> IO () -- ^ Action called when something changes + -> IO () -- ^ Can block forever +previewPoll conf directory callback = do + -- Initialize inotify + inotify <- initINotify + + -- Start by watching all directories + contents <- getRecursiveContents True directory + forM_ contents $ \file -> do + isDir <- doesDirectoryExist file + when isDir $ watchDirectory conf inotify file callback + +-- | Start watching a directory recursively: when another directory is created +-- inside this directory, start watching that one as well... +-- +watchDirectory :: HakyllConfiguration -- ^ Configuration + -> INotify -- ^ INotify handle + -> FilePath -- ^ Directory to watch + -> IO () -- ^ Callback + -> IO () -- ^ No result +watchDirectory conf inotify path callback = + unless (isFileInternal conf path) $ do + _ <- addWatch inotify interesting path $ \event -> do + putStrLn $ "Triggered: " ++ show event + callback' inotify path event + return () + where + callback' i p (Created True n) = watchDirectory conf i (p n) callback + callback' _ _ (Created _ p) = whenProper $ Just p + callback' _ _ (Modified _ p) = whenProper p + callback' _ _ (MovedOut _ p _) = whenProper $ Just p + callback' _ _ (MovedIn _ p _) = whenProper $ Just p + callback' _ _ (Deleted _ p) = whenProper $ Just p + callback' _ _ _ = return () + + interesting = [Modify, Create, Move, Delete] + + -- Call the callback only for proper files + whenProper Nothing = return () + whenProper (Just f) = unless ("." `isPrefixOf` f) callback -- cgit v1.2.3 From 38290835769494b555edd092d79e9523ea854531 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 22:55:03 +0100 Subject: Add defaultApplyTemplate compiler --- src/Hakyll/Web.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 92cdab5..73f818a 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -3,9 +3,12 @@ module Hakyll.Web ( defaultPageRead , defaultTemplateRead + , defaultHamletTemplateRead + , defaultHamletTemplateReadWith , defaultRelativizeUrls , defaultCopyFile , defaultCompressCss + , defaultApplyTemplate ) where import Prelude hiding (id) @@ -52,3 +55,7 @@ defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath defaultCompressCss :: Compiler () String defaultCompressCss = getResourceString >>^ compressCss + +defaultApplyTemplate :: Identifier -- ^ Template + -> Compiler (Page String) (Page String) -- ^ Compiler +defaultApplyTemplate identifier = require identifier (flip applyTemplate) -- cgit v1.2.3 From 84d920432c3397aab86414892b4766506236bc4c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 08:20:35 +0100 Subject: Add customRoute --- src/Hakyll/Core/Routes.hs | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs index c1a034f..b6e1c12 100644 --- a/src/Hakyll/Core/Routes.hs +++ b/src/Hakyll/Core/Routes.hs @@ -12,6 +12,7 @@ module Hakyll.Core.Routes , idRoute , setExtension , ifMatch + , customRoute ) where import Data.Monoid (Monoid, mempty, mappend) @@ -69,3 +70,8 @@ ifMatch :: Pattern -> Routes -> Routes ifMatch pattern (Routes route) = Routes $ \id' -> if doesMatch pattern id' then route id' else Nothing + +-- | Create a custom route. This should almost always be used with 'ifMatch'. +-- +customRoute :: (Identifier -> FilePath) -> Routes +customRoute f = Routes $ Just . f -- cgit v1.2.3 From 4e0abd872ac36eadb103a909bcd9f970667a9270 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 08:39:10 +0100 Subject: Update cabal file, fix warnings --- hakyll.cabal | 77 +++++++++++++++++++++++++++++++----------------- src/Hakyll/Core/Rules.hs | 7 +++-- src/Hakyll/Core/Run.hs | 8 +++-- 3 files changed, 59 insertions(+), 33 deletions(-) (limited to 'src') diff --git a/hakyll.cabal b/hakyll.cabal index 0538a18..63eaf61 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -33,36 +33,59 @@ library containers == 0.*, pandoc == 1.*, regex-base >= 0.93, - regex-tdfa >= 1.1, - network == 2.*, + regex-pcre >= 0.93, mtl >= 1, old-locale == 1.*, old-time == 1.*, time >= 1.1, binary >= 0.5, - hamlet >= 0.4.2, - blaze-html >= 0.2 && <= 0.3 - exposed-modules: Network.Hakyll.SimpleServer - Text.Hakyll - Text.Hakyll.Context - Text.Hakyll.ContextManipulations - Text.Hakyll.CreateContext - Text.Hakyll.File - Text.Hakyll.HakyllMonad - Text.Hakyll.Regex - Text.Hakyll.Render - Text.Hakyll.HakyllAction - Text.Hakyll.Paginate - Text.Hakyll.Page - Text.Hakyll.Pandoc - Text.Hakyll.Util - Text.Hakyll.Tags - Text.Hakyll.Feed - Text.Hakyll.Configurations.Static + hamlet >= 0.7, + blaze-html >= 0.4, + snap-server >= 0.4, + snap-core >= 0.4, + bytestring >= 0.9, + utf8-string >= 0.3, + hinotify >= 0.3, + tagsoup >= 0.12, + hopenssl >= 1.4 + exposed-modules: Hakyll + Hakyll.Main + Hakyll.Web.Util.String + Hakyll.Web.Preview.Server + Hakyll.Web.Preview.INotify + Hakyll.Web.CompressCss + Hakyll.Web.Template + Hakyll.Web.Feed + Hakyll.Web.Tags + Hakyll.Web.Pandoc + Hakyll.Web.FileType + Hakyll.Web.Page + Hakyll.Web.Template.Read + Hakyll.Web.RelativizeUrls + Hakyll.Web.Page.Read + Hakyll.Web.Page.Metadata + Hakyll.Web + Hakyll.Core.ResourceProvider.FileResourceProvider + Hakyll.Core.Configuration + Hakyll.Core.Identifier.Pattern + Hakyll.Core.Util.Arrow + Hakyll.Core.Util.File + Hakyll.Core.ResourceProvider + Hakyll.Core.CompiledItem + Hakyll.Core.Compiler + Hakyll.Core.Run + Hakyll.Core.Store + Hakyll.Core.Writable + Hakyll.Core.Identifier + Hakyll.Core.DirectedGraph.Dot + Hakyll.Core.DirectedGraph.DependencySolver + Hakyll.Core.DirectedGraph + Hakyll.Core.Rules + Hakyll.Core.Routes other-modules: Paths_hakyll - Text.Hakyll.Internal.Cache - Text.Hakyll.Internal.CompressCss - Text.Hakyll.Internal.FileType - Text.Hakyll.Internal.Template - Text.Hakyll.Internal.Template.Template - Text.Hakyll.Internal.Template.Hamlet + Hakyll.Web.Template.Read.Hakyll + Hakyll.Web.Template.Read.Hamlet + Hakyll.Web.Template.Internal + Hakyll.Web.Page.Internal + Hakyll.Core.Compiler.Internal + Hakyll.Core.DirectedGraph.Internal diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 4aa497c..28aac1f 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -16,10 +16,11 @@ module Hakyll.Core.Rules ) where import Control.Applicative (Applicative, (<$>)) -import Control.Monad.Writer -import Control.Monad.Reader +import Control.Monad.Writer (WriterT, execWriterT, tell) +import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Arrow (second, (>>>), arr, (>>^)) -import Control.Monad.State +import Control.Monad.State (State, evalState, get, put) +import Data.Monoid (Monoid, mempty, mappend) import Data.Typeable (Typeable) import Data.Binary (Binary) diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 407a2b1..de4114c 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -6,9 +6,11 @@ module Hakyll.Core.Run ) where import Prelude hiding (reverse) -import Control.Applicative -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad (filterM) +import Control.Monad.Trans (liftIO) +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Monad.State (StateT, evalStateT, get, modify) import Control.Arrow ((&&&)) import qualified Data.Map as M import Data.Monoid (mempty, mappend) -- cgit v1.2.3 From 2dfe7f6a674657d006d71eac25931bfd629b78a2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 08:48:18 +0100 Subject: Document Routes module --- src/Hakyll/Core/Routes.hs | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs index b6e1c12..250536a 100644 --- a/src/Hakyll/Core/Routes.hs +++ b/src/Hakyll/Core/Routes.hs @@ -2,9 +2,28 @@ -- This is where the 'Routes' type comes in; it determines where a certain -- target should be written. -- --- When a route is applied (using 'runRoute'), it either returns a 'Just' --- 'FilePath' (meaning the target should be written to that file path), or --- 'Nothing' (meaning this target should not be written anywhere). +-- Suppose we have an item @foo\/bar.markdown@. We can render this to +-- @foo\/bar.html@ using: +-- +-- > route "foo/bar.markdown" (setExtension ".html") +-- +-- If we do not want to change the extension, we can use 'idRoute', the simplest +-- route available: +-- +-- > route "foo/bar.markdown" idRoute +-- +-- That will route @foo\/bar.markdown@ to @foo\/bar.markdown@. +-- +-- Note that the extension says nothing about the content! If you set the +-- extension to @.html@, it is your own responsibility to ensure that the +-- content is indeed HTML. +-- +-- Finally, some special cases: +-- +-- * If there is no route for an item, this item will not be routed, so it will +-- not appear in your site directory. +-- +-- * If an item matches multiple routes, the first rule will be chosen. -- module Hakyll.Core.Routes ( Routes -- cgit v1.2.3 From dd81433d74579848e6853eb5a1500535c378c808 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 13:30:55 +0100 Subject: Split Rules module, add documentation --- hakyll.cabal | 1 + src/Hakyll/Core/CompiledItem.hs | 9 +++- src/Hakyll/Core/Compiler.hs | 2 +- src/Hakyll/Core/Rules.hs | 101 ++++++++++++++------------------------ src/Hakyll/Core/Rules/Internal.hs | 70 ++++++++++++++++++++++++++ src/Hakyll/Core/Run.hs | 2 +- 6 files changed, 118 insertions(+), 67 deletions(-) create mode 100644 src/Hakyll/Core/Rules/Internal.hs (limited to 'src') diff --git a/hakyll.cabal b/hakyll.cabal index 63eaf61..57c6066 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -89,3 +89,4 @@ library Hakyll.Web.Page.Internal Hakyll.Core.Compiler.Internal Hakyll.Core.DirectedGraph.Internal + Hakyll.Core.Rules.Internal diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs index fe6730b..5dd0efc 100644 --- a/src/Hakyll/Core/CompiledItem.hs +++ b/src/Hakyll/Core/CompiledItem.hs @@ -1,6 +1,11 @@ -- | A module containing a box datatype representing a compiled item. This --- item can be of any type, given that a few restrictions hold (e.g. we want --- a 'Typeable' instance to perform type-safe casts). +-- item can be of any type, given that a few restrictions hold: +-- +-- * we need a 'Typeable' instance to perform type-safe casts; +-- +-- * we need a 'Binary' instance so we can serialize these items to the cache; +-- +-- * we need a 'Writable' instance so the results can be saved. -- {-# LANGUAGE ExistentialQuantification #-} module Hakyll.Core.CompiledItem diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 5249478..85b912c 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -38,7 +38,7 @@ import Hakyll.Core.Writable import Hakyll.Core.ResourceProvider import Hakyll.Core.Compiler.Internal import Hakyll.Core.Store -import Hakyll.Core.Rules +import Hakyll.Core.Rules.Internal import Hakyll.Core.Routes -- | Run a compiler, yielding the resulting target and it's dependencies. This diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 28aac1f..fbdd533 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -1,13 +1,19 @@ --- | This module provides a monadic DSL in which the user can specify the --- different rules used to run the compilers +-- | This module provides a declarative DSL in which the user can specify the +-- different rules used to run the compilers. +-- +-- The convention is to just list all items in the 'RulesM' monad, routes and +-- compilation rules. +-- +-- A typical usage example would be: +-- +-- > main = hakyll $ do +-- > route "posts/*" (setExtension "html") +-- > compile "posts/*" someCompiler -- {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} module Hakyll.Core.Rules - ( CompileRule (..) - , RuleSet (..) - , RulesM + ( RulesM , Rules - , runRules , compile , create , route @@ -15,12 +21,12 @@ module Hakyll.Core.Rules , metaCompileWith ) where -import Control.Applicative (Applicative, (<$>)) -import Control.Monad.Writer (WriterT, execWriterT, tell) -import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Applicative ((<$>)) +import Control.Monad.Writer (tell) +import Control.Monad.Reader (ask) import Control.Arrow (second, (>>>), arr, (>>^)) -import Control.Monad.State (State, evalState, get, put) -import Data.Monoid (Monoid, mempty, mappend) +import Control.Monad.State (get, put) +import Data.Monoid (mempty) import Data.Typeable (Typeable) import Data.Binary (Binary) @@ -32,53 +38,7 @@ import Hakyll.Core.Compiler.Internal import Hakyll.Core.Routes import Hakyll.Core.CompiledItem import Hakyll.Core.Writable - --- | 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 - { rulesRoutes :: Routes - , rulesCompilers :: [(Identifier, Compiler () CompileRule)] - } - -instance Monoid RuleSet where - mempty = RuleSet mempty mempty - mappend (RuleSet r1 c1) (RuleSet r2 c2) = - RuleSet (mappend r1 r2) (mappend c1 c2) - --- | Rule state --- -data RuleState = RuleState - { rulesMetaCompilerIndex :: Int - } deriving (Show) - --- | The monad used to compose rules --- -newtype RulesM a = RulesM - { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) 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 :: Rules -> ResourceProvider -> RuleSet -runRules rules provider = - evalState (execWriterT $ runReaderT (unRulesM rules) provider) state - where - state = RuleState {rulesMetaCompilerIndex = 0} +import Hakyll.Core.Rules.Internal -- | Add a route -- @@ -95,10 +55,11 @@ tellCompilers compilers = RulesM $ tell $ RuleSet mempty $ where boxCompiler = (>>> arr compiledItem >>> arr CompileRule) --- | Add a compilation rule +-- | Add a compilation rule to the rules. -- -- This instructs all resources matching the given pattern to be compiled using --- the given compiler +-- the given compiler. When no resources match the given pattern, nothing will +-- happen. In this case, you might want to have a look at 'create'. -- compile :: (Binary a, Typeable a, Writable a) => Pattern -> Compiler () a -> Rules @@ -108,18 +69,32 @@ compile pattern compiler = RulesM $ do -- | Add a compilation rule -- --- This sets a compiler for the given identifier +-- This sets a compiler for the given identifier. No resource is needed, since +-- we are creating the item from scratch. -- create :: (Binary a, Typeable a, Writable a) => Identifier -> Compiler () a -> Rules create identifier compiler = tellCompilers [(identifier, compiler)] --- | Add a route +-- | Add a route. +-- +-- This adds a route for all items matching the given pattern. -- route :: Pattern -> Routes -> Rules route pattern route' = tellRoute $ ifMatch pattern route' --- | Add a compiler that produces other compilers over time +-- | 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. +-- +-- And indeed, we can see that the first argument to 'metaCompile' is a +-- 'Compiler' which produces a list of ('Identifier', 'Compiler') pairs. The +-- idea is simple: 'metaCompile' produces a list of compilers, and the +-- corresponding identifiers. +-- +-- 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, Compiler () a)] diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs new file mode 100644 index 0000000..bedc67a --- /dev/null +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -0,0 +1,70 @@ +-- | Internal rules module for types which are not exposed to the user +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Rules.Internal + ( CompileRule (..) + , RuleSet (..) + , RuleState (..) + , RulesM (..) + , Rules + , 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 Hakyll.Core.ResourceProvider +import Hakyll.Core.Identifier +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Routes +import Hakyll.Core.CompiledItem + +-- | 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 + { rulesRoutes :: Routes + , rulesCompilers :: [(Identifier, Compiler () CompileRule)] + } + +instance Monoid RuleSet where + mempty = RuleSet mempty mempty + mappend (RuleSet r1 c1) (RuleSet r2 c2) = + RuleSet (mappend r1 r2) (mappend c1 c2) + +-- | Rule state +-- +data RuleState = RuleState + { rulesMetaCompilerIndex :: Int + } deriving (Show) + +-- | The monad used to compose rules +-- +newtype RulesM a = RulesM + { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) 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 :: Rules -> ResourceProvider -> RuleSet +runRules rules provider = + evalState (execWriterT $ runReaderT (unRulesM rules) provider) state + where + state = RuleState {rulesMetaCompilerIndex = 0} diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index de4114c..7e6851f 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -25,7 +25,7 @@ import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.ResourceProvider import Hakyll.Core.ResourceProvider.FileResourceProvider -import Hakyll.Core.Rules +import Hakyll.Core.Rules.Internal import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable -- cgit v1.2.3 From 60cda32b72ce35e4c7c797be91badcb20afbe887 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 15:34:34 +0100 Subject: Add transparent reading of hamlet/hakyll templates --- src/Hakyll/Web.hs | 19 ++++++------------- src/Hakyll/Web/Template.hs | 30 +++++++++++++++++++++++++++++- src/Hakyll/Web/Template/Internal.hs | 8 ++++---- src/Hakyll/Web/Template/Read/Hakyll.hs | 14 +++++++------- src/Hakyll/Web/Template/Read/Hamlet.hs | 2 +- 5 files changed, 47 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 73f818a..617e2de 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -3,8 +3,7 @@ module Hakyll.Web ( defaultPageRead , defaultTemplateRead - , defaultHamletTemplateRead - , defaultHamletTemplateReadWith + , defaultTemplateReadWith , defaultRelativizeUrls , defaultCopyFile , defaultCompressCss @@ -15,7 +14,7 @@ import Prelude hiding (id) import Control.Category (id) import Control.Arrow (arr, (>>>), (>>^), (&&&)) -import Text.Hamlet (HamletSettings, defaultHamletSettings) +import Text.Hamlet (HamletSettings) import Hakyll.Core.Compiler import Hakyll.Core.Writable @@ -23,7 +22,6 @@ import Hakyll.Core.Identifier import Hakyll.Web.Page import Hakyll.Web.Pandoc import Hakyll.Web.Template -import Hakyll.Web.Template.Read import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String import Hakyll.Web.CompressCss @@ -39,16 +37,11 @@ defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) defaultTemplateRead :: Compiler () Template -defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ - getResourceString >>^ readTemplate +defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ templateRead -defaultHamletTemplateRead :: Compiler () Template -defaultHamletTemplateRead = defaultHamletTemplateReadWith defaultHamletSettings - -defaultHamletTemplateReadWith :: HamletSettings -> Compiler () Template -defaultHamletTemplateReadWith settings = - cached "Hakyll.Web.defaultHamletTemplateReadWith" $ - getResourceString >>^ readHamletTemplateWith settings +defaultTemplateReadWith :: HamletSettings -> Compiler () Template +defaultTemplateReadWith settings = cached "Hakyll.Web.defaultTemplateReadWith" $ + templateReadWith settings defaultCopyFile :: Compiler () CopyFile defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 06794e8..00c1a27 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -2,11 +2,19 @@ module Hakyll.Web.Template ( Template , applyTemplate , applySelf + , templateRead + , templateReadWith ) where +import Control.Arrow import Data.Maybe (fromMaybe) import qualified Data.Map as M +import System.FilePath (takeExtension) +import Text.Hamlet (HamletSettings, defaultHamletSettings) + +import Hakyll.Core.Compiler +import Hakyll.Core.Identifier import Hakyll.Web.Template.Internal import Hakyll.Web.Template.Read import Hakyll.Web.Page @@ -20,7 +28,7 @@ applyTemplate template page = fmap (const $ substitute =<< unTemplate template) page where substitute (Chunk chunk) = chunk - substitute (Identifier key) = + substitute (Key key) = fromMaybe ('$' : key) $ M.lookup key $ toMap page substitute (Escaped) = "$" @@ -29,3 +37,23 @@ applyTemplate template page = -- applySelf :: Page String -> Page String applySelf page = applyTemplate (readTemplate $ pageBody page) page + +-- | 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. +-- +templateRead :: Compiler a Template +templateRead = templateReadWith defaultHamletSettings + +-- | Version of 'templateRead' that enables custom settings. +-- +templateReadWith :: HamletSettings -> Compiler a Template +templateReadWith settings = + getIdentifier &&& getResourceString >>^ uncurry read' + where + read' identifier string = + if takeExtension (toFilePath identifier) `elem` [".hml", ".hamlet"] + -- Hamlet template + then readHamletTemplateWith settings string + -- Hakyll template + else readTemplate string diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs index d0f6472..d0e0859 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -28,18 +28,18 @@ instance Writable Template where -- data TemplateElement = Chunk String - | Identifier String + | Key String | Escaped deriving (Show, Eq, Typeable) instance Binary TemplateElement where put (Chunk string) = putWord8 0 >> put string - put (Identifier key) = putWord8 1 >> put key + put (Key key) = putWord8 1 >> put key put (Escaped) = putWord8 2 get = getWord8 >>= \tag -> case tag of - 0 -> Chunk <$> get - 1 -> Identifier <$> get + 0 -> Chunk <$> get + 1 -> Key <$> get 2 -> return Escaped _ -> error $ "Hakyll.Web.Template.Internal: " ++ "Error reading cached template" diff --git a/src/Hakyll/Web/Template/Read/Hakyll.hs b/src/Hakyll/Web/Template/Read/Hakyll.hs index e0e10f4..fecf772 100644 --- a/src/Hakyll/Web/Template/Read/Hakyll.hs +++ b/src/Hakyll/Web/Template/Read/Hakyll.hs @@ -19,17 +19,17 @@ readTemplate = Template . readTemplate' | "$$" `isPrefixOf` string = Escaped : readTemplate' (drop 2 string) | "$" `isPrefixOf` string = - case readIdentifier (drop 1 string) of - Just (key, rest) -> Identifier key : readTemplate' rest + case readKey (drop 1 string) of + Just (key, rest) -> Key key : readTemplate' rest Nothing -> Chunk "$" : readTemplate' (drop 1 string) | otherwise = let (chunk, rest) = break (== '$') string in Chunk chunk : readTemplate' rest - -- Parse an identifier into (identifier, rest) if it's valid, and return + -- Parse an key into (key, rest) if it's valid, and return -- Nothing otherwise - readIdentifier string = - let (identifier, rest) = span isAlphaNum string - in if not (null identifier) && "$" `isPrefixOf` rest - then Just (identifier, drop 1 rest) + readKey string = + let (key, rest) = span isAlphaNum string + in if not (null key) && "$" `isPrefixOf` rest + then Just (key, drop 1 rest) else Nothing diff --git a/src/Hakyll/Web/Template/Read/Hamlet.hs b/src/Hakyll/Web/Template/Read/Hamlet.hs index 55b73f8..7b496de 100644 --- a/src/Hakyll/Web/Template/Read/Hamlet.hs +++ b/src/Hakyll/Web/Template/Read/Hamlet.hs @@ -35,7 +35,7 @@ fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd where fromSimpleDoc :: SimpleDoc -> TemplateElement fromSimpleDoc (SDRaw chunk) = Chunk chunk - fromSimpleDoc (SDVar [var]) = Identifier var + fromSimpleDoc (SDVar [var]) = Key var fromSimpleDoc (SDVar _) = error "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \ \Hakyll does not support '.' in identifier names when using \ -- cgit v1.2.3 From 77970096465743cd85e41313e59ef064046691fc Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 16:09:39 +0100 Subject: Document the Template module --- src/Hakyll/Web/Template.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 00c1a27..9ea4183 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -1,3 +1,46 @@ +-- | This module provides means for reading and applying 'Template's. +-- +-- Templates are tools to convert data (pages) into a string. They are +-- perfectly suited for laying out your site. +-- +-- Let's look at an example template: +-- +-- > +-- > +-- > My crazy homepage - $title$ +-- > +-- > +-- > +-- >
+-- > $body$ +-- >
+-- > +-- > +-- > +-- +-- We can use this template to render a 'Page' which has a body and a @$title$@ +-- metadata field. +-- +-- As you can see, the format is very simple -- @$key$@ is used to render the +-- @$key$@ field from the page, everything else is literally copied. If you want +-- to literally insert @\"$key$\"@ into your page (for example, when you're +-- writing a Hakyll tutorial) you can use +-- +-- >

+-- > A literal $$key$$. +-- >

+-- +-- Because of it's simplicity, these templates can be used for more than HTML: +-- you could make, for example, CSS or JS templates as well. +-- +-- In addition to the native format, Hakyll also supports hamlet templates. For +-- more information on hamlet templates, please refer to: +-- . +-- module Hakyll.Web.Template ( Template , applyTemplate -- cgit v1.2.3 From fc6df44c2218f5c0265c978a02f9cb7fcf50562a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 17:39:53 +0100 Subject: Document Page module --- src/Hakyll/Web/Page.hs | 49 ++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 549badc..220ee29 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -1,6 +1,49 @@ --- | A page is an important concept in Hakyll: it has a body (usually of the --- type 'String') and number of metadata fields. This type is used to represent --- pages on your website. +-- | A page is a key-value mapping, representing a page on your site +-- +-- A page is an important concept in Hakyll. It is a key-value mapping, and has +-- one field with an arbitrary type. A 'Page' thus consists of +-- +-- * a key-value mapping (of the type @Map String String@); +-- +-- * a value (of the type @a@). +-- +-- Usually, the value will be a 'String' as well, and the value will be the body +-- of the page. +-- +-- Pages can be constructed using Haskell, but they are usually parsed from a +-- file. The file format for pages is pretty straightforward. +-- +-- > This is a simple page +-- > consisting of two lines. +-- +-- This is a valid page with two lines. If we load this in Hakyll, there would +-- be no metadata, and the body would be the given text. Let's look at a page +-- with some metadata. +-- +-- > --- +-- > title: Alice's Adventures in Wonderland +-- > author: Lewis Caroll +-- > year: 1865 +-- > --- +-- > +-- > Chapter I +-- > ========= +-- > +-- > Down the Rabbit-Hole +-- > -------------------- +-- > +-- > Alice was beginning to get very tired of sitting by her sister on the bank, +-- > and of having nothing to do: once or twice she had peeped into the book her +-- > sister was reading, but it had no pictures or conversations in it, "and +-- > what is the use of a book," thought Alice "without pictures or +-- > conversation?" +-- > +-- > ... +-- +-- As you can see, we construct a metadata header in Hakyll using @---@. Then, +-- we simply list all @key: value@ pairs, and end with @---@ again. This page +-- contains three metadata fields and a body. The body is given in markdown +-- format, which can be easily rendered to HTML by Hakyll, using pandoc. -- {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page -- cgit v1.2.3 From 2b9858a8f9212219718625b7c5891bcb11cbaefb Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 17:52:19 +0100 Subject: Add Resource type for improved type-safety --- src/Hakyll/Core/Compiler.hs | 8 ++++---- src/Hakyll/Core/ResourceProvider.hs | 7 ++++++- src/Hakyll/Core/Rules.hs | 6 ++++-- src/Hakyll/Web.hs | 11 ++++++----- src/Hakyll/Web/Page.hs | 3 ++- src/Hakyll/Web/Template.hs | 5 +++-- 6 files changed, 25 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 85b912c..bbb5737 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -87,7 +87,7 @@ getRouteFor = fromJob $ \identifier -> CompilerM $ do -- | Get the resource we are compiling as a string -- -getResourceString :: Compiler a String +getResourceString :: Compiler Resource String getResourceString = getIdentifier >>> getResourceString' where getResourceString' = fromJob $ \id' -> CompilerM $ do @@ -165,8 +165,8 @@ requireAllA pattern = (id &&& requireAll_ pattern >>>) cached :: (Binary a, Typeable a, Writable a) => String - -> Compiler () a - -> Compiler () a + -> Compiler Resource a + -> Compiler Resource a cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do identifier <- compilerIdentifier <$> ask store <- compilerStore <$> ask @@ -174,7 +174,7 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do liftIO $ putStrLn $ show identifier ++ ": " ++ if modified then "MODIFIED" else "OK" if modified - then do v <- unCompilerM $ j () + then do v <- unCompilerM $ j Resource liftIO $ storeSet store name identifier v return v else do v <- liftIO $ storeGet store name identifier diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs index d5f2ea3..980f001 100644 --- a/src/Hakyll/Core/ResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -3,7 +3,8 @@ -- the concrete instance. -- module Hakyll.Core.ResourceProvider - ( ResourceProvider (..) + ( Resource (..) + , ResourceProvider (..) , resourceExists , resourceDigest , resourceModified @@ -19,6 +20,10 @@ import OpenSSL.Digest (MessageDigest (MD5)) import Hakyll.Core.Identifier import Hakyll.Core.Store +-- | A resource +-- +data Resource = Resource + -- | A value responsible for retrieving and listing resources -- data ResourceProvider = ResourceProvider diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index fbdd533..78cbac7 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -39,6 +39,7 @@ import Hakyll.Core.Routes import Hakyll.Core.CompiledItem import Hakyll.Core.Writable import Hakyll.Core.Rules.Internal +import Hakyll.Core.Util.Arrow -- | Add a route -- @@ -62,10 +63,11 @@ tellCompilers compilers = RulesM $ tell $ RuleSet mempty $ -- happen. In this case, you might want to have a look at 'create'. -- compile :: (Binary a, Typeable a, Writable a) - => Pattern -> Compiler () a -> Rules + => Pattern -> Compiler Resource a -> Rules compile pattern compiler = RulesM $ do identifiers <- matches pattern . resourceList <$> ask - unRulesM $ tellCompilers $ zip identifiers (repeat compiler) + unRulesM $ tellCompilers $ zip identifiers $ repeat $ + constA Resource >>> compiler -- | Add a compilation rule -- diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 617e2de..ae86301 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -19,6 +19,7 @@ import Text.Hamlet (HamletSettings) import Hakyll.Core.Compiler import Hakyll.Core.Writable import Hakyll.Core.Identifier +import Hakyll.Core.ResourceProvider import Hakyll.Web.Page import Hakyll.Web.Pandoc import Hakyll.Web.Template @@ -26,7 +27,7 @@ import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String import Hakyll.Web.CompressCss -defaultPageRead :: Compiler () (Page String) +defaultPageRead :: Compiler Resource (Page String) defaultPageRead = cached "Hakyll.Web.defaultPageRead" $ pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc @@ -36,17 +37,17 @@ defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize relativize Nothing = id relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) -defaultTemplateRead :: Compiler () Template +defaultTemplateRead :: Compiler Resource Template defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ templateRead -defaultTemplateReadWith :: HamletSettings -> Compiler () Template +defaultTemplateReadWith :: HamletSettings -> Compiler Resource Template defaultTemplateReadWith settings = cached "Hakyll.Web.defaultTemplateReadWith" $ templateReadWith settings -defaultCopyFile :: Compiler () CopyFile +defaultCopyFile :: Compiler Resource CopyFile defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath -defaultCompressCss :: Compiler () String +defaultCompressCss :: Compiler Resource String defaultCompressCss = getResourceString >>^ compressCss defaultApplyTemplate :: Identifier -- ^ Template diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 220ee29..03995cd 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -68,6 +68,7 @@ import Data.Ord (comparing) import Hakyll.Core.Identifier import Hakyll.Core.Compiler +import Hakyll.Core.ResourceProvider import Hakyll.Web.Page.Internal import Hakyll.Web.Page.Read import Hakyll.Web.Page.Metadata @@ -90,7 +91,7 @@ toMap (Page m b) = M.insert "body" b m -- | Read a page (do not render it) -- -pageRead :: Compiler a (Page String) +pageRead :: Compiler Resource (Page String) pageRead = getResourceString >>^ readPage -- | Add a number of default metadata fields to a page. These fields include: diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 9ea4183..6e6ad67 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -58,6 +58,7 @@ import Text.Hamlet (HamletSettings, defaultHamletSettings) import Hakyll.Core.Compiler import Hakyll.Core.Identifier +import Hakyll.Core.ResourceProvider import Hakyll.Web.Template.Internal import Hakyll.Web.Template.Read import Hakyll.Web.Page @@ -85,12 +86,12 @@ applySelf page = applyTemplate (readTemplate $ pageBody page) page -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed -- as such. -- -templateRead :: Compiler a Template +templateRead :: Compiler Resource Template templateRead = templateReadWith defaultHamletSettings -- | Version of 'templateRead' that enables custom settings. -- -templateReadWith :: HamletSettings -> Compiler a Template +templateReadWith :: HamletSettings -> Compiler Resource Template templateReadWith settings = getIdentifier &&& getResourceString >>^ uncurry read' where -- cgit v1.2.3 From 34257df262521e4031c5e19acad3e9ce060c488b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 11 Feb 2011 23:26:54 +0100 Subject: Resource = Identifier with an exists invariant --- src/Hakyll/Core/Compiler.hs | 12 ++++---- src/Hakyll/Core/ResourceProvider.hs | 35 ++++++++++++++-------- .../Core/ResourceProvider/FileResourceProvider.hs | 9 ++++-- src/Hakyll/Core/Rules.hs | 6 ++-- src/Hakyll/Core/Run.hs | 5 ++-- 5 files changed, 40 insertions(+), 27 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index bbb5737..056ef32 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -88,11 +88,9 @@ getRouteFor = fromJob $ \identifier -> CompilerM $ do -- | Get the resource we are compiling as a string -- getResourceString :: Compiler Resource String -getResourceString = getIdentifier >>> getResourceString' - where - getResourceString' = fromJob $ \id' -> CompilerM $ do - provider <- compilerResourceProvider <$> ask - liftIO $ resourceString provider id' +getResourceString = fromJob $ \resource -> CompilerM $ do + provider <- compilerResourceProvider <$> ask + liftIO $ resourceString provider resource -- | Auxiliary: get a dependency -- @@ -141,7 +139,7 @@ requireAll_ :: (Binary a, Typeable a, Writable a) -> Compiler b [a] requireAll_ pattern = fromDependencies getDeps >>> fromJob requireAll_' where - getDeps = matches pattern . resourceList + getDeps = matches pattern . map unResource . resourceList requireAll_' = const $ CompilerM $ do deps <- getDeps . compilerResourceProvider <$> ask mapM (unCompilerM . getDependency) deps @@ -174,7 +172,7 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do liftIO $ putStrLn $ show identifier ++ ": " ++ if modified then "MODIFIED" else "OK" if modified - then do v <- unCompilerM $ j Resource + then do v <- unCompilerM $ j $ Resource identifier liftIO $ storeSet store name identifier v return v else do v <- liftIO $ storeGet store name identifier diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs index 980f001..dcd4af0 100644 --- a/src/Hakyll/Core/ResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider.hs @@ -2,6 +2,14 @@ -- 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.ResourceProvider ( Resource (..) , ResourceProvider (..) @@ -22,43 +30,46 @@ import Hakyll.Core.Store -- | A resource -- -data Resource = Resource +-- Invariant: the resource specified by the given identifier must exist +-- +newtype Resource = Resource {unResource :: Identifier} + deriving (Eq, Show, Ord) -- | A value responsible for retrieving and listing resources -- data ResourceProvider = ResourceProvider { -- | A list of all resources this provider is able to provide - resourceList :: [Identifier] + resourceList :: [Resource] , -- | Retrieve a certain resource as string - resourceString :: Identifier -> IO String + resourceString :: Resource -> IO String , -- | Retrieve a certain resource as lazy bytestring - resourceLazyByteString :: Identifier -> IO LB.ByteString + resourceLazyByteString :: Resource -> IO LB.ByteString } --- | Check if a given resource exists +-- | Check if a given identifier has a resource -- resourceExists :: ResourceProvider -> Identifier -> Bool -resourceExists provider = flip elem $ resourceList provider +resourceExists provider = flip elem $ map unResource $ resourceList provider -- | Retrieve a digest for a given resource -- -resourceDigest :: ResourceProvider -> Identifier -> IO [Word8] +resourceDigest :: ResourceProvider -> Resource -> IO [Word8] resourceDigest provider = digest MD5 <=< resourceLazyByteString provider -- | Check if a resource was modified -- -resourceModified :: ResourceProvider -> Identifier -> Store -> IO Bool -resourceModified provider identifier store = do +resourceModified :: ResourceProvider -> Resource -> Store -> IO Bool +resourceModified provider resource store = do -- Get the latest seen digest from the store - lastDigest <- storeGet store itemName identifier + lastDigest <- storeGet store itemName $ unResource resource -- Calculate the digest for the resource - newDigest <- resourceDigest provider identifier + newDigest <- resourceDigest provider resource -- Check digests if Just newDigest == lastDigest -- All is fine, not modified then return False -- Resource modified; store new digest - else do storeSet store itemName identifier newDigest + else do storeSet store itemName (unResource resource) newDigest return True where itemName = "Hakyll.Core.ResourceProvider.resourceModified" diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs index 7343855..2f040b3 100644 --- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -16,9 +16,12 @@ import Hakyll.Core.Util.File -- fileResourceProvider :: IO ResourceProvider fileResourceProvider = do + -- Retrieve a list of identifiers list <- map parseIdentifier <$> getRecursiveContents False "." + + -- Construct a resource provider return ResourceProvider - { resourceList = list - , resourceString = readFile . toFilePath - , resourceLazyByteString = LB.readFile . toFilePath + { resourceList = map Resource list + , resourceString = readFile . toFilePath . unResource + , resourceLazyByteString = LB.readFile . toFilePath . unResource } diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 78cbac7..137dc2c 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -65,9 +65,9 @@ tellCompilers compilers = RulesM $ tell $ RuleSet mempty $ compile :: (Binary a, Typeable a, Writable a) => Pattern -> Compiler Resource a -> Rules compile pattern compiler = RulesM $ do - identifiers <- matches pattern . resourceList <$> ask - unRulesM $ tellCompilers $ zip identifiers $ repeat $ - constA Resource >>> compiler + identifiers <- matches pattern . map unResource . resourceList <$> ask + unRulesM $ tellCompilers $ flip map identifiers $ \identifier -> + (identifier, constA (Resource identifier) >>> compiler) -- | Add a compilation rule -- diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 7e6851f..2b0ff5d 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -82,8 +82,9 @@ modified :: ResourceProvider -- ^ Resource provider -> [Identifier] -- ^ Identifiers to check -> IO (Set Identifier) -- ^ Modified resources modified provider store ids = fmap S.fromList $ flip filterM ids $ \id' -> - if resourceExists provider id' then resourceModified provider id' store - else return False + if resourceExists provider id' + then resourceModified provider (Resource id') store + else return False -- | Add a number of compilers and continue using these compilers -- -- cgit v1.2.3 From 1100f65f76060a5bee2ae92c25923fff84dc856c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Feb 2011 10:26:58 +0100 Subject: Document Compiler module --- src/Hakyll/Core/Compiler.hs | 86 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 85 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 056ef32..8d713c2 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -1,4 +1,88 @@ --- | A Compiler manages targets and dependencies between targets. +-- | A Compiler manages targets and dependencies between targets +-- +-- The most distinguishing property of a 'Compiler' is that it is an Arrow. A +-- compiler of the type @Compiler a b@ is simply a compilation phase which takes +-- an @a@ as input, and produces a @b@ as output. +-- +-- Compilers are chained using the '>>>' arrow operation. If we have a compiler +-- +-- > getResourceString :: Compiler Resource String +-- +-- which reads the resource, and a compiler +-- +-- > readPage :: Compiler String (Page String) +-- +-- we can chain these two compilers to get a +-- +-- > (getResourceString >>> readPage) :: Compiler Resource (Page String) +-- +-- Most compilers can be created by combining smaller compilers using '>>>'. +-- +-- More advanced constructions are also possible using arrow, and sometimes +-- these are needed. For a good introduction to arrow, you can refer to +-- +-- +-- +-- A construction worth writing a few paragraphs about here are the 'require' +-- functions. Different variants of this function are exported here, but they +-- all serve more or less the same goal. +-- +-- When you use only '>>>' to chain your compilers, you get a linear pipeline -- +-- it is not possible to add extra items from other compilers along the way. +-- This is where the 'require' functions come in. +-- +-- This function allows you to reference other items, which are then added to +-- the pipeline. Let's look at this crappy ASCII illustration which represents +-- a pretty common scenario: +-- +-- > read resource >>> pandoc render >>> layout >>> relativize URL's +-- > +-- > @templates/fancy.html@ +-- +-- We want to construct a pipeline of compilers to go from our resource to a +-- proper webpage. However, the @layout@ compiler takes more than just the +-- rendered page as input: it needs the @templates/fancy.html@ template as well. +-- +-- This is an example of where we need the @require@ function. We can solve +-- this using a construction that looks like: +-- +-- > ... >>> pandoc render >>> require >>> layout >>> ... +-- > | +-- > @templates/fancy.html@ ------/ +-- +-- This illustration can help us understand the type signature of 'require'. +-- +-- > require :: (Binary a, Typeable a, Writable a) +-- > => Identifier +-- > -> (b -> a -> c) +-- > -> Compiler b c +-- +-- Let's look at it in detail: +-- +-- > (Binary a, Typeable a, Writable a) +-- +-- These are constraints for the @a@ type. @a@ (the template) needs to have +-- certain properties for it to be required. +-- +-- > Identifier +-- +-- This is simply @templates/fancy.html@: the 'Identifier' of the item we want +-- to 'require', in other words, the name of the item we want to add to the +-- pipeline somehow. +-- +-- > (b -> a -> c) +-- +-- This is a function given by the user, specifying /how/ the two items shall be +-- merged. @b@ is the output of the previous compiler, and @a@ is the item we +-- just required -- the template. This means @c@ will be the final output of the +-- 'require' combinator. +-- +-- > Compiler b c +-- +-- Indeed, we have now constructed a compiler which takes a @b@ and produces a +-- @c@. This means that we have a linear pipeline again, thanks to the 'require' +-- function. So, the 'require' function actually helps to reduce to complexity +-- of Hakyll applications! -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler -- cgit v1.2.3 From 6e2cc769289990a6fbe68d50598646008e3f8aa6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Feb 2011 15:03:43 +0100 Subject: $key$ instead of $key when not found --- src/Hakyll/Web/Template.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 6e6ad67..78ddbba 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -73,7 +73,7 @@ applyTemplate template page = where substitute (Chunk chunk) = chunk substitute (Key key) = - fromMaybe ('$' : key) $ M.lookup key $ toMap page + fromMaybe ("$" ++ key ++ "$") $ M.lookup key $ toMap page substitute (Escaped) = "$" -- | Apply a page as it's own template. This is often very useful to fill in -- cgit v1.2.3 From f910233e0ff0e276a10a1a8f37cf4c02499ef9ae Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Feb 2011 15:21:26 +0100 Subject: Avoid name clashes with pandoc --- examples/hakyll/hakyll.hs | 6 ++--- src/Hakyll/Web/Pandoc.hs | 60 +++++++++++++++++++++++------------------------ 2 files changed, 33 insertions(+), 33 deletions(-) (limited to 'src') diff --git a/examples/hakyll/hakyll.hs b/examples/hakyll/hakyll.hs index 92f24c7..35f0ba4 100644 --- a/examples/hakyll/hakyll.hs +++ b/examples/hakyll/hakyll.hs @@ -2,7 +2,7 @@ import Hakyll import Control.Monad (forM_) import Control.Arrow ((>>>), arr) -import Text.Pandoc (writerTableOfContents, writerTemplate, writerStandalone) +import Text.Pandoc main :: IO () main = hakyll $ do @@ -25,7 +25,7 @@ main = hakyll $ do -- Tutorial route "tutorial.markdown" $ setExtension "html" compile "tutorial.markdown" $ pageRead - >>> pageRenderPandocWith defaultParserState withToc + >>> pageRenderPandocWith defaultHakyllParserState withToc >>> requireA "sidebar.markdown" (setFieldA "sidebar" $ arr pageBody) >>> defaultApplyTemplate "templates/default.html" >>> defaultRelativizeUrls @@ -36,7 +36,7 @@ main = hakyll $ do -- Templates compile "templates/*" defaultTemplateRead where - withToc = defaultWriterOptions + withToc = defaultHakyllWriterOptions { writerTableOfContents = True , writerTemplate = "

Table of contents

\n$toc$\n$body$" , writerStandalone = True diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index acd5f56..308d06b 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -14,8 +14,8 @@ module Hakyll.Web.Pandoc , pageRenderPandocWith -- * Default options - , defaultParserState - , defaultWriterOptions + , defaultHakyllParserState + , defaultHakyllWriterOptions ) where import Prelude hiding (id) @@ -23,8 +23,7 @@ import Control.Applicative ((<$>)) import Control.Arrow ((>>^), (&&&)) import Control.Category (id) -import Text.Pandoc (Pandoc) -import qualified Text.Pandoc as P +import Text.Pandoc import Hakyll.Core.Compiler import Hakyll.Web.FileType @@ -35,20 +34,20 @@ import Hakyll.Web.Page readPandoc :: FileType -- ^ File type, determines how parsing happens -> String -- ^ String to read -> Pandoc -- ^ Resulting document -readPandoc = readPandocWith defaultParserState +readPandoc = readPandocWith defaultHakyllParserState -- | Read a string using pandoc, with the supplied options -- -readPandocWith :: P.ParserState -- ^ Parser options - -> FileType -- ^ File type, determines how parsing happens - -> String -- ^ String to read - -> Pandoc -- ^ Resulting document +readPandocWith :: ParserState -- ^ Parser options + -> FileType -- ^ File type, determines how parsing happens + -> String -- ^ String to read + -> Pandoc -- ^ Resulting document readPandocWith state fileType' = case fileType' of - Html -> P.readHtml state - LaTeX -> P.readLaTeX state - LiterateHaskell t -> readPandocWith state {P.stateLiterateHaskell = True} t - Markdown -> P.readMarkdown state - Rst -> P.readRST state + Html -> readHtml state + LaTeX -> readLaTeX state + LiterateHaskell t -> readPandocWith state {stateLiterateHaskell = True} t + Markdown -> readMarkdown state + Rst -> readRST state t -> error $ "Hakyll.Web.readPandocWith: I don't know how to read " ++ show t @@ -56,23 +55,23 @@ readPandocWith state fileType' = case fileType' of -- writePandoc :: Pandoc -- ^ Document to write -> String -- ^ Resulting HTML -writePandoc = writePandocWith defaultWriterOptions +writePandoc = writePandocWith defaultHakyllWriterOptions -- | Write a document (as HTML) using pandoc, with the supplied options -- -writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc - -> Pandoc -- ^ Document to write - -> String -- ^ Resulting HTML -writePandocWith = P.writeHtmlString +writePandocWith :: WriterOptions -- ^ Writer options for pandoc + -> Pandoc -- ^ Document to write + -> String -- ^ Resulting HTML +writePandocWith = writeHtmlString -- | Read the resource using pandoc -- pageReadPandoc :: Compiler (Page String) (Page Pandoc) -pageReadPandoc = pageReadPandocWith defaultParserState +pageReadPandoc = pageReadPandocWith defaultHakyllParserState -- | Read the resource using pandoc -- -pageReadPandocWith :: P.ParserState -> Compiler (Page String) (Page Pandoc) +pageReadPandocWith :: ParserState -> Compiler (Page String) (Page Pandoc) pageReadPandocWith state = id &&& getFileType >>^ pageReadPandocWith' where @@ -81,30 +80,31 @@ pageReadPandocWith state = -- | Render the resource using pandoc -- pageRenderPandoc :: Compiler (Page String) (Page String) -pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions +pageRenderPandoc = + pageRenderPandocWith defaultHakyllParserState defaultHakyllWriterOptions -- | Render the resource using pandoc -- -pageRenderPandocWith :: P.ParserState - -> P.WriterOptions +pageRenderPandocWith :: ParserState + -> WriterOptions -> Compiler (Page String) (Page String) pageRenderPandocWith state options = pageReadPandocWith state >>^ fmap (writePandocWith options) -- | The default reader options for pandoc parsing in hakyll -- -defaultParserState :: P.ParserState -defaultParserState = P.defaultParserState +defaultHakyllParserState :: ParserState +defaultHakyllParserState = defaultParserState { -- The following option causes pandoc to read smart typography, a nice -- and free bonus. - P.stateSmart = True + stateSmart = True } -- | The default writer options for pandoc rendering in hakyll -- -defaultWriterOptions :: P.WriterOptions -defaultWriterOptions = P.defaultWriterOptions +defaultHakyllWriterOptions :: WriterOptions +defaultHakyllWriterOptions = defaultWriterOptions { -- This option causes literate haskell to be written using '>' marks in -- html, which I think is a good default. - P.writerLiterateHaskell = True + writerLiterateHaskell = True } -- cgit v1.2.3 From 1e0c875d6efd67bda010573fc8bb935eef2ea225 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Feb 2011 16:54:31 +0100 Subject: More Identifier documentation --- examples/hakyll/tutorial.markdown | 5 ++++- src/Hakyll/Core/Identifier.hs | 10 ++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/examples/hakyll/tutorial.markdown b/examples/hakyll/tutorial.markdown index b3892d5..3fa870f 100644 --- a/examples/hakyll/tutorial.markdown +++ b/examples/hakyll/tutorial.markdown @@ -109,7 +109,10 @@ items it matches -- and matching is done using the `"css/*"` [pattern]. example, `css/screen.css` will be routed to `css/screen.css` -- not very exciting. -[pattern]: TODO: link +Note that a [pattern] matches [identifiers], it doesn't match filenames. + +[pattern]: /reference/Hakyll-Core-Identifier-Pattern.html +[identifiers]: /reference/Hakyll-Core-Identifier.html ~~~~~{.haskell} route "css/*" idRoute diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs index ea03e8c..16403e6 100644 --- a/src/Hakyll/Core/Identifier.hs +++ b/src/Hakyll/Core/Identifier.hs @@ -10,6 +10,16 @@ -- -- * @error/404@ -- +-- The most important difference between an 'Identifier' and a file path is that +-- the identifier for an item is not necesserily the file path. +-- +-- For example, we could have an @index@ identifier, generated by Hakyll. The +-- actual file path would be @index.html@, but we identify it using @index@. +-- +-- @posts/foo.markdown@ could be an identifier of an item that is rendered to +-- @posts/foo.html@. In this case, the identifier is the name of the source +-- file of the page. +-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Identifier ( Identifier (..) -- cgit v1.2.3 From 878ca8f3b02e99e736edaf5c7f0ba376ff3fe282 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Feb 2011 20:33:46 +0100 Subject: Document RelativizeUrls module --- examples/brochure/hakyll.hs | 2 +- examples/hakyll/tutorial.markdown | 18 ++++++++++++++---- src/Hakyll/Web/RelativizeUrls.hs | 16 ++++++++++++++++ 3 files changed, 31 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/examples/brochure/hakyll.hs b/examples/brochure/hakyll.hs index e84f14c..483265a 100644 --- a/examples/brochure/hakyll.hs +++ b/examples/brochure/hakyll.hs @@ -14,5 +14,5 @@ main = hakyll $ do forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> do route page $ setExtension "html" compile page $ defaultPageRead - >>> require "templates/default.html" (flip applyTemplate) + >>> defaultApplyTemplate "templates/default.html" >>> defaultRelativizeUrls diff --git a/examples/hakyll/tutorial.markdown b/examples/hakyll/tutorial.markdown index 3fa870f..bf534f3 100644 --- a/examples/hakyll/tutorial.markdown +++ b/examples/hakyll/tutorial.markdown @@ -73,7 +73,7 @@ main = hakyll $ do forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> do route page $ setExtension "html" compile page $ defaultPageRead - >>> require "templates/default.html" (flip applyTemplate) + >>> defaultApplyTemplate "templates/default.html" >>> defaultRelativizeUrls ~~~~~ @@ -133,7 +133,7 @@ Next, we're going to render some pages. We're going to style the results a little, so we're going to need a [template]. We simply compile a template using the `defaultTemplateRead` compiler, it's good enough in most cases. -[template]: TODO: link +[template]: /reference/Hakyll-Web-Template.html We don't use a route for these templates, after all, we don't want to route them anywhere, we just want to use them to style our pages a little. @@ -142,6 +142,13 @@ anywhere, we just want to use them to style our pages a little. compile "templates/*" defaultTemplateRead ~~~~~ +We can conclude that some rules do not *directly* add an output page on our +site. In this case, we compile the template so it is available to the compiler +later[^1]. + +[^1]: Actually, since the rules DSL is declarative, we could also add the + template compile rule at the bottom -- this would make no difference. + Now, it's time to actually render our pages. We use the `forM_` monad combinator so we can describe all files at once. @@ -162,10 +169,13 @@ DSL there. ### The Compiler DSL The gist of it is that the `Compiler a b` type has two parameters -- it is an -Arrow, and we can chain compilers using the `>>>` operator. +Arrow, and we can chain compilers using the `>>>` operator. The [compiler] +reference page has some more information on this subject. + +[compiler]: /reference/Hakyll-Core-Compiler.html ~~~~~{.haskell} compile page $ defaultPageRead - >>> require "templates/default.html" (flip applyTemplate) + >>> defaultApplyTemplate "templates/default.html" >>> defaultRelativizeUrls ~~~~~ diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs index 2a3b98f..40a5847 100644 --- a/src/Hakyll/Web/RelativizeUrls.hs +++ b/src/Hakyll/Web/RelativizeUrls.hs @@ -1,3 +1,19 @@ +-- | This module exposes a function which can relativize URL's on a webpage. +-- +-- This means that one can deploy the resulting site on +-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@ +-- without having to change anything (simply copy over the files). +-- +-- To use it, you should use absolute URL's from the site root everywhere. For +-- example, use +-- +-- > Funny zomgroflcopter +-- +-- in a blogpost. When running this through the relativize URL's module, this +-- will result in (suppose your blogpost is located at @\/posts\/foo.html@: +-- +-- > Funny zomgroflcopter +-- module Hakyll.Web.RelativizeUrls ( relativizeUrls ) where -- cgit v1.2.3 From abfb4c19195cf305637f1a9acd7f6dd70d59b831 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 13:50:10 +0100 Subject: defaultCompressCss → compressCssCompiler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web.hs | 5 ----- src/Hakyll/Web/CompressCss.hs | 12 +++++++++++- 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index ae86301..74c5c6c 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -6,7 +6,6 @@ module Hakyll.Web , defaultTemplateReadWith , defaultRelativizeUrls , defaultCopyFile - , defaultCompressCss , defaultApplyTemplate ) where @@ -25,7 +24,6 @@ import Hakyll.Web.Pandoc import Hakyll.Web.Template import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String -import Hakyll.Web.CompressCss defaultPageRead :: Compiler Resource (Page String) defaultPageRead = cached "Hakyll.Web.defaultPageRead" $ @@ -47,9 +45,6 @@ defaultTemplateReadWith settings = cached "Hakyll.Web.defaultTemplateReadWith" $ defaultCopyFile :: Compiler Resource CopyFile defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath -defaultCompressCss :: Compiler Resource String -defaultCompressCss = getResourceString >>^ compressCss - defaultApplyTemplate :: Identifier -- ^ Template -> Compiler (Page String) (Page String) -- ^ Compiler defaultApplyTemplate identifier = require identifier (flip applyTemplate) diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index e138ea2..3e86e09 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -2,14 +2,24 @@ -- state, but would typically reduce the number of bytes by about 25%. -- module Hakyll.Web.CompressCss - ( compressCss + ( compressCssCompiler + , compressCss ) where import Data.Char (isSpace) import Data.List (isPrefixOf) +import Control.Arrow ((>>^)) +import Hakyll.Core.Compiler +import Hakyll.Core.ResourceProvider import Hakyll.Web.Util.String +-- | Compiler form of 'compressCss' which automatically picks the right root +-- path +-- +compressCssCompiler :: Compiler Resource String +compressCssCompiler = getResourceString >>^ compressCss + -- | Compress CSS to speed up your site. -- compressCss :: String -> String -- cgit v1.2.3 From 5a591ee24c50ed25702c06f8f811189984e443ea Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 18:32:55 +0100 Subject: Rules DSL tracks resources used --- src/Hakyll/Core/Rules.hs | 24 +++++++++++++++++------- src/Hakyll/Core/Rules/Internal.hs | 15 ++++++++++----- 2 files changed, 27 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 137dc2c..1aa3ad3 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -27,6 +27,7 @@ import Control.Monad.Reader (ask) import Control.Arrow (second, (>>>), arr, (>>^)) import Control.Monad.State (get, put) import Data.Monoid (mempty) +import qualified Data.Set as S import Data.Typeable (Typeable) import Data.Binary (Binary) @@ -44,18 +45,24 @@ import Hakyll.Core.Util.Arrow -- | Add a route -- tellRoute :: Routes -> Rules -tellRoute route' = RulesM $ tell $ RuleSet route' mempty +tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty -- | Add a number of compilers -- tellCompilers :: (Binary a, Typeable a, Writable a) => [(Identifier, Compiler () a)] -> Rules -tellCompilers compilers = RulesM $ tell $ RuleSet mempty $ - map (second boxCompiler) compilers +tellCompilers compilers = RulesM $ tell $ RuleSet mempty compilers' mempty where + compilers' = map (second boxCompiler) compilers boxCompiler = (>>> arr compiledItem >>> arr CompileRule) +-- | Add resources +-- +tellResources :: [Resource] + -> Rules +tellResources resources = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources + -- | Add a compilation rule to the rules. -- -- This instructs all resources matching the given pattern to be compiled using @@ -66,8 +73,10 @@ compile :: (Binary a, Typeable a, Writable a) => Pattern -> Compiler Resource a -> Rules compile pattern compiler = RulesM $ do identifiers <- matches pattern . map unResource . resourceList <$> ask - unRulesM $ tellCompilers $ flip map identifiers $ \identifier -> - (identifier, constA (Resource identifier) >>> compiler) + unRulesM $ do + tellCompilers $ flip map identifiers $ \identifier -> + (identifier, constA (Resource identifier) >>> compiler) + tellResources $ map Resource identifiers -- | Add a compilation rule -- @@ -125,8 +134,9 @@ metaCompileWith :: (Binary a, Typeable a, Writable a) -- ^ Compiler generating the other compilers -> Rules -- ^ Resulting rules -metaCompileWith identifier compiler = RulesM $ tell $ RuleSet mempty - [(identifier, compiler >>> arr makeRule )] +metaCompileWith identifier compiler = RulesM $ tell $ + RuleSet mempty compilers mempty where makeRule = MetaCompileRule . map (second box) + compilers = [(identifier, compiler >>> arr makeRule )] box = (>>> fromDependency identifier >>^ CompileRule . compiledItem) diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index bedc67a..2895257 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -15,6 +15,7 @@ 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 Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier @@ -35,14 +36,18 @@ data CompileRule = CompileRule CompiledItem -- | A collection of rules for the compilation process -- data RuleSet = RuleSet - { rulesRoutes :: Routes - , rulesCompilers :: [(Identifier, Compiler () CompileRule)] + { -- | Routes used in the compilation structure + rulesRoutes :: Routes + , -- | Compilation rules + rulesCompilers :: [(Identifier, Compiler () CompileRule)] + , -- | A list of the used resources + rulesResources :: Set Resource } instance Monoid RuleSet where - mempty = RuleSet mempty mempty - mappend (RuleSet r1 c1) (RuleSet r2 c2) = - RuleSet (mappend r1 r2) (mappend c1 c2) + 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 -- -- cgit v1.2.3 From 3346123ca661d578ccb458e7135f8b68867bf107 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 18:43:22 +0100 Subject: Receive list of used resources in Run module --- src/Hakyll/Core/Run.hs | 5 +++-- src/Hakyll/Main.hs | 16 ++++++++++++++-- 2 files changed, 17 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 2b0ff5d..b59fdac 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -32,9 +32,9 @@ import Hakyll.Core.Writable import Hakyll.Core.Store import Hakyll.Core.Configuration --- | Run all rules needed +-- | Run all rules needed, return the rule set used -- -run :: HakyllConfiguration -> Rules -> IO () +run :: HakyllConfiguration -> Rules -> IO RuleSet run configuration rules = do store <- makeStore $ storeDirectory configuration provider <- fileResourceProvider @@ -46,6 +46,7 @@ run configuration rules = do state' = runReaderT reader $ env ruleSet provider store evalStateT state' state + return ruleSet where env ruleSet provider store = RuntimeEnvironment { hakyllConfiguration = configuration diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 64800c2..74097f7 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -6,13 +6,15 @@ module Hakyll.Main ) where import Control.Concurrent (forkIO) -import Control.Monad (when) +import Control.Monad (when, forM_) import System.Environment (getProgName, getArgs) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) +import qualified Data.Set as S import Hakyll.Core.Configuration import Hakyll.Core.Run import Hakyll.Core.Rules +import Hakyll.Core.Rules.Internal import Hakyll.Web.Preview.INotify import Hakyll.Web.Preview.Server @@ -41,7 +43,9 @@ hakyllWith configuration rules = do -- | Build the site -- build :: HakyllConfiguration -> Rules -> IO () -build = run +build configuration rules = do + _ <- run configuration rules + return () -- | Remove the output directories -- @@ -80,11 +84,19 @@ help = do -- preview :: HakyllConfiguration -> Rules -> Int -> IO () preview configuration rules port = do + -- Build once, keep the rule set + ruleSet <- run configuration rules + + -- Debug: show the resources used + forM_ (S.toList $ rulesResources ruleSet) $ putStrLn . show + + {- -- Fork a thread polling for changes _ <- forkIO $ previewPoll configuration "." $ build configuration rules -- Run the server in the main thread server configuration port + -} -- | Rebuild the site -- -- cgit v1.2.3 From d00026366c78ef8578f7a9503ced4915b1d4ec28 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 22:15:02 +0100 Subject: defaultPageRead → defaultPageCompiler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web.hs | 10 ++-------- src/Hakyll/Web/Page.hs | 15 +++++++++++---- src/Hakyll/Web/Page/Metadata.hs | 10 +++++++++- src/Hakyll/Web/Pandoc.hs | 2 +- src/Hakyll/Web/Template.hs | 6 +++--- 5 files changed, 26 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 74c5c6c..bd9ce31 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -1,8 +1,7 @@ -- | Module exporting commonly used web-related functions -- module Hakyll.Web - ( defaultPageRead - , defaultTemplateRead + ( defaultTemplateRead , defaultTemplateReadWith , defaultRelativizeUrls , defaultCopyFile @@ -11,7 +10,7 @@ module Hakyll.Web import Prelude hiding (id) import Control.Category (id) -import Control.Arrow (arr, (>>>), (>>^), (&&&)) +import Control.Arrow ((>>^), (&&&)) import Text.Hamlet (HamletSettings) @@ -20,15 +19,10 @@ import Hakyll.Core.Writable import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Web.Page -import Hakyll.Web.Pandoc import Hakyll.Web.Template import Hakyll.Web.RelativizeUrls import Hakyll.Web.Util.String -defaultPageRead :: Compiler Resource (Page String) -defaultPageRead = cached "Hakyll.Web.defaultPageRead" $ - pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc - defaultRelativizeUrls :: Compiler (Page String) (Page String) defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize where diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 03995cd..30578e9 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -51,14 +51,15 @@ module Hakyll.Web.Page , fromBody , fromMap , toMap - , pageRead + , readPageCompiler + , defaultPageCompiler , addDefaultFields , sortByBaseName ) where import Prelude hiding (id) import Control.Category (id) -import Control.Arrow ((>>^), (&&&), (>>>)) +import Control.Arrow (arr, (>>^), (&&&), (>>>)) import System.FilePath (takeBaseName, takeDirectory) import Data.Monoid (Monoid, mempty) import Data.Map (Map) @@ -72,6 +73,8 @@ import Hakyll.Core.ResourceProvider import Hakyll.Web.Page.Internal import Hakyll.Web.Page.Read import Hakyll.Web.Page.Metadata +import Hakyll.Web.Pandoc +import Hakyll.Web.Template import Hakyll.Web.Util.String -- | Create a page from a body, without metadata @@ -91,8 +94,12 @@ toMap (Page m b) = M.insert "body" b m -- | Read a page (do not render it) -- -pageRead :: Compiler Resource (Page String) -pageRead = getResourceString >>^ readPage +readPageCompiler :: Compiler Resource (Page String) +readPageCompiler = getResourceString >>^ readPage + +defaultPageCompiler :: Compiler Resource (Page String) +defaultPageCompiler = cached "Hakyll.Web.Page.defaultPageCompiler" $ + readPageCompiler >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc -- | Add a number of default metadata fields to a page. These fields include: -- diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs index 2880ece..23d98a4 100644 --- a/src/Hakyll/Web/Page/Metadata.hs +++ b/src/Hakyll/Web/Page/Metadata.hs @@ -2,6 +2,7 @@ -- module Hakyll.Web.Page.Metadata ( getField + , getFieldMaybe , setField , setFieldA , renderField @@ -31,7 +32,14 @@ import Hakyll.Web.Util.String getField :: String -- ^ Key -> Page a -- ^ Page -> String -- ^ Value -getField key = fromMaybe "" . M.lookup key . pageMetadata +getField key = fromMaybe "" . getFieldMaybe key + +-- | Get a field in a 'Maybe' wrapper +-- +getFieldMaybe :: String -- ^ Key + -> Page a -- ^ Page + -> Maybe String -- ^ Value, if found +getFieldMaybe key = M.lookup key . pageMetadata -- | Add a metadata field. If the field already exists, it is not overwritten. -- diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 308d06b..f225997 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -27,7 +27,7 @@ import Text.Pandoc import Hakyll.Core.Compiler import Hakyll.Web.FileType -import Hakyll.Web.Page +import Hakyll.Web.Page.Internal -- | Read a string using pandoc, with the default options -- diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 78ddbba..70b689a 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -51,7 +51,6 @@ module Hakyll.Web.Template import Control.Arrow import Data.Maybe (fromMaybe) -import qualified Data.Map as M import System.FilePath (takeExtension) import Text.Hamlet (HamletSettings, defaultHamletSettings) @@ -61,7 +60,8 @@ import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Web.Template.Internal import Hakyll.Web.Template.Read -import Hakyll.Web.Page +import Hakyll.Web.Page.Internal +import Hakyll.Web.Page.Metadata -- | Substitutes @$identifiers@ in the given @Template@ by values from the given -- "Page". When a key is not found, it is left as it is. You can specify @@ -73,7 +73,7 @@ applyTemplate template page = where substitute (Chunk chunk) = chunk substitute (Key key) = - fromMaybe ("$" ++ key ++ "$") $ M.lookup key $ toMap page + fromMaybe ("$" ++ key ++ "$") $ getFieldMaybe key page substitute (Escaped) = "$" -- | Apply a page as it's own template. This is often very useful to fill in -- cgit v1.2.3 From bc4fef81b7143d3b2035f3bd28fe89bea8dbc30d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 22:20:39 +0100 Subject: defaultRelativizeUrls → relativizeUrlsCompiler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web.hs | 13 +------------ src/Hakyll/Web/CompressCss.hs | 3 +-- src/Hakyll/Web/RelativizeUrls.hs | 19 ++++++++++++++++++- 3 files changed, 20 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index bd9ce31..72b22dd 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -3,14 +3,11 @@ module Hakyll.Web ( defaultTemplateRead , defaultTemplateReadWith - , defaultRelativizeUrls , defaultCopyFile , defaultApplyTemplate ) where -import Prelude hiding (id) -import Control.Category (id) -import Control.Arrow ((>>^), (&&&)) +import Control.Arrow ((>>^)) import Text.Hamlet (HamletSettings) @@ -20,14 +17,6 @@ import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Web.Page import Hakyll.Web.Template -import Hakyll.Web.RelativizeUrls -import Hakyll.Web.Util.String - -defaultRelativizeUrls :: Compiler (Page String) (Page String) -defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize - where - relativize Nothing = id - relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) defaultTemplateRead :: Compiler Resource Template defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ templateRead diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index 3e86e09..94ba9a9 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -14,8 +14,7 @@ import Hakyll.Core.Compiler import Hakyll.Core.ResourceProvider import Hakyll.Web.Util.String --- | Compiler form of 'compressCss' which automatically picks the right root --- path +-- | Compiler form of 'compressCss' -- compressCssCompiler :: Compiler Resource String compressCssCompiler = getResourceString >>^ compressCss diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs index 40a5847..1df4fea 100644 --- a/src/Hakyll/Web/RelativizeUrls.hs +++ b/src/Hakyll/Web/RelativizeUrls.hs @@ -15,14 +15,31 @@ -- > Funny zomgroflcopter -- module Hakyll.Web.RelativizeUrls - ( relativizeUrls + ( relativizeUrlsCompiler + , relativizeUrls ) where +import Prelude hiding (id) +import Control.Category (id) +import Control.Arrow ((&&&), (>>^)) import Data.List (isPrefixOf) import qualified Data.Set as S import Text.HTML.TagSoup +import Hakyll.Core.Compiler +import Hakyll.Web.Page +import Hakyll.Web.Util.String + +-- | Compiler form of 'compressCss' which automatically picks the right root +-- path +-- +relativizeUrlsCompiler :: Compiler (Page String) (Page String) +relativizeUrlsCompiler = getRoute &&& id >>^ uncurry relativize + where + relativize Nothing = id + relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) + -- | Relativize URL's in HTML -- relativizeUrls :: String -- ^ Path to the site root -- cgit v1.2.3 From 28a30caef08ab786bfa8b75d75f155a4e62b7280 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 22:39:20 +0100 Subject: defaultTemplateRead → templateCompiler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web.hs | 13 +------------ src/Hakyll/Web/Page.hs | 8 +++++--- src/Hakyll/Web/Template.hs | 17 +++++++++-------- 3 files changed, 15 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index 72b22dd..ec05afb 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -1,16 +1,12 @@ -- | Module exporting commonly used web-related functions -- module Hakyll.Web - ( defaultTemplateRead - , defaultTemplateReadWith - , defaultCopyFile + ( defaultCopyFile , defaultApplyTemplate ) where import Control.Arrow ((>>^)) -import Text.Hamlet (HamletSettings) - import Hakyll.Core.Compiler import Hakyll.Core.Writable import Hakyll.Core.Identifier @@ -18,13 +14,6 @@ import Hakyll.Core.ResourceProvider import Hakyll.Web.Page import Hakyll.Web.Template -defaultTemplateRead :: Compiler Resource Template -defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $ templateRead - -defaultTemplateReadWith :: HamletSettings -> Compiler Resource Template -defaultTemplateReadWith settings = cached "Hakyll.Web.defaultTemplateReadWith" $ - templateReadWith settings - defaultCopyFile :: Compiler Resource CopyFile defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 30578e9..c61008c 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -52,7 +52,7 @@ module Hakyll.Web.Page , fromMap , toMap , readPageCompiler - , defaultPageCompiler + , pageCompiler , addDefaultFields , sortByBaseName ) where @@ -97,8 +97,10 @@ toMap (Page m b) = M.insert "body" b m readPageCompiler :: Compiler Resource (Page String) readPageCompiler = getResourceString >>^ readPage -defaultPageCompiler :: Compiler Resource (Page String) -defaultPageCompiler = cached "Hakyll.Web.Page.defaultPageCompiler" $ +-- | Read a page, add default fields, substitute fields and render using pandoc +-- +pageCompiler :: Compiler Resource (Page String) +pageCompiler = cached "Hakyll.Web.Page.pageCompiler" $ readPageCompiler >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc -- | Add a number of default metadata fields to a page. These fields include: diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 70b689a..1a399b3 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -45,8 +45,8 @@ module Hakyll.Web.Template ( Template , applyTemplate , applySelf - , templateRead - , templateReadWith + , templateCompiler + , templateCompilerWith ) where import Control.Arrow @@ -86,14 +86,15 @@ applySelf page = applyTemplate (readTemplate $ pageBody page) page -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed -- as such. -- -templateRead :: Compiler Resource Template -templateRead = templateReadWith defaultHamletSettings +templateCompiler :: Compiler Resource Template +templateCompiler = templateCompilerWith defaultHamletSettings --- | Version of 'templateRead' that enables custom settings. +-- | Version of 'templateCompiler' that enables custom settings. -- -templateReadWith :: HamletSettings -> Compiler Resource Template -templateReadWith settings = - getIdentifier &&& getResourceString >>^ uncurry read' +templateCompilerWith :: HamletSettings -> Compiler Resource Template +templateCompilerWith settings = + cached "Hakyll.Web.Template.templateCompilerWith" $ + getIdentifier &&& getResourceString >>^ uncurry read' where read' identifier string = if takeExtension (toFilePath identifier) `elem` [".hml", ".hamlet"] -- cgit v1.2.3 From a5438d8d9284ba2855934fc13f318c8f2dff6db9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 22:46:43 +0100 Subject: defaultCopyFile → copyFileCompiler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll.hs | 2 ++ src/Hakyll/Core/CopyFile.hs | 29 +++++++++++++++++++++++++++++ src/Hakyll/Core/Writable.hs | 15 +-------------- src/Hakyll/Web.hs | 6 +----- 4 files changed, 33 insertions(+), 19 deletions(-) create mode 100644 src/Hakyll/Core/CopyFile.hs (limited to 'src') diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 64d5330..aaf36d4 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -2,6 +2,7 @@ -- module Hakyll ( module Hakyll.Core.Compiler + , module Hakyll.Core.CopyFile , module Hakyll.Core.Configuration , module Hakyll.Core.Identifier , module Hakyll.Core.Identifier.Pattern @@ -26,6 +27,7 @@ module Hakyll ) where import Hakyll.Core.Compiler +import Hakyll.Core.CopyFile import Hakyll.Core.Configuration import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern diff --git a/src/Hakyll/Core/CopyFile.hs b/src/Hakyll/Core/CopyFile.hs new file mode 100644 index 0000000..dbbaaa1 --- /dev/null +++ b/src/Hakyll/Core/CopyFile.hs @@ -0,0 +1,29 @@ +-- | Exports simple compilers to just copy files +-- +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +module Hakyll.Core.CopyFile + ( CopyFile (..) + , copyFileCompiler + ) where + +import Control.Arrow ((>>^)) +import System.Directory (copyFile) + +import Data.Typeable (Typeable) +import Data.Binary (Binary) + +import Hakyll.Core.ResourceProvider +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) + +instance Writable CopyFile where + write dst (CopyFile src) = copyFile src dst + +copyFileCompiler :: Compiler Resource CopyFile +copyFileCompiler = getIdentifier >>^ CopyFile . toFilePath diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs index db53d9a..a3fd421 100644 --- a/src/Hakyll/Core/Writable.hs +++ b/src/Hakyll/Core/Writable.hs @@ -1,18 +1,13 @@ -- | Describes writable items; items that can be saved to the disk -- -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, - DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} module Hakyll.Core.Writable ( Writable (..) - , CopyFile (..) ) where -import System.Directory (copyFile) import Data.Word (Word8) import qualified Data.ByteString as SB -import Data.Binary (Binary) -import Data.Typeable (Typeable) -- | Describes an item that can be saved to the disk -- @@ -25,11 +20,3 @@ instance Writable [Char] where instance Writable [Word8] where write p = SB.writeFile p . SB.pack - --- | Newtype construct around 'FilePath' which will copy the file directly --- -newtype CopyFile = CopyFile {unCopyFile :: FilePath} - deriving (Show, Eq, Ord, Binary, Typeable) - -instance Writable CopyFile where - write dst (CopyFile src) = copyFile src dst diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs index ec05afb..482cf6d 100644 --- a/src/Hakyll/Web.hs +++ b/src/Hakyll/Web.hs @@ -1,8 +1,7 @@ -- | Module exporting commonly used web-related functions -- module Hakyll.Web - ( defaultCopyFile - , defaultApplyTemplate + ( defaultApplyTemplate ) where import Control.Arrow ((>>^)) @@ -14,9 +13,6 @@ import Hakyll.Core.ResourceProvider import Hakyll.Web.Page import Hakyll.Web.Template -defaultCopyFile :: Compiler Resource CopyFile -defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath - defaultApplyTemplate :: Identifier -- ^ Template -> Compiler (Page String) (Page String) -- ^ Compiler defaultApplyTemplate identifier = require identifier (flip applyTemplate) -- cgit v1.2.3 From 03fb17ec6d7dc625e4faecdd4fdc778c998262c9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Feb 2011 22:48:15 +0100 Subject: defaultApplyTemplate → applyTemplateCompiler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Hakyll/Web.hs | 18 ------------------ 1 file changed, 18 deletions(-) delete mode 100644 src/Hakyll/Web.hs (limited to 'src') diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs deleted file mode 100644 index 482cf6d..0000000 --- a/src/Hakyll/Web.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | Module exporting commonly used web-related functions --- -module Hakyll.Web - ( defaultApplyTemplate - ) where - -import Control.Arrow ((>>^)) - -import Hakyll.Core.Compiler -import Hakyll.Core.Writable -import Hakyll.Core.Identifier -import Hakyll.Core.ResourceProvider -import Hakyll.Web.Page -import Hakyll.Web.Template - -defaultApplyTemplate :: Identifier -- ^ Template - -> Compiler (Page String) (Page String) -- ^ Compiler -defaultApplyTemplate identifier = require identifier (flip applyTemplate) -- cgit v1.2.3 From 7aac6ccd5dfc635ad77bc74781ab06b0b1b9fe5e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 18 Feb 2011 18:15:00 +0100 Subject: Add applyTemplateCompiler --- src/Hakyll/Web/Template.hs | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 1a399b3..5b38ba3 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -47,6 +47,7 @@ module Hakyll.Web.Template , applySelf , templateCompiler , templateCompilerWith + , applyTemplateCompiler ) where import Control.Arrow @@ -102,3 +103,7 @@ templateCompilerWith settings = then readHamletTemplateWith settings string -- Hakyll template else readTemplate string + +applyTemplateCompiler :: Identifier -- ^ Template + -> Compiler (Page String) (Page String) -- ^ Compiler +applyTemplateCompiler identifier = require identifier (flip applyTemplate) -- cgit v1.2.3 From 4c75843c81d83980ff5757520b2e3e93ad9084ca Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 18 Feb 2011 18:15:52 +0100 Subject: Fix inotify preview polling --- src/Hakyll.hs | 2 -- src/Hakyll/Main.hs | 12 +++---- src/Hakyll/Web/Preview/INotify.hs | 68 +++++++++++++++++---------------------- 3 files changed, 35 insertions(+), 47 deletions(-) (limited to 'src') diff --git a/src/Hakyll.hs b/src/Hakyll.hs index aaf36d4..1fe6147 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -12,7 +12,6 @@ module Hakyll , module Hakyll.Core.Util.File , module Hakyll.Core.Writable , module Hakyll.Main - , module Hakyll.Web , module Hakyll.Web.CompressCss , module Hakyll.Web.Feed , module Hakyll.Web.FileType @@ -37,7 +36,6 @@ import Hakyll.Core.Util.Arrow import Hakyll.Core.Util.File import Hakyll.Core.Writable import Hakyll.Main -import Hakyll.Web import Hakyll.Web.CompressCss import Hakyll.Web.Feed import Hakyll.Web.FileType diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 74097f7..8cec42e 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -6,10 +6,9 @@ module Hakyll.Main ) where import Control.Concurrent (forkIO) -import Control.Monad (when, forM_) +import Control.Monad (when) import System.Environment (getProgName, getArgs) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) -import qualified Data.Set as S import Hakyll.Core.Configuration import Hakyll.Core.Run @@ -87,16 +86,15 @@ preview configuration rules port = do -- Build once, keep the rule set ruleSet <- run configuration rules - -- Debug: show the resources used - forM_ (S.toList $ rulesResources ruleSet) $ putStrLn . show + -- Get the resource list and a callback for the preview poll + let resources = rulesResources ruleSet + callback = build configuration rules - {- -- Fork a thread polling for changes - _ <- forkIO $ previewPoll configuration "." $ build configuration rules + _ <- forkIO $ previewPoll configuration resources callback -- Run the server in the main thread server configuration port - -} -- | Rebuild the site -- diff --git a/src/Hakyll/Web/Preview/INotify.hs b/src/Hakyll/Web/Preview/INotify.hs index fb3a7de..5bee981 100644 --- a/src/Hakyll/Web/Preview/INotify.hs +++ b/src/Hakyll/Web/Preview/INotify.hs @@ -4,57 +4,49 @@ module Hakyll.Web.Preview.INotify ( previewPoll ) where -import Control.Monad (forM_, when, unless) -import System.Directory (doesDirectoryExist) -import System.FilePath (()) -import Data.List (isPrefixOf) +import Control.Monad (forM_, when) +import Data.Set (Set) +import qualified Data.Set as S +import System.FilePath (takeDirectory) import System.INotify -import Hakyll.Core.Util.File import Hakyll.Core.Configuration +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Identifier -- | Calls the given callback when the directory tree changes -- previewPoll :: HakyllConfiguration -- ^ Configuration - -> FilePath -- ^ Root directory + -> Set Resource -- ^ Resources to watch -> IO () -- ^ Action called when something changes -> IO () -- ^ Can block forever -previewPoll conf directory callback = do +previewPoll _ resources callback = do -- Initialize inotify inotify <- initINotify - -- Start by watching all directories - contents <- getRecursiveContents True directory - forM_ contents $ \file -> do - isDir <- doesDirectoryExist file - when isDir $ watchDirectory conf inotify file callback + let -- A set of file paths + paths = S.map (toFilePath . unResource) resources --- | Start watching a directory recursively: when another directory is created --- inside this directory, start watching that one as well... --- -watchDirectory :: HakyllConfiguration -- ^ Configuration - -> INotify -- ^ INotify handle - -> FilePath -- ^ Directory to watch - -> IO () -- ^ Callback - -> IO () -- ^ No result -watchDirectory conf inotify path callback = - unless (isFileInternal conf path) $ do - _ <- addWatch inotify interesting path $ \event -> do - putStrLn $ "Triggered: " ++ show event - callback' inotify path event + -- A list of directories + directories = S.toList $ S.map (notEmpty . takeDirectory) paths + + -- Make sure a directory name is not empty + notEmpty "" = "." + notEmpty x = x + + -- Execute the callback when path is known + ifResource path = when (path `S.member` paths) $ do + putStrLn $ "Changed: " ++ path + callback + + -- Add a watcher for every directory + forM_ directories $ \directory -> do + putStrLn $ "Adding watch for " ++ directory + _ <- addWatch inotify interesting directory $ \e -> case e of + (Modified _ (Just p)) -> ifResource p + _ -> return () return () where - callback' i p (Created True n) = watchDirectory conf i (p n) callback - callback' _ _ (Created _ p) = whenProper $ Just p - callback' _ _ (Modified _ p) = whenProper p - callback' _ _ (MovedOut _ p _) = whenProper $ Just p - callback' _ _ (MovedIn _ p _) = whenProper $ Just p - callback' _ _ (Deleted _ p) = whenProper $ Just p - callback' _ _ _ = return () - - interesting = [Modify, Create, Move, Delete] - - -- Call the callback only for proper files - whenProper Nothing = return () - whenProper (Just f) = unless ("." `isPrefixOf` f) callback + -- Interesting events + interesting = [Modify] -- cgit v1.2.3 From b89aad6178b151a859469a3ae5c6ed4e6f57cad6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 19 Feb 2011 10:39:29 +0100 Subject: Include the directory in the path --- src/Hakyll/Web/Preview/INotify.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Preview/INotify.hs b/src/Hakyll/Web/Preview/INotify.hs index 5bee981..9af6def 100644 --- a/src/Hakyll/Web/Preview/INotify.hs +++ b/src/Hakyll/Web/Preview/INotify.hs @@ -7,7 +7,7 @@ module Hakyll.Web.Preview.INotify import Control.Monad (forM_, when) import Data.Set (Set) import qualified Data.Set as S -import System.FilePath (takeDirectory) +import System.FilePath (takeDirectory, ()) import System.INotify @@ -28,10 +28,12 @@ previewPoll _ resources callback = do let -- A set of file paths paths = S.map (toFilePath . unResource) resources - -- A list of directories + -- A list of directories. Run it through a set so we have every + -- directory only once. directories = S.toList $ S.map (notEmpty . takeDirectory) paths - -- Make sure a directory name is not empty + -- Problem: we can't add a watcher for "". So we make sure a directory + -- name is not empty notEmpty "" = "." notEmpty x = x @@ -43,10 +45,7 @@ previewPoll _ resources callback = do -- Add a watcher for every directory forM_ directories $ \directory -> do putStrLn $ "Adding watch for " ++ directory - _ <- addWatch inotify interesting directory $ \e -> case e of - (Modified _ (Just p)) -> ifResource p + _ <- addWatch inotify [Modify] directory $ \e -> case e of + (Modified _ (Just p)) -> ifResource $ directory p _ -> return () return () - where - -- Interesting events - interesting = [Modify] -- cgit v1.2.3 From f04efbad3ed6f5cbc215f8aa72b1bd0203712768 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 19 Feb 2011 17:04:50 +0100 Subject: Preview/INotify now works --- src/Hakyll/Core/Configuration.hs | 25 +++++++++++++++++++++- .../Core/ResourceProvider/FileResourceProvider.hs | 8 ++++--- src/Hakyll/Core/Run.hs | 2 +- src/Hakyll/Main.hs | 4 +++- src/Hakyll/Web/Preview/INotify.hs | 7 +++--- 5 files changed, 37 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs index 3a7456f..242b68f 100644 --- a/src/Hakyll/Core/Configuration.hs +++ b/src/Hakyll/Core/Configuration.hs @@ -5,12 +5,26 @@ module Hakyll.Core.Configuration , defaultHakyllConfiguration ) where +import System.FilePath (takeFileName) +import Data.List (isPrefixOf, isSuffixOf) + data HakyllConfiguration = HakyllConfiguration { -- | Directory in which the output written destinationDirectory :: FilePath , -- | Directory where hakyll's internal store is kept storeDirectory :: FilePath - } deriving (Show) + , -- | Function to determine ignored files + -- + -- In 'defaultHakyllConfiguration', the following files are ignored: + -- + -- * files starting with a @.@ + -- + -- * files ending with a @~@ + -- + -- * files ending with @.swp@ + -- + ignoreFile :: FilePath -> Bool + } -- | Default configuration for a hakyll application -- @@ -18,4 +32,13 @@ defaultHakyllConfiguration :: HakyllConfiguration defaultHakyllConfiguration = HakyllConfiguration { destinationDirectory = "_site" , storeDirectory = "_cache" + , ignoreFile = ignoreFile' } + where + ignoreFile' path + | "." `isPrefixOf` fileName = True + | "~" `isSuffixOf` fileName = True + | ".swp" `isSuffixOf` fileName = True + | otherwise = False + where + fileName = takeFileName path diff --git a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs index 2f040b3..0d89b21 100644 --- a/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs +++ b/src/Hakyll/Core/ResourceProvider/FileResourceProvider.hs @@ -11,13 +11,15 @@ import qualified Data.ByteString.Lazy as LB import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier import Hakyll.Core.Util.File +import Hakyll.Core.Configuration -- | Create a filesystem-based 'ResourceProvider' -- -fileResourceProvider :: IO ResourceProvider -fileResourceProvider = do +fileResourceProvider :: HakyllConfiguration -> IO ResourceProvider +fileResourceProvider configuration = do -- Retrieve a list of identifiers - list <- map parseIdentifier <$> getRecursiveContents False "." + list <- map parseIdentifier . filter (not . ignoreFile configuration) <$> + getRecursiveContents False "." -- Construct a resource provider return ResourceProvider diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index b59fdac..b4c69f1 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -37,7 +37,7 @@ import Hakyll.Core.Configuration run :: HakyllConfiguration -> Rules -> IO RuleSet run configuration rules = do store <- makeStore $ storeDirectory configuration - provider <- fileResourceProvider + provider <- fileResourceProvider configuration let ruleSet = runRules rules provider compilers = rulesCompilers ruleSet diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 8cec42e..13ec0dd 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -88,7 +88,9 @@ preview configuration rules port = do -- Get the resource list and a callback for the preview poll let resources = rulesResources ruleSet - callback = build configuration rules + callback = do + putStrLn "In TL callback" + build configuration rules -- Fork a thread polling for changes _ <- forkIO $ previewPoll configuration resources callback diff --git a/src/Hakyll/Web/Preview/INotify.hs b/src/Hakyll/Web/Preview/INotify.hs index 9af6def..e21b767 100644 --- a/src/Hakyll/Web/Preview/INotify.hs +++ b/src/Hakyll/Web/Preview/INotify.hs @@ -8,6 +8,7 @@ import Control.Monad (forM_, when) import Data.Set (Set) import qualified Data.Set as S import System.FilePath (takeDirectory, ()) +import Data.List (isPrefixOf) import System.INotify @@ -38,9 +39,9 @@ previewPoll _ resources callback = do notEmpty x = x -- Execute the callback when path is known - ifResource path = when (path `S.member` paths) $ do - putStrLn $ "Changed: " ++ path - callback + ifResource path = + let path' = if "./" `isPrefixOf` path then drop 2 path else path + in when (path' `S.member` paths) callback -- Add a watcher for every directory forM_ directories $ \directory -> do -- cgit v1.2.3 From 256cc760bae2e8bc4238fb8b903ffc92a36d7db9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2011 02:56:57 +0100 Subject: Add pretty, thread-safe logger --- src/Hakyll/Core/Compiler.hs | 2 -- src/Hakyll/Core/Logger.hs | 82 +++++++++++++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Run.hs | 80 +++++++++++++++++++++++++------------------ 3 files changed, 129 insertions(+), 35 deletions(-) create mode 100644 src/Hakyll/Core/Logger.hs (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 8d713c2..7d2d116 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -253,8 +253,6 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do identifier <- compilerIdentifier <$> ask store <- compilerStore <$> ask modified <- compilerResourceModified <$> ask - liftIO $ putStrLn $ - show identifier ++ ": " ++ if modified then "MODIFIED" else "OK" if modified then do v <- unCompilerM $ j $ Resource identifier liftIO $ storeSet store name identifier v diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs new file mode 100644 index 0000000..c5b8531 --- /dev/null +++ b/src/Hakyll/Core/Logger.hs @@ -0,0 +1,82 @@ +-- | Produce pretty, thread-safe logs +-- +{-# LANGUAGE BangPatterns #-} +module Hakyll.Core.Logger + ( Logger + , makeLogger + , flushLogger + , section + , timed + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan) +import Control.Concurrent.MVar.Strict (MVar, newEmptyMVar, takeMVar, putMVar) +import Text.Printf (printf) + +import Data.Time (getCurrentTime, diffUTCTime) + +-- | Logger structure. Very complicated. +-- +data Logger = Logger + { loggerChan :: Chan (Maybe String) -- Nothing marks the end + , loggerSync :: MVar () -- Used for sync on quit + } + +-- | Create a new logger +-- +makeLogger :: IO Logger +makeLogger = do + logger <- Logger <$> newChan <*> newEmptyMVar + _ <- forkIO $ loggerThread logger + return logger + where + loggerThread logger = do + msg <- readChan $ loggerChan logger + case msg of + -- Stop: sync + Nothing -> putMVar (loggerSync logger) () + -- Print and continue + Just m -> do + putStrLn m + loggerThread logger + +-- | Flush the logger (blocks until flushed) +-- +flushLogger :: Logger -> IO () +flushLogger logger = do + writeChan (loggerChan logger) Nothing + () <- takeMVar $ loggerSync logger + return () + +-- | Send a raw message to the logger +-- +message :: Logger -> String -> IO () +message logger = writeChan (loggerChan logger) . Just + +-- | Start a section in the log +-- +section :: MonadIO m + => Logger -- ^ Logger + -> String -- ^ Section name + -> m () -- ^ No result +section logger = liftIO . message logger + +-- | Execute a monadic action and log the duration +-- +timed :: MonadIO m + => Logger -- ^ Logger + -> String -- ^ Message + -> m a -- ^ Action + -> m a -- ^ Timed and logged action +timed logger msg action = do + start <- liftIO getCurrentTime + !result <- action + stop <- liftIO getCurrentTime + let diff = fromEnum $ diffUTCTime stop start + ms = diff `div` 10 ^ (9 :: Int) + formatted = printf " [%4dms] %s" ms msg + liftIO $ message logger formatted + return result diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index b4c69f1..54c22c2 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -10,7 +10,7 @@ import Control.Monad (filterM) import Control.Monad.Trans (liftIO) import Control.Applicative (Applicative, (<$>)) import Control.Monad.Reader (ReaderT, runReaderT, ask) -import Control.Monad.State (StateT, evalStateT, get, modify) +import Control.Monad.State.Strict (StateT, evalStateT, get, modify) import Control.Arrow ((&&&)) import qualified Data.Map as M import Data.Monoid (mempty, mappend) @@ -31,25 +31,36 @@ import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable import Hakyll.Core.Store import Hakyll.Core.Configuration +import Hakyll.Core.Logger -- | Run all rules needed, return the rule set used -- run :: HakyllConfiguration -> Rules -> IO RuleSet run configuration rules = do - store <- makeStore $ storeDirectory configuration - provider <- fileResourceProvider configuration + logger <- makeLogger + + section logger "Initialising" + store <- timed logger "Creating store" $ + makeStore $ storeDirectory configuration + provider <- timed logger "Creating provider" $ + fileResourceProvider configuration + let ruleSet = runRules rules provider compilers = rulesCompilers ruleSet -- Extract the reader/state reader = unRuntime $ addNewCompilers [] compilers - state' = runReaderT reader $ env ruleSet provider store + state' = runReaderT reader $ env logger ruleSet provider store evalStateT state' state + + -- Flush and return + flushLogger logger return ruleSet where - env ruleSet provider store = RuntimeEnvironment - { hakyllConfiguration = configuration + env logger ruleSet provider store = RuntimeEnvironment + { hakyllLogger = logger + , hakyllConfiguration = configuration , hakyllRoutes = rulesRoutes ruleSet , hakyllResourceProvider = provider , hakyllStore = store @@ -61,7 +72,8 @@ run configuration rules = do } data RuntimeEnvironment = RuntimeEnvironment - { hakyllConfiguration :: HakyllConfiguration + { hakyllLogger :: Logger + , hakyllConfiguration :: HakyllConfiguration , hakyllRoutes :: Routes , hakyllResourceProvider :: ResourceProvider , hakyllStore :: Store @@ -96,6 +108,8 @@ addNewCompilers :: [(Identifier, Compiler () CompileRule)] -> Runtime () addNewCompilers oldCompilers newCompilers = Runtime $ do -- Get some information + logger <- hakyllLogger <$> ask + section logger "Adding new compilers" provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask @@ -115,31 +129,31 @@ addNewCompilers oldCompilers newCompilers = Runtime $ do -- Find the old graph and append the new graph to it. This forms the -- complete graph - completeGraph <- mappend currentGraph . hakyllGraph <$> get - - -- Check which items are up-to-date. This only needs to happen for the new - -- compilers - oldModified <- hakyllModified <$> get - newModified <- liftIO $ modified provider store $ map fst newCompilers + completeGraph <- timed logger "Creating graph" $ + mappend currentGraph . hakyllGraph <$> get - let modified' = oldModified `S.union` newModified - - -- Find obsolete items. Every item that is reachable from a modified - -- item is considered obsolete. From these obsolete items, we are only - -- interested in ones that are in the current subgraph. - obsolete = S.filter (`member` currentGraph) - $ reachableNodes modified' $ reverse completeGraph + orderedCompilers <- timed logger "Solving dependencies" $ do + -- Check which items are up-to-date. This only needs to happen for the new + -- compilers + oldModified <- hakyllModified <$> get + newModified <- liftIO $ modified provider store $ map fst newCompilers - -- Solve the graph and retain only the obsolete items - ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph + let modified' = oldModified `S.union` newModified + + -- Find obsolete items. Every item that is reachable from a modified + -- item is considered obsolete. From these obsolete items, we are only + -- interested in ones that are in the current subgraph. + obsolete = S.filter (`member` currentGraph) + $ reachableNodes modified' $ reverse completeGraph - -- Join the order with the compilers again - orderedCompilers = map (id &&& (compilerMap M.!)) ordered + -- Solve the graph and retain only the obsolete items + ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph - liftIO $ putStrLn "Adding compilers..." - liftIO $ putStrLn $ "Added: " ++ show (map fst orderedCompilers) + -- Update the state + modify $ updateState modified' completeGraph - modify $ updateState modified' completeGraph + -- Join the order with the compilers again + return $ map (id &&& (compilerMap M.!)) ordered -- Now run the ordered list of compilers unRuntime $ runCompilers orderedCompilers @@ -157,33 +171,33 @@ runCompilers :: [(Identifier, Compiler () CompileRule)] runCompilers [] = return () runCompilers ((id', compiler) : compilers) = Runtime $ do -- Obtain information + logger <- hakyllLogger <$> ask routes <- hakyllRoutes <$> ask provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask modified' <- hakyllModified <$> get + section logger $ "Compiling " ++ show id' + let -- Check if the resource was modified isModified = id' `S.member` modified' -- Run the compiler - result <- liftIO $ runCompiler compiler id' provider routes store isModified - liftIO $ putStrLn $ "Generated target: " ++ show id' + result <- timed logger "Compiling item" $ + liftIO $ runCompiler compiler id' provider routes store isModified case result of -- Compile rule for one item, easy stuff CompileRule compiled -> do case runRoutes routes id' of Nothing -> return () - Just url -> do - liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ url + Just url -> timed logger ("Routing to " ++ url) $ do destination <- destinationDirectory . hakyllConfiguration <$> ask let path = destination url liftIO $ makeDirectories path liftIO $ write path compiled - liftIO $ putStrLn "" - -- Continue for the remaining compilers unRuntime $ runCompilers compilers -- cgit v1.2.3 From 678f18973f48975712649c8e209199f5c86c0e73 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2011 10:56:04 +0100 Subject: Quit/Sync bug fix --- src/Hakyll/Core/Logger.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs index c5b8531..8f5a4f9 100644 --- a/src/Hakyll/Core/Logger.hs +++ b/src/Hakyll/Core/Logger.hs @@ -9,6 +9,7 @@ module Hakyll.Core.Logger , timed ) where +import Control.Monad (forever) import Control.Monad.Trans (MonadIO, liftIO) import Control.Applicative ((<$>), (<*>)) import Control.Concurrent (forkIO) @@ -33,15 +34,13 @@ makeLogger = do _ <- forkIO $ loggerThread logger return logger where - loggerThread logger = do + loggerThread logger = forever $ do msg <- readChan $ loggerChan logger case msg of -- Stop: sync Nothing -> putMVar (loggerSync logger) () -- Print and continue - Just m -> do - putStrLn m - loggerThread logger + Just m -> putStrLn m -- | Flush the logger (blocks until flushed) -- -- cgit v1.2.3 From 12a0e5387bc74dd3043513d12698c3f2a25fa371 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2011 11:42:19 +0100 Subject: Add Unix filters as compilers --- src/Hakyll.hs | 2 ++ src/Hakyll/Core/UnixFilter.hs | 66 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 68 insertions(+) create mode 100644 src/Hakyll/Core/UnixFilter.hs (limited to 'src') diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 1fe6147..b459507 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -8,6 +8,7 @@ module Hakyll , module Hakyll.Core.Identifier.Pattern , module Hakyll.Core.Routes , module Hakyll.Core.Rules + , module Hakyll.Core.UnixFilter , module Hakyll.Core.Util.Arrow , module Hakyll.Core.Util.File , module Hakyll.Core.Writable @@ -32,6 +33,7 @@ import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Routes import Hakyll.Core.Rules +import Hakyll.Core.UnixFilter import Hakyll.Core.Util.Arrow import Hakyll.Core.Util.File import Hakyll.Core.Writable diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs new file mode 100644 index 0000000..736acee --- /dev/null +++ b/src/Hakyll/Core/UnixFilter.hs @@ -0,0 +1,66 @@ +-- | A Compiler that supports unix filters. +-- +module Hakyll.Core.UnixFilter + ( unixFilter + ) where + +import Control.Concurrent (forkIO) +import System.IO (hPutStr, hClose, hGetContents) +import System.Posix.Process (executeFile, forkProcess) +import System.Posix.IO ( dupTo, createPipe, stdInput + , stdOutput, closeFd, fdToHandle + ) + +import Hakyll.Core.Compiler + +-- | Use a unix filter as compiler. For example, we could use the 'rev' program +-- as a compiler. +-- +-- > rev :: Compiler Resource String +-- > rev = getResourceString >>> unixFilter "rev" [] +-- +-- A more realistic example: one can use this to call, for example, the sass +-- compiler on CSS files. More information about sass can be found here: +-- +-- +-- +-- The code is fairly straightforward, given that we use @.scss@ for sass: +-- +-- > route "style.scss" $ setExtension "css" +-- > compile "style.scss" $ +-- > getResourceString >>> unixFilter "sass" ["-s", "--scss"] +-- > >>> arr compressCss +-- +unixFilter :: String -- ^ Program name + -> [String] -- ^ Program args + -> Compiler String String -- ^ Resulting compiler +unixFilter programName args = unsafeCompiler $ \input -> do + -- Create pipes + (stdinRead, stdinWrite) <- createPipe + (stdoutRead, stdoutWrite) <- createPipe + + -- Fork the child + _ <- forkProcess $ do + -- Copy our pipes over the regular stdin/stdout + _ <- dupTo stdinRead stdInput + _ <- dupTo stdoutWrite stdOutput + + -- Close the now unneeded file descriptors in the child + mapM_ closeFd [stdinWrite, stdoutRead, stdinRead, stdoutWrite] + + -- Execute the program + _ <- executeFile programName True args Nothing + return () + + -- On the parent side, close the client-side FDs. + mapM_ closeFd [stdinRead, stdoutWrite] + + -- Write the input to the child pipe + _ <- forkIO $ do + stdinWriteHandle <- fdToHandle stdinWrite + hPutStr stdinWriteHandle input + hClose stdinWriteHandle + + -- Receive the output from the child + stdoutReadHandle <- fdToHandle stdoutRead + hGetContents stdoutReadHandle -- cgit v1.2.3 From 8b57ab509f9fbf7bb2058251beb60f39e8b476ca Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2011 13:02:35 +0100 Subject: Add logger to Compiler monad --- src/Hakyll/Core/Compiler.hs | 17 +++++++++++++++-- src/Hakyll/Core/Compiler/Internal.hs | 7 ++++++- src/Hakyll/Core/Run.hs | 4 ++-- src/Hakyll/Core/UnixFilter.hs | 12 +++++++++++- 4 files changed, 34 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 7d2d116..d6090e9 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -102,6 +102,7 @@ module Hakyll.Core.Compiler , cached , unsafeCompiler , mapCompiler + , timedCompiler ) where import Prelude hiding ((.), id) @@ -124,6 +125,7 @@ import Hakyll.Core.Compiler.Internal import Hakyll.Core.Store import Hakyll.Core.Rules.Internal import Hakyll.Core.Routes +import Hakyll.Core.Logger -- | Run a compiler, yielding the resulting target and it's dependencies. This -- version of 'runCompilerJob' also stores the result @@ -134,10 +136,12 @@ runCompiler :: Compiler () CompileRule -- ^ Compiler to run -> Routes -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? + -> Logger -- ^ Logger -> IO CompileRule -- ^ Resulting item -runCompiler compiler identifier provider routes store modified = do +runCompiler compiler identifier provider routes store modified logger = do -- Run the compiler job - result <- runCompilerJob compiler identifier provider routes store modified + result <- + runCompilerJob compiler identifier provider routes store modified logger -- Inspect the result case result of @@ -274,3 +278,12 @@ unsafeCompiler f = fromJob $ CompilerM . liftIO . f mapCompiler :: Compiler a b -> Compiler [a] [b] mapCompiler (Compiler d j) = Compiler d $ mapM j + +-- | Log and time a compiler +-- +timedCompiler :: String -- ^ Message + -> Compiler a b -- ^ Compiler to time + -> Compiler a b -- ^ Resulting compiler +timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do + logger <- compilerLogger <$> ask + timed logger msg $ unCompilerM $ j x diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index a524a66..30a391f 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -26,6 +26,7 @@ import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Core.Store import Hakyll.Core.Routes +import Hakyll.Core.Logger -- | A set of dependencies -- @@ -44,6 +45,8 @@ data CompilerEnvironment = CompilerEnvironment compilerStore :: Store , -- | Flag indicating if the underlying resource was modified compilerResourceModified :: Bool + , -- | Logger + compilerLogger :: Logger } -- | The compiler monad @@ -91,8 +94,9 @@ runCompilerJob :: Compiler () a -- ^ Compiler to run -> Routes -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? + -> Logger -- ^ Logger -> IO a -runCompilerJob compiler identifier provider route store modified = +runCompilerJob compiler identifier provider route store modified logger = runReaderT (unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment @@ -101,6 +105,7 @@ runCompilerJob compiler identifier provider route store modified = , compilerRoutes = route , compilerStore = store , compilerResourceModified = modified + , compilerLogger = logger } runCompilerDependencies :: Compiler () a diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 54c22c2..42db80a 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -183,8 +183,8 @@ runCompilers ((id', compiler) : compilers) = Runtime $ do isModified = id' `S.member` modified' -- Run the compiler - result <- timed logger "Compiling item" $ - liftIO $ runCompiler compiler id' provider routes store isModified + result <- timed logger "Total compile time" $ liftIO $ + runCompiler compiler id' provider routes store isModified logger case result of -- Compile rule for one item, easy stuff diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs index 736acee..ee4b6cd 100644 --- a/src/Hakyll/Core/UnixFilter.hs +++ b/src/Hakyll/Core/UnixFilter.hs @@ -34,7 +34,17 @@ import Hakyll.Core.Compiler unixFilter :: String -- ^ Program name -> [String] -- ^ Program args -> Compiler String String -- ^ Resulting compiler -unixFilter programName args = unsafeCompiler $ \input -> do +unixFilter programName args = + timedCompiler ("Executing external program " ++ programName) $ + unsafeCompiler $ \input -> unixFilterIO programName args input + +-- | Internally used function +-- +unixFilterIO :: String + -> [String] + -> String + -> IO String +unixFilterIO programName args input = do -- Create pipes (stdinRead, stdinWrite) <- createPipe (stdoutRead, stdoutWrite) <- createPipe -- cgit v1.2.3 From 917829539cfe61a55bb1dd16bf91b00011ce8dd2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2011 13:15:11 +0100 Subject: Add report function to logger --- src/Hakyll/Core/Compiler.hs | 2 ++ src/Hakyll/Core/Logger.hs | 9 +++++++++ 2 files changed, 11 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index d6090e9..e4922dd 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -254,9 +254,11 @@ cached :: (Binary a, Typeable a, Writable a) -> Compiler Resource a -> Compiler Resource a cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do + logger <- compilerLogger <$> ask identifier <- compilerIdentifier <$> ask store <- compilerStore <$> ask modified <- compilerResourceModified <$> ask + report logger $ "Checking cache: " ++ if modified then "modified" else "OK" if modified then do v <- unCompilerM $ j $ Resource identifier liftIO $ storeSet store name identifier v diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs index 8f5a4f9..720dee0 100644 --- a/src/Hakyll/Core/Logger.hs +++ b/src/Hakyll/Core/Logger.hs @@ -7,6 +7,7 @@ module Hakyll.Core.Logger , flushLogger , section , timed + , report ) where import Control.Monad (forever) @@ -79,3 +80,11 @@ timed logger msg action = do formatted = printf " [%4dms] %s" ms msg liftIO $ message logger formatted return result + +-- | Log something at the same level as 'timed', but without the timing +-- +report :: MonadIO m + => Logger -- ^ Logger + -> String -- ^ Message + -> m () -- ^ No result +report logger msg = liftIO $ message logger $ " [ ] " ++ msg -- cgit v1.2.3 From 371c28cb1a7976740f104b0737b6b9c37c08b72f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2011 13:35:20 +0100 Subject: Implement interval-based preview --- src/Hakyll/Web/Preview/Interval.hs | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 src/Hakyll/Web/Preview/Interval.hs (limited to 'src') diff --git a/src/Hakyll/Web/Preview/Interval.hs b/src/Hakyll/Web/Preview/Interval.hs new file mode 100644 index 0000000..5ab90e5 --- /dev/null +++ b/src/Hakyll/Web/Preview/Interval.hs @@ -0,0 +1,36 @@ +-- | Interval-based implementation of preview polling, for the platforms which +-- are not supported by inotify. +-- +module Hakyll.Web.Preview.Interval + ( previewPoll + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import System.Time (getClockTime) +import Data.Set (Set) +import qualified Data.Set as S +import System.Directory (getModificationTime) + +import Hakyll.Core.Configuration +import Hakyll.Core.Identifier +import Hakyll.Core.ResourceProvider + +-- | A preview thread that periodically recompiles the site. +-- +previewPoll :: HakyllConfiguration -- ^ Configuration + -> Set Resource -- ^ Resources to watch + -> IO () -- ^ Action called when something changes + -> IO () -- ^ Can block forever +previewPoll _ resources callback = do + let files = map (toFilePath . unResource) $ S.toList resources + time <- getClockTime + loop files time + where + delay = 1000000 + loop files time = do + threadDelay delay + modified <- any (time <) <$> mapM getModificationTime files + when modified callback + loop files =<< getClockTime -- cgit v1.2.3 From 5abc3d87e234c2f92b6c5481200d1f813ca2ce6f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Feb 2011 10:11:55 +0100 Subject: Add cabal flag for inotify --- hakyll.cabal | 21 ++++++++++--- src-inotify/Hakyll/Web/Preview/Poll.hs | 52 +++++++++++++++++++++++++++++++++ src-interval/Hakyll/Web/Preview/Poll.hs | 36 +++++++++++++++++++++++ src/Hakyll/Main.hs | 2 +- src/Hakyll/Web/Preview/INotify.hs | 52 --------------------------------- src/Hakyll/Web/Preview/Interval.hs | 36 ----------------------- 6 files changed, 106 insertions(+), 93 deletions(-) create mode 100644 src-inotify/Hakyll/Web/Preview/Poll.hs create mode 100644 src-interval/Hakyll/Web/Preview/Poll.hs delete mode 100644 src/Hakyll/Web/Preview/INotify.hs delete mode 100644 src/Hakyll/Web/Preview/Interval.hs (limited to 'src') diff --git a/hakyll.cabal b/hakyll.cabal index 57c6066..34d9cc2 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 2.4.1 +Version: 3.0.0.0 Synopsis: A simple static site generator library. Description: A simple static site generator library, mainly aimed at @@ -24,9 +24,20 @@ source-repository head type: git location: git://github.com/jaspervdj/Hakyll.git +flag inotify + description: Use the inotify bindings for the preview server. Better, but + only works on Linux. + default: False + library ghc-options: -Wall hs-source-dirs: src + + if flag(inotify) + hs-source-dirs: src-inotify + else + hs-source-dirs: src-interval + build-depends: base >= 4 && < 5, filepath == 1.*, directory == 1.*, @@ -47,12 +58,14 @@ library utf8-string >= 0.3, hinotify >= 0.3, tagsoup >= 0.12, - hopenssl >= 1.4 + hopenssl >= 1.4, + unix >= 2.4, + strict-concurrency >= 0.2 exposed-modules: Hakyll Hakyll.Main Hakyll.Web.Util.String Hakyll.Web.Preview.Server - Hakyll.Web.Preview.INotify + Hakyll.Web.Preview.Poll Hakyll.Web.CompressCss Hakyll.Web.Template Hakyll.Web.Feed @@ -64,10 +77,10 @@ library Hakyll.Web.RelativizeUrls Hakyll.Web.Page.Read Hakyll.Web.Page.Metadata - Hakyll.Web Hakyll.Core.ResourceProvider.FileResourceProvider Hakyll.Core.Configuration Hakyll.Core.Identifier.Pattern + Hakyll.Core.UnixFilter Hakyll.Core.Util.Arrow Hakyll.Core.Util.File Hakyll.Core.ResourceProvider diff --git a/src-inotify/Hakyll/Web/Preview/Poll.hs b/src-inotify/Hakyll/Web/Preview/Poll.hs new file mode 100644 index 0000000..69370ac --- /dev/null +++ b/src-inotify/Hakyll/Web/Preview/Poll.hs @@ -0,0 +1,52 @@ +-- | Filesystem polling with an inotify backend. Works only on linux. +-- +module Hakyll.Web.Preview.Poll + ( previewPoll + ) where + +import Control.Monad (forM_, when) +import Data.Set (Set) +import qualified Data.Set as S +import System.FilePath (takeDirectory, ()) +import Data.List (isPrefixOf) + +import System.INotify + +import Hakyll.Core.Configuration +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Identifier + +-- | Calls the given callback when the directory tree changes +-- +previewPoll :: HakyllConfiguration -- ^ Configuration + -> Set Resource -- ^ Resources to watch + -> IO () -- ^ Action called when something changes + -> IO () -- ^ Can block forever +previewPoll _ resources callback = do + -- Initialize inotify + inotify <- initINotify + + let -- A set of file paths + paths = S.map (toFilePath . unResource) resources + + -- A list of directories. Run it through a set so we have every + -- directory only once. + directories = S.toList $ S.map (notEmpty . takeDirectory) paths + + -- Problem: we can't add a watcher for "". So we make sure a directory + -- name is not empty + notEmpty "" = "." + notEmpty x = x + + -- Execute the callback when path is known + ifResource path = + let path' = if "./" `isPrefixOf` path then drop 2 path else path + in when (path' `S.member` paths) callback + + -- Add a watcher for every directory + forM_ directories $ \directory -> do + putStrLn $ "Adding watch for " ++ directory + _ <- addWatch inotify [Modify] directory $ \e -> case e of + (Modified _ (Just p)) -> ifResource $ directory p + _ -> return () + return () diff --git a/src-interval/Hakyll/Web/Preview/Poll.hs b/src-interval/Hakyll/Web/Preview/Poll.hs new file mode 100644 index 0000000..ec6df0c --- /dev/null +++ b/src-interval/Hakyll/Web/Preview/Poll.hs @@ -0,0 +1,36 @@ +-- | Interval-based implementation of preview polling, for the platforms which +-- are not supported by inotify. +-- +module Hakyll.Web.Preview.Poll + ( previewPoll + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import System.Time (getClockTime) +import Data.Set (Set) +import qualified Data.Set as S +import System.Directory (getModificationTime) + +import Hakyll.Core.Configuration +import Hakyll.Core.Identifier +import Hakyll.Core.ResourceProvider + +-- | A preview thread that periodically recompiles the site. +-- +previewPoll :: HakyllConfiguration -- ^ Configuration + -> Set Resource -- ^ Resources to watch + -> IO () -- ^ Action called when something changes + -> IO () -- ^ Can block forever +previewPoll _ resources callback = do + let files = map (toFilePath . unResource) $ S.toList resources + time <- getClockTime + loop files time + where + delay = 1000000 + loop files time = do + threadDelay delay + modified <- any (time <) <$> mapM getModificationTime files + when modified callback + loop files =<< getClockTime diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 13ec0dd..a44d9fa 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -14,7 +14,7 @@ import Hakyll.Core.Configuration import Hakyll.Core.Run import Hakyll.Core.Rules import Hakyll.Core.Rules.Internal -import Hakyll.Web.Preview.INotify +import Hakyll.Web.Preview.Poll import Hakyll.Web.Preview.Server -- | This usualy is the function with which the user runs the hakyll compiler diff --git a/src/Hakyll/Web/Preview/INotify.hs b/src/Hakyll/Web/Preview/INotify.hs deleted file mode 100644 index e21b767..0000000 --- a/src/Hakyll/Web/Preview/INotify.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | Filesystem polling with an inotify backend. Works only on linux. --- -module Hakyll.Web.Preview.INotify - ( previewPoll - ) where - -import Control.Monad (forM_, when) -import Data.Set (Set) -import qualified Data.Set as S -import System.FilePath (takeDirectory, ()) -import Data.List (isPrefixOf) - -import System.INotify - -import Hakyll.Core.Configuration -import Hakyll.Core.ResourceProvider -import Hakyll.Core.Identifier - --- | Calls the given callback when the directory tree changes --- -previewPoll :: HakyllConfiguration -- ^ Configuration - -> Set Resource -- ^ Resources to watch - -> IO () -- ^ Action called when something changes - -> IO () -- ^ Can block forever -previewPoll _ resources callback = do - -- Initialize inotify - inotify <- initINotify - - let -- A set of file paths - paths = S.map (toFilePath . unResource) resources - - -- A list of directories. Run it through a set so we have every - -- directory only once. - directories = S.toList $ S.map (notEmpty . takeDirectory) paths - - -- Problem: we can't add a watcher for "". So we make sure a directory - -- name is not empty - notEmpty "" = "." - notEmpty x = x - - -- Execute the callback when path is known - ifResource path = - let path' = if "./" `isPrefixOf` path then drop 2 path else path - in when (path' `S.member` paths) callback - - -- Add a watcher for every directory - forM_ directories $ \directory -> do - putStrLn $ "Adding watch for " ++ directory - _ <- addWatch inotify [Modify] directory $ \e -> case e of - (Modified _ (Just p)) -> ifResource $ directory p - _ -> return () - return () diff --git a/src/Hakyll/Web/Preview/Interval.hs b/src/Hakyll/Web/Preview/Interval.hs deleted file mode 100644 index 5ab90e5..0000000 --- a/src/Hakyll/Web/Preview/Interval.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Interval-based implementation of preview polling, for the platforms which --- are not supported by inotify. --- -module Hakyll.Web.Preview.Interval - ( previewPoll - ) where - -import Control.Applicative ((<$>)) -import Control.Concurrent (threadDelay) -import Control.Monad (when) -import System.Time (getClockTime) -import Data.Set (Set) -import qualified Data.Set as S -import System.Directory (getModificationTime) - -import Hakyll.Core.Configuration -import Hakyll.Core.Identifier -import Hakyll.Core.ResourceProvider - --- | A preview thread that periodically recompiles the site. --- -previewPoll :: HakyllConfiguration -- ^ Configuration - -> Set Resource -- ^ Resources to watch - -> IO () -- ^ Action called when something changes - -> IO () -- ^ Can block forever -previewPoll _ resources callback = do - let files = map (toFilePath . unResource) $ S.toList resources - time <- getClockTime - loop files time - where - delay = 1000000 - loop files time = do - threadDelay delay - modified <- any (time <) <$> mapM getModificationTime files - when modified callback - loop files =<< getClockTime -- cgit v1.2.3 From cd6d968187df77523f219f82540e3b65fe94a1ca Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Feb 2011 13:48:40 +0100 Subject: Remove debug output --- src-inotify/Hakyll/Web/Preview/Poll.hs | 1 - src/Hakyll/Main.hs | 4 +--- 2 files changed, 1 insertion(+), 4 deletions(-) (limited to 'src') diff --git a/src-inotify/Hakyll/Web/Preview/Poll.hs b/src-inotify/Hakyll/Web/Preview/Poll.hs index 69370ac..686f045 100644 --- a/src-inotify/Hakyll/Web/Preview/Poll.hs +++ b/src-inotify/Hakyll/Web/Preview/Poll.hs @@ -45,7 +45,6 @@ previewPoll _ resources callback = do -- Add a watcher for every directory forM_ directories $ \directory -> do - putStrLn $ "Adding watch for " ++ directory _ <- addWatch inotify [Modify] directory $ \e -> case e of (Modified _ (Just p)) -> ifResource $ directory p _ -> return () diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index a44d9fa..04b4cea 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -88,9 +88,7 @@ preview configuration rules port = do -- Get the resource list and a callback for the preview poll let resources = rulesResources ruleSet - callback = do - putStrLn "In TL callback" - build configuration rules + callback = build configuration rules -- Fork a thread polling for changes _ <- forkIO $ previewPoll configuration resources callback -- cgit v1.2.3 From 730eebe9894e73b7e86a6e5a7546ab5b2484c65d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 25 Feb 2011 14:17:30 +0100 Subject: The dependency analyzer now knows a little more --- .ghci | 2 +- src/Hakyll.hs | 2 ++ src/Hakyll/Core/Compiler.hs | 2 +- src/Hakyll/Core/Compiler/Internal.hs | 28 +++++++++++++++++++++++----- src/Hakyll/Core/Run.hs | 2 +- 5 files changed, 28 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/.ghci b/.ghci index fd1deff..a42ffe2 100644 --- a/.ghci +++ b/.ghci @@ -1 +1 @@ -:set -isrc -itests -idist/build/autogen +:set -isrc -isrc-inotify -itests -idist/build/autogen diff --git a/src/Hakyll.hs b/src/Hakyll.hs index b459507..9a17479 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -6,6 +6,7 @@ module Hakyll , module Hakyll.Core.Configuration , module Hakyll.Core.Identifier , module Hakyll.Core.Identifier.Pattern + , module Hakyll.Core.ResourceProvider , module Hakyll.Core.Routes , module Hakyll.Core.Rules , module Hakyll.Core.UnixFilter @@ -31,6 +32,7 @@ import Hakyll.Core.CopyFile import Hakyll.Core.Configuration import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes import Hakyll.Core.Rules import Hakyll.Core.UnixFilter diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index e4922dd..908cb55 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -225,7 +225,7 @@ requireA identifier = (id &&& require_ identifier >>>) requireAll_ :: (Binary a, Typeable a, Writable a) => Pattern -> Compiler b [a] -requireAll_ pattern = fromDependencies getDeps >>> fromJob requireAll_' +requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_' where getDeps = matches pattern . map unResource . resourceList requireAll_' = const $ CompilerM $ do diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 30a391f..d37c7ef 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -32,6 +32,15 @@ import Hakyll.Core.Logger -- type Dependencies = Set Identifier +-- | Environment in which the dependency analyzer runs +-- +data DependencyEnvironment = DependencyEnvironment + { -- | Target identifier + dependencyIdentifier :: Identifier + , -- | Resource provider + dependencyResourceProvider :: ResourceProvider + } + -- | Environment in which a compiler runs -- data CompilerEnvironment = CompilerEnvironment @@ -58,7 +67,7 @@ newtype CompilerM a = CompilerM -- | The compiler arrow -- data Compiler a b = Compiler - { compilerDependencies :: Reader ResourceProvider Dependencies + { compilerDependencies :: Reader DependencyEnvironment Dependencies , compilerJob :: a -> CompilerM b } @@ -109,19 +118,28 @@ runCompilerJob compiler identifier provider route store modified logger = } runCompilerDependencies :: Compiler () a + -> Identifier -> ResourceProvider -> Dependencies -runCompilerDependencies compiler = runReader (compilerDependencies compiler) +runCompilerDependencies compiler identifier provider = + runReader (compilerDependencies compiler) env + where + env = DependencyEnvironment + { dependencyIdentifier = identifier + , dependencyResourceProvider = provider + } fromJob :: (a -> CompilerM b) -> Compiler a b fromJob = Compiler (return S.empty) -fromDependencies :: (ResourceProvider -> [Identifier]) +fromDependencies :: (Identifier -> ResourceProvider -> [Identifier]) -> Compiler b b -fromDependencies deps = Compiler (S.fromList . deps <$> ask) return +fromDependencies collectDeps = flip Compiler return $ do + DependencyEnvironment identifier provider <- ask + return $ S.fromList $ collectDeps identifier provider -- | Wait until another compiler has finished before running this compiler -- fromDependency :: Identifier -> Compiler a a -fromDependency = fromDependencies . const . return +fromDependency = fromDependencies . const . const . return diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 42db80a..09864be 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -118,7 +118,7 @@ addNewCompilers oldCompilers newCompilers = Runtime $ do -- Get all dependencies for the compilers dependencies = flip map compilers $ \(id', compiler) -> - let deps = runCompilerDependencies compiler provider + let deps = runCompilerDependencies compiler id' provider in (id', deps) -- Create a compiler map (Id -> Compiler) -- cgit v1.2.3 From c89cfdb456deda5a81b52d9e8516d635e82f70d8 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 25 Feb 2011 14:36:34 +0100 Subject: Add `byExtension` compiler --- src/Hakyll/Core/Compiler.hs | 33 +++++++++++++++++++++++++++++++++ src/Hakyll/Core/Compiler/Internal.hs | 1 + 2 files changed, 34 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 908cb55..a3fed7c 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -103,6 +103,7 @@ module Hakyll.Core.Compiler , unsafeCompiler , mapCompiler , timedCompiler + , byExtension ) where import Prelude hiding ((.), id) @@ -112,6 +113,7 @@ import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) import Control.Category (Category, (.), id) import Data.Maybe (fromMaybe) +import System.FilePath (takeExtension) import Data.Binary (Binary) import Data.Typeable (Typeable) @@ -289,3 +291,34 @@ timedCompiler :: String -- ^ Message timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do logger <- compilerLogger <$> ask timed logger msg $ unCompilerM $ j x + +-- | Choose a compiler by extension +-- +-- Example: +-- +-- > route "css/*" $ setExtension "css" +-- > compile "css/*" $ byExtension (error "Not a (S)CSS file") +-- > [ (".css", compressCssCompiler) +-- > , (".scss", sass) +-- > ] +-- +-- This piece of code will select the @compressCssCompiler@ for @.css@ files, +-- and the @sass@ compiler (defined elsewhere) for @.scss@ files. +-- +byExtension :: Compiler a b -- ^ Default compiler + -> [(String, Compiler a b)] -- ^ Choices + -> Compiler a b -- ^ Resulting compiler +byExtension defaultCompiler choices = Compiler deps job + where + -- Lookup the compiler, give an error when it is not found + lookup' identifier = + let extension = takeExtension $ toFilePath identifier + in fromMaybe defaultCompiler $ lookup extension choices + -- Collect the dependencies of the choice + deps = do + identifier <- dependencyIdentifier <$> ask + compilerDependencies $ lookup' identifier + -- Collect the job of the choice + job x = CompilerM $ do + identifier <- compilerIdentifier <$> ask + unCompilerM $ compilerJob (lookup' identifier) x diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index d37c7ef..53df044 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal ( Dependencies + , DependencyEnvironment (..) , CompilerEnvironment (..) , CompilerM (..) , Compiler (..) -- cgit v1.2.3 From b73fc8e831806abf6432e5e443834e94c70dd4e7 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Feb 2011 11:07:46 +0100 Subject: Add some more information on metacompilation --- examples/hakyll/tutorial.markdown | 10 ++++++++-- src/Hakyll/Core/Rules.hs | 21 ++++++++++++++++++++- 2 files changed, 28 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/examples/hakyll/tutorial.markdown b/examples/hakyll/tutorial.markdown index 4596739..642c4f2 100644 --- a/examples/hakyll/tutorial.markdown +++ b/examples/hakyll/tutorial.markdown @@ -150,7 +150,8 @@ later[^1]. template compile rule at the bottom -- this would make no difference. Now, it's time to actually render our pages. We use the `forM_` monad combinator -so we can describe all files at once. +so we can describe all files at once (instead of compiling all three files +manually). ~~~~~{.haskell} forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> do @@ -170,7 +171,7 @@ DSL there. The gist of it is that the `Compiler a b` type has two parameters -- it is an Arrow, and we can chain compilers using the `>>>` operator. The [compiler] -reference page has some more information on this subject. +reference page has some more readable information on this subject. [compiler]: /reference/Hakyll-Core-Compiler.html @@ -179,3 +180,8 @@ compile page $ pageCompiler >>> applyTemplateCompiler "templates/default.html" >>> relativizeUrlsCompiler ~~~~~ + +Note that we can only use `applyTemplateCompiler` with +`"templates/default.html"` because we compiled `"templates/default.html"`. If we +didn't list a rule for that item, the compilation would fail (Hakyll would not +know what `"templates/default.html"` is!). diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 1aa3ad3..eba3fb9 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -81,7 +81,9 @@ compile pattern compiler = RulesM $ do -- | Add a compilation rule -- -- This sets a compiler for the given identifier. No resource is needed, since --- we are creating the item from scratch. +-- we are creating the item from scratch. This is useful if you want to create a +-- page on your site that just takes content from other items -- but has no +-- actual content itself. -- create :: (Binary a, Typeable a, Writable a) => Identifier -> Compiler () a -> Rules @@ -98,6 +100,23 @@ route pattern route' = tellRoute $ ifMatch pattern route' -- Metacompilers are a special class of compilers: they are compilers which -- produce other compilers. -- +-- This is needed when the list of compilers depends on something we cannot know +-- before actually running other compilers. The most typical example is if we +-- have a blogpost using tags. +-- +-- Every post has a collection of tags. For example, +-- +-- > post1: code, haskell +-- > post2: code, random +-- +-- Now, we want to create a list of posts for every tag. We cannot write this +-- down in our 'Rules' DSL directly, since we don't know what tags the different +-- posts will have -- we depend on information that will only be available when +-- we are actually compiling the pages. +-- +-- The solution is simple, using 'metaCompile', we can add a compiler that will +-- parse the pages and produce the compilers needed for the different tag pages. +-- -- And indeed, we can see that the first argument to 'metaCompile' is a -- 'Compiler' which produces a list of ('Identifier', 'Compiler') pairs. The -- idea is simple: 'metaCompile' produces a list of compilers, and the -- cgit v1.2.3 From 5c454fc2ced8364e000f8c9cc36387e39e001714 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Feb 2011 15:49:11 +0100 Subject: Fix $body$ bug, add `traceShowCompiler` --- src/Hakyll/Core/Compiler.hs | 9 +++++++++ src/Hakyll/Web/Page.hs | 12 ------------ src/Hakyll/Web/Page/Internal.hs | 12 ++++++++++++ src/Hakyll/Web/Template.hs | 6 +++--- 4 files changed, 24 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index a3fed7c..e5da9b8 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -101,6 +101,7 @@ module Hakyll.Core.Compiler , requireAllA , cached , unsafeCompiler + , traceShowCompiler , mapCompiler , timedCompiler , byExtension @@ -277,6 +278,14 @@ unsafeCompiler :: (a -> IO b) -- ^ Function to lift -> Compiler a b -- ^ Resulting compiler unsafeCompiler f = fromJob $ CompilerM . liftIO . f +-- | Compiler for debugging purposes +-- +traceShowCompiler :: Show a => Compiler a a +traceShowCompiler = fromJob $ \x -> CompilerM $ do + logger <- compilerLogger <$> ask + report logger $ show x + return x + -- | Map over a compiler -- mapCompiler :: Compiler a b diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index c61008c..8a16ef8 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -61,8 +61,6 @@ import Prelude hiding (id) import Control.Category (id) import Control.Arrow (arr, (>>^), (&&&), (>>>)) import System.FilePath (takeBaseName, takeDirectory) -import Data.Monoid (Monoid, mempty) -import Data.Map (Map) import qualified Data.Map as M import Data.List (sortBy) import Data.Ord (comparing) @@ -82,16 +80,6 @@ import Hakyll.Web.Util.String fromBody :: a -> Page a fromBody = Page M.empty --- | Create a metadata page, without a body --- -fromMap :: Monoid a => Map String String -> Page a -fromMap m = Page m mempty - --- | Convert a page to a map. The body will be placed in the @body@ key. --- -toMap :: Page String -> Map String String -toMap (Page m b) = M.insert "body" b m - -- | Read a page (do not render it) -- readPageCompiler :: Compiler Resource (Page String) diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs index dd47197..55067ed 100644 --- a/src/Hakyll/Web/Page/Internal.hs +++ b/src/Hakyll/Web/Page/Internal.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page.Internal ( Page (..) + , fromMap + , toMap ) where import Control.Applicative ((<$>), (<*>)) @@ -36,3 +38,13 @@ instance Binary a => Binary (Page a) where instance Writable a => Writable (Page a) where write p (Page _ b) = write p b + +-- | Create a metadata page, without a body +-- +fromMap :: Monoid a => Map String String -> Page a +fromMap m = Page m mempty + +-- | Convert a page to a map. The body will be placed in the @body@ key. +-- +toMap :: Page String -> Map String String +toMap (Page m b) = M.insert "body" b m diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 5b38ba3..9c49278 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -53,6 +53,7 @@ module Hakyll.Web.Template import Control.Arrow import Data.Maybe (fromMaybe) import System.FilePath (takeExtension) +import qualified Data.Map as M import Text.Hamlet (HamletSettings, defaultHamletSettings) @@ -62,7 +63,6 @@ import Hakyll.Core.ResourceProvider import Hakyll.Web.Template.Internal import Hakyll.Web.Template.Read import Hakyll.Web.Page.Internal -import Hakyll.Web.Page.Metadata -- | Substitutes @$identifiers@ in the given @Template@ by values from the given -- "Page". When a key is not found, it is left as it is. You can specify @@ -72,9 +72,9 @@ applyTemplate :: Template -> Page String -> Page String applyTemplate template page = fmap (const $ substitute =<< unTemplate template) page where + map' = toMap page substitute (Chunk chunk) = chunk - substitute (Key key) = - fromMaybe ("$" ++ key ++ "$") $ getFieldMaybe key page + substitute (Key key) = fromMaybe ("$" ++ key ++ "$") $ M.lookup key map' substitute (Escaped) = "$" -- | Apply a page as it's own template. This is often very useful to fill in -- cgit v1.2.3 From 40d921e8e76635a8952015eec9e5de117ce70caf Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 28 Feb 2011 20:44:23 +0100 Subject: Fix URL error in feeds --- src/Hakyll/Web/Feed.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index 417f484..d91a60f 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -33,6 +33,7 @@ import Hakyll.Web.Page import Hakyll.Web.Page.Metadata import Hakyll.Web.Template import Hakyll.Web.Template.Read.Hakyll (readTemplate) +import Hakyll.Web.Util.String import Paths_hakyll @@ -93,7 +94,7 @@ renderFeed feedTemplate itemTemplate configuration = renderFeed' = unsafeCompiler $ \(items, url) -> do feedTemplate' <- loadTemplate feedTemplate itemTemplate' <- loadTemplate itemTemplate - let url' = fromMaybe noUrl url + let url' = toUrl $ fromMaybe noUrl url return $ createFeed feedTemplate' itemTemplate' url' configuration items -- Auxiliary: load a template from a datafile -- cgit v1.2.3 From 49989eab5767b24cb3e917b95137ae05566e34a8 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 28 Feb 2011 22:33:28 +0100 Subject: Web.Util.String → {Web.Util.Url, Core.Util.String} MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- hakyll.cabal | 3 +- src/Hakyll.hs | 6 ++-- src/Hakyll/Core/Util/String.hs | 48 ++++++++++++++++++++++++++ src/Hakyll/Web/CompressCss.hs | 2 +- src/Hakyll/Web/Feed.hs | 2 +- src/Hakyll/Web/Page.hs | 2 +- src/Hakyll/Web/Page/Metadata.hs | 2 +- src/Hakyll/Web/Page/Read.hs | 2 +- src/Hakyll/Web/Preview/Server.hs | 2 +- src/Hakyll/Web/RelativizeUrls.hs | 2 +- src/Hakyll/Web/Tags.hs | 3 +- src/Hakyll/Web/Util/String.hs | 73 ---------------------------------------- src/Hakyll/Web/Util/Url.hs | 30 +++++++++++++++++ 13 files changed, 93 insertions(+), 84 deletions(-) create mode 100644 src/Hakyll/Core/Util/String.hs delete mode 100644 src/Hakyll/Web/Util/String.hs create mode 100644 src/Hakyll/Web/Util/Url.hs (limited to 'src') diff --git a/hakyll.cabal b/hakyll.cabal index e011406..b4a533f 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -65,7 +65,7 @@ library strict-concurrency >= 0.2 exposed-modules: Hakyll Hakyll.Main - Hakyll.Web.Util.String + Hakyll.Web.Util.Url Hakyll.Web.Preview.Server Hakyll.Web.Preview.Poll Hakyll.Web.CompressCss @@ -85,6 +85,7 @@ library Hakyll.Core.UnixFilter Hakyll.Core.Util.Arrow Hakyll.Core.Util.File + Hakyll.Core.Util.String Hakyll.Core.ResourceProvider Hakyll.Core.CompiledItem Hakyll.Core.Compiler diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 9a17479..0261044 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -12,6 +12,7 @@ module Hakyll , module Hakyll.Core.UnixFilter , module Hakyll.Core.Util.Arrow , module Hakyll.Core.Util.File + , module Hakyll.Core.Util.String , module Hakyll.Core.Writable , module Hakyll.Main , module Hakyll.Web.CompressCss @@ -24,7 +25,7 @@ module Hakyll , module Hakyll.Web.RelativizeUrls , module Hakyll.Web.Tags , module Hakyll.Web.Template - , module Hakyll.Web.Util.String + , module Hakyll.Web.Util.Url ) where import Hakyll.Core.Compiler @@ -38,6 +39,7 @@ import Hakyll.Core.Rules import Hakyll.Core.UnixFilter import Hakyll.Core.Util.Arrow import Hakyll.Core.Util.File +import Hakyll.Core.Util.String import Hakyll.Core.Writable import Hakyll.Main import Hakyll.Web.CompressCss @@ -50,4 +52,4 @@ import Hakyll.Web.Pandoc import Hakyll.Web.RelativizeUrls import Hakyll.Web.Tags import Hakyll.Web.Template -import Hakyll.Web.Util.String +import Hakyll.Web.Util.Url diff --git a/src/Hakyll/Core/Util/String.hs b/src/Hakyll/Core/Util/String.hs new file mode 100644 index 0000000..7f75a36 --- /dev/null +++ b/src/Hakyll/Core/Util/String.hs @@ -0,0 +1,48 @@ +-- | Miscellaneous string manipulation functions. +-- +module Hakyll.Core.Util.String + ( trim + , replaceAll + , splitAll + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe) + +import Text.Regex.PCRE ((=~~)) + +-- | Trim a string (drop spaces, tabs and newlines at both sides). +-- +trim :: String -> String +trim = reverse . trim' . reverse . trim' + where + trim' = dropWhile isSpace + +-- | A simple (but inefficient) regex replace funcion +-- +replaceAll :: String -- ^ Pattern + -> (String -> String) -- ^ Replacement (called on capture) + -> String -- ^ Source string + -> String -- ^ Result +replaceAll pattern f source = replaceAll' source + where + replaceAll' src = case listToMaybe (src =~~ pattern) of + Nothing -> src + Just (o, l) -> + let (before, tmp) = splitAt o src + (capture, after) = splitAt l tmp + in before ++ f capture ++ replaceAll' after + +-- | A simple regex split function. The resulting list will contain no empty +-- strings. +-- +splitAll :: String -- ^ Pattern + -> String -- ^ String to split + -> [String] -- ^ Result +splitAll pattern = filter (not . null) . splitAll' + where + splitAll' src = case listToMaybe (src =~~ pattern) of + Nothing -> [src] + Just (o, l) -> + let (before, tmp) = splitAt o src + in before : splitAll' (drop l tmp) diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index 94ba9a9..2df08fd 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -12,7 +12,7 @@ import Control.Arrow ((>>^)) import Hakyll.Core.Compiler import Hakyll.Core.ResourceProvider -import Hakyll.Web.Util.String +import Hakyll.Core.Util.String -- | Compiler form of 'compressCss' -- diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index d91a60f..85674c6 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -33,7 +33,7 @@ import Hakyll.Web.Page import Hakyll.Web.Page.Metadata import Hakyll.Web.Template import Hakyll.Web.Template.Read.Hakyll (readTemplate) -import Hakyll.Web.Util.String +import Hakyll.Web.Util.Url import Paths_hakyll diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 8a16ef8..955e1a8 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -73,7 +73,7 @@ import Hakyll.Web.Page.Read import Hakyll.Web.Page.Metadata import Hakyll.Web.Pandoc import Hakyll.Web.Template -import Hakyll.Web.Util.String +import Hakyll.Web.Util.Url -- | Create a page from a body, without metadata -- diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs index 23d98a4..72742e6 100644 --- a/src/Hakyll/Web/Page/Metadata.hs +++ b/src/Hakyll/Web/Page/Metadata.hs @@ -24,7 +24,7 @@ import System.FilePath (takeFileName) import System.Locale (TimeLocale, defaultTimeLocale) import Hakyll.Web.Page.Internal -import Hakyll.Web.Util.String +import Hakyll.Core.Util.String -- | Get a metadata field. If the field does not exist, the empty string is -- returned. diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs index d72f32a..cf39ddd 100644 --- a/src/Hakyll/Web/Page/Read.hs +++ b/src/Hakyll/Web/Page/Read.hs @@ -12,7 +12,7 @@ import Data.Map (Map) import qualified Data.Map as M import Hakyll.Web.Page.Internal -import Hakyll.Web.Util.String +import Hakyll.Core.Util.String -- | We're using a simple state monad as parser -- diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs index 77b3cb0..c550b69 100644 --- a/src/Hakyll/Web/Preview/Server.hs +++ b/src/Hakyll/Web/Preview/Server.hs @@ -18,7 +18,7 @@ import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen , ConfigListen (..), emptyConfig ) -import Hakyll.Web.Util.String (replaceAll) +import Hakyll.Core.Util.String (replaceAll) -- | The first file in the list that actually exists is returned -- diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs index 1df4fea..2de4a0e 100644 --- a/src/Hakyll/Web/RelativizeUrls.hs +++ b/src/Hakyll/Web/RelativizeUrls.hs @@ -29,7 +29,7 @@ import Text.HTML.TagSoup import Hakyll.Core.Compiler import Hakyll.Web.Page -import Hakyll.Web.Util.String +import Hakyll.Web.Util.Url -- | Compiler form of 'compressCss' which automatically picks the right root -- path diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 77dc440..211a06b 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -55,10 +55,11 @@ import qualified Text.Blaze.Html5.Attributes as A import Hakyll.Web.Page import Hakyll.Web.Page.Metadata -import Hakyll.Web.Util.String +import Hakyll.Web.Util.Url import Hakyll.Core.Writable import Hakyll.Core.Identifier import Hakyll.Core.Compiler +import Hakyll.Core.Util.String -- | Data about tags -- diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs deleted file mode 100644 index 0dde74a..0000000 --- a/src/Hakyll/Web/Util/String.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | Miscellaneous string manipulation functions. --- -module Hakyll.Web.Util.String - ( trim - , replaceAll - , splitAll - , toUrl - , toSiteRoot - ) where - -import Data.Char (isSpace) -import Data.Maybe (listToMaybe) - -import System.FilePath (splitPath, takeDirectory, joinPath) -import Text.Regex.PCRE ((=~~)) - --- | Trim a string (drop spaces, tabs and newlines at both sides). --- -trim :: String -> String -trim = reverse . trim' . reverse . trim' - where - trim' = dropWhile isSpace - --- | A simple (but inefficient) regex replace funcion --- -replaceAll :: String -- ^ Pattern - -> (String -> String) -- ^ Replacement (called on capture) - -> String -- ^ Source string - -> String -- ^ Result -replaceAll pattern f source = replaceAll' source - where - replaceAll' src = case listToMaybe (src =~~ pattern) of - Nothing -> src - Just (o, l) -> - let (before, tmp) = splitAt o src - (capture, after) = splitAt l tmp - in before ++ f capture ++ replaceAll' after - --- | A simple regex split function. The resulting list will contain no empty --- strings. --- -splitAll :: String -- ^ Pattern - -> String -- ^ String to split - -> [String] -- ^ Result -splitAll pattern = filter (not . null) . splitAll' - where - splitAll' src = case listToMaybe (src =~~ pattern) of - Nothing -> [src] - Just (o, l) -> - let (before, tmp) = splitAt o src - in before : splitAll' (drop l tmp) - --- | Convert a filepath to an URL starting from the site root --- --- Example: --- --- > toUrl "foo/bar.html" --- --- Result: --- --- > "/foo/bar.html" --- -toUrl :: FilePath -> String -toUrl = ('/' :) - --- | Get the relative url to the site root, for a given (absolute) url --- -toSiteRoot :: String -> String -toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory - where - parent = const ".." - emptyException [] = "." - emptyException x = x diff --git a/src/Hakyll/Web/Util/Url.hs b/src/Hakyll/Web/Util/Url.hs new file mode 100644 index 0000000..54a361e --- /dev/null +++ b/src/Hakyll/Web/Util/Url.hs @@ -0,0 +1,30 @@ +-- | Miscellaneous URL manipulation functions. +-- +module Hakyll.Web.Util.Url + ( toUrl + , toSiteRoot + ) where + +import System.FilePath (splitPath, takeDirectory, joinPath) + +-- | Convert a filepath to an URL starting from the site root +-- +-- Example: +-- +-- > toUrl "foo/bar.html" +-- +-- Result: +-- +-- > "/foo/bar.html" +-- +toUrl :: FilePath -> String +toUrl = ('/' :) + +-- | Get the relative url to the site root, for a given (absolute) url +-- +toSiteRoot :: String -> String +toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory + where + parent = const ".." + emptyException [] = "." + emptyException x = x -- cgit v1.2.3 From d460fd88d13984aa0e851527f7ff65065230c411 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 28 Feb 2011 22:40:23 +0100 Subject: Add `gsubRoute` --- src/Hakyll/Core/Routes.hs | 18 ++++++++++++++++++ tests/Hakyll/Core/Routes/Tests.hs | 3 +++ 2 files changed, 21 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs index 250536a..eba35ff 100644 --- a/src/Hakyll/Core/Routes.hs +++ b/src/Hakyll/Core/Routes.hs @@ -32,6 +32,7 @@ module Hakyll.Core.Routes , setExtension , ifMatch , customRoute + , gsubRoute ) where import Data.Monoid (Monoid, mempty, mappend) @@ -40,6 +41,7 @@ import System.FilePath (replaceExtension) import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Util.String -- | Type used for a route -- @@ -94,3 +96,19 @@ ifMatch pattern (Routes route) = Routes $ \id' -> -- customRoute :: (Identifier -> FilePath) -> Routes customRoute f = Routes $ Just . f + +-- | Create a gsub route +-- +-- Example: +-- +-- > runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" +-- +-- Result: +-- +-- > Just "tags/bar.xml" +-- +gsubRoute :: String -- ^ Pattern + -> (String -> String) -- ^ Replacement + -> Routes -- ^ Resulting route +gsubRoute pattern replacement = customRoute $ + replaceAll pattern replacement . toFilePath diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs index 5aa6dbd..201c656 100644 --- a/tests/Hakyll/Core/Routes/Tests.hs +++ b/tests/Hakyll/Core/Routes/Tests.hs @@ -15,4 +15,7 @@ tests = fromAssertions "runRoutes" , Just "foo.html" @=? runRoutes (setExtension ".html") "foo" , Just "foo.html" @=? runRoutes (setExtension "html") "foo.markdown" , Just "foo.html" @=? runRoutes (setExtension ".html") "foo.markdown" + + , Just "tags/bar.xml" @=? + runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" ] -- cgit v1.2.3 From fa057f30117e02f13f4a788eb3f52660ab8ab440 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 1 Mar 2011 09:40:07 +0100 Subject: Add `composeRoutes` --- src/Hakyll/Core/Routes.hs | 22 ++++++++++++++++++++++ tests/Hakyll/Core/Routes/Tests.hs | 3 +++ 2 files changed, 25 insertions(+) (limited to 'src') diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs index eba35ff..fcab28d 100644 --- a/src/Hakyll/Core/Routes.hs +++ b/src/Hakyll/Core/Routes.hs @@ -33,6 +33,7 @@ module Hakyll.Core.Routes , ifMatch , customRoute , gsubRoute + , composeRoutes ) where import Data.Monoid (Monoid, mempty, mappend) @@ -112,3 +113,24 @@ gsubRoute :: String -- ^ Pattern -> 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@. +-- +-- Example: +-- +-- > let routes = gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml" +-- > in runRoutes routes "tags/rss/bar" +-- +-- Result: +-- +-- > 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 diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs index 201c656..3361846 100644 --- a/tests/Hakyll/Core/Routes/Tests.hs +++ b/tests/Hakyll/Core/Routes/Tests.hs @@ -18,4 +18,7 @@ tests = fromAssertions "runRoutes" , Just "tags/bar.xml" @=? runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" + , Just "tags/bar.xml" @=? + runRoutes (gsubRoute "rss/" (const "") `composeRoutes` + setExtension "xml") "tags/rss/bar" ] -- cgit v1.2.3