From 42bacee41a68e9e1eaddcec0702ead71a0a1b3e6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 24 Jan 2010 16:40:09 +0100 Subject: Module cleanup. --- src/Text/Hakyll/CompressCSS.hs | 36 -------------- src/Text/Hakyll/Internal/CompressCSS.hs | 36 ++++++++++++++ src/Text/Hakyll/Internal/Render.hs | 68 ++++++++++++++++++++++++++ src/Text/Hakyll/Internal/Template.hs | 86 +++++++++++++++++++++++++++++++++ src/Text/Hakyll/Render.hs | 6 +-- src/Text/Hakyll/Render/Internal.hs | 76 ----------------------------- src/Text/Hakyll/Tags.hs | 3 +- src/Text/Hakyll/Template.hs | 74 ---------------------------- 8 files changed, 194 insertions(+), 191 deletions(-) delete mode 100644 src/Text/Hakyll/CompressCSS.hs create mode 100644 src/Text/Hakyll/Internal/CompressCSS.hs create mode 100644 src/Text/Hakyll/Internal/Render.hs create mode 100644 src/Text/Hakyll/Internal/Template.hs delete mode 100644 src/Text/Hakyll/Render/Internal.hs delete mode 100644 src/Text/Hakyll/Template.hs (limited to 'src/Text/Hakyll') diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs deleted file mode 100644 index 0836f69..0000000 --- a/src/Text/Hakyll/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.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 (tail str) - where - eatComments str' | null str' = [] - | isPrefixOf "*/" str' = drop 2 str' - | otherwise = eatComments $ tail str' diff --git a/src/Text/Hakyll/Internal/CompressCSS.hs b/src/Text/Hakyll/Internal/CompressCSS.hs new file mode 100644 index 0000000..7d52bef --- /dev/null +++ b/src/Text/Hakyll/Internal/CompressCSS.hs @@ -0,0 +1,36 @@ +-- | 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 (tail str) + where + eatComments str' | null str' = [] + | isPrefixOf "*/" str' = drop 2 str' + | otherwise = eatComments $ tail str' diff --git a/src/Text/Hakyll/Internal/Render.hs b/src/Text/Hakyll/Internal/Render.hs new file mode 100644 index 0000000..a3d2d9b --- /dev/null +++ b/src/Text/Hakyll/Internal/Render.hs @@ -0,0 +1,68 @@ +-- | Internal module do some low-level rendering. +module Text.Hakyll.Internal.Render + ( substitute + , regularSubstitute + , finalSubstitute + , pureRenderWith + , pureRenderAndConcatWith + , pureRenderChainWith + , writePage + ) where + +import qualified Data.Map as M +import Control.Monad.Reader (liftIO) +import Data.List (foldl') +import Data.Maybe (fromMaybe) + +import Text.Hakyll.Context (Context, ContextManipulation) +import Text.Hakyll.Renderable +import Text.Hakyll.Page +import Text.Hakyll.File +import Text.Hakyll.Hakyll +import Text.Hakyll.Internal.Template + +-- | A pure render function. +pureRenderWith :: ContextManipulation -- ^ Manipulation to apply on the context. + -> Template -- ^ Template to use for rendering. + -> Context -- ^ Renderable object to render with given template. + -> Context -- ^ The body of the result will contain the render. +pureRenderWith manipulation template context = + -- Ignore $root when substituting here. We will only replace that in the + -- final render (just before writing). + let contextIgnoringRoot = M.insert "root" "$root" (manipulation context) + body = regularSubstitute template contextIgnoringRoot + in M.insert "body" body context + +-- | A pure renderAndConcat function. +pureRenderAndConcatWith :: ContextManipulation -- ^ Manipulation to apply. + -> [Template] -- ^ Templates to use. + -> [Context] -- ^ Different renderables. + -> String +pureRenderAndConcatWith manipulation templates = + concatMap renderAndConcat + where + renderAndConcat = fromMaybe "" . M.lookup "body" + . pureRenderChainWith manipulation templates + +-- | A pure renderChain function. +pureRenderChainWith :: ContextManipulation + -> [Template] + -> Context + -> Context +pureRenderChainWith manipulation templates context = + let initial = manipulation context + in foldl' (flip $ pureRenderWith id) initial templates + +-- | Write a page to the site destination. Final action after render +-- chains and such. +writePage :: Page -> Hakyll () +writePage page = do + additionalContext' <- askHakyll additionalContext + destination <- toDestination url + let context = additionalContext' `M.union` M.singleton "root" (toRoot url) + makeDirectories destination +    -- Substitute $root here, just before writing. + liftIO $ writeFile destination $ finalSubstitute (fromString $ getBody page) + context + where + url = getURL page diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs new file mode 100644 index 0000000..41d279c --- /dev/null +++ b/src/Text/Hakyll/Internal/Template.hs @@ -0,0 +1,86 @@ +module Text.Hakyll.Internal.Template + ( Template + , fromString + , readTemplate + , substitute + , regularSubstitute + , finalSubstitute + ) where + +import qualified Data.Map as M +import Data.List (isPrefixOf) +import Data.Char (isAlphaNum) +import Data.Binary +import Control.Monad (liftM, liftM2) +import Data.Maybe (fromMaybe) +import System.FilePath (()) +import Control.Monad.Reader (liftIO) + +import Text.Hakyll.Hakyll (Hakyll) +import Text.Hakyll.Context (Context) +import Text.Hakyll.Internal.Cache + +data Template = Chunk String Template + | Identifier String Template + | EscapeCharacter Template + | End + deriving (Show, Read) + +fromString :: String -> Template +fromString [] = End +fromString string + | "$$" `isPrefixOf` string = EscapeCharacter (fromString $ tail tail') + | "$" `isPrefixOf` string = let (key, rest) = span isAlphaNum tail' + in Identifier key (fromString rest) + | otherwise = let (chunk, rest) = break (== '$') string + in Chunk chunk (fromString rest) + where + tail' = tail string + +readTemplate :: FilePath -> Hakyll Template +readTemplate path = do + isCacheMoreRecent' <- isCacheMoreRecent fileName [path] + if isCacheMoreRecent' then getFromCache fileName + else do content <- liftIO $ readFile path + let template = fromString content + storeInCache template fileName + return template + where + fileName = "templates" 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 (Chunk chunk template) context = + chunk ++ substitute escaper template context +substitute escaper (Identifier key template) context = + replacement ++ substitute escaper template context + where + replacement = fromMaybe ('$' : key) $ M.lookup key context +substitute escaper (EscapeCharacter template) context = + escaper ++ substitute escaper template context +substitute _ End _ = [] + +-- | "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 "$" + +instance Binary Template where + put (Chunk string template) = put (0 :: Word8) >> put string >> put template + put (Identifier key template) = put (1 :: Word8) >> put key >> put template + put (EscapeCharacter template) = put (2 :: Word8) >> put template + put (End) = put (3 :: Word8) + + get = do tag <- getWord8 + case tag of 0 -> liftM2 Chunk get get + 1 -> liftM2 Identifier get get + 2 -> liftM EscapeCharacter get + 3 -> return End + _ -> error "Error reading template" diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs index 9484859..3329994 100644 --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -16,14 +16,14 @@ import Control.Monad (unless) import Control.Monad.Reader (liftIO) import System.Directory (copyFile) -import Text.Hakyll.Template (readTemplate) import Text.Hakyll.Hakyll (Hakyll) import Text.Hakyll.Context (ContextManipulation) import Text.Hakyll.Page import Text.Hakyll.Renderable import Text.Hakyll.File -import Text.Hakyll.CompressCSS -import Text.Hakyll.Render.Internal +import Text.Hakyll.Internal.Template (readTemplate) +import Text.Hakyll.Internal.CompressCSS +import Text.Hakyll.Internal.Render -- | Execute an IO action only when the cache is invalid. depends :: FilePath -- ^ File to be rendered or created. diff --git a/src/Text/Hakyll/Render/Internal.hs b/src/Text/Hakyll/Render/Internal.hs deleted file mode 100644 index 3ebc67f..0000000 --- a/src/Text/Hakyll/Render/Internal.hs +++ /dev/null @@ -1,76 +0,0 @@ --- | Internal module do some low-level rendering. -module Text.Hakyll.Render.Internal - ( substitute - , regularSubstitute - , finalSubstitute - , pureRenderWith - , pureRenderAndConcatWith - , pureRenderChainWith - , writePage - ) where - -import qualified Data.Map as M -import Control.Monad.Reader (liftIO) -import Data.List (foldl') -import Data.Maybe (fromMaybe) - -import Text.Hakyll.Template (Template, substitute, fromString) -import Text.Hakyll.Context (Context, ContextManipulation) -import Text.Hakyll.Renderable -import Text.Hakyll.Page -import Text.Hakyll.File -import Text.Hakyll.Hakyll - --- | "substitute" for use during a chain. -regularSubstitute :: Template -> Context -> String -regularSubstitute = substitute "$$" - --- | "substitute" for the end of a chain (just before writing). -finalSubstitute :: Template -> Context -> String -finalSubstitute = substitute "$" - --- | A pure render function. -pureRenderWith :: ContextManipulation -- ^ Manipulation to apply on the context. - -> Template -- ^ Template to use for rendering. - -> Context -- ^ Renderable object to render with given template. - -> Context -- ^ The body of the result will contain the render. -pureRenderWith manipulation template context = - -- Ignore $root when substituting here. We will only replace that in the - -- final render (just before writing). - let contextIgnoringRoot = M.insert "root" "$root" (manipulation context) - body = regularSubstitute template contextIgnoringRoot - in M.insert "body" body context - --- | A pure renderAndConcat function. -pureRenderAndConcatWith :: ContextManipulation -- ^ Manipulation to apply. - -> [Template] -- ^ Templates to use. - -> [Context] -- ^ Different renderables. - -> String -pureRenderAndConcatWith manipulation templates = - concatMap renderAndConcat - where - renderAndConcat = fromMaybe "" . M.lookup "body" - . pureRenderChainWith manipulation templates - --- | A pure renderChain function. -pureRenderChainWith :: ContextManipulation - -> [Template] - -> Context - -> Context -pureRenderChainWith manipulation templates context = - let initial = manipulation context - in foldl' (flip $ pureRenderWith id) initial templates - --- | Write a page to the site destination. Final action after render --- chains and such. -writePage :: Page -> Hakyll () -writePage page = do - additionalContext' <- askHakyll additionalContext - destination <- toDestination url - let context = additionalContext' `M.union` M.singleton "root" (toRoot url) - makeDirectories destination -    -- Substitute $root here, just before writing. - liftIO $ writeFile destination $ finalSubstitute (fromString $ getBody page) - context - where - url = getURL page diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs index 77f52fe..d36a866 100644 --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -29,12 +29,11 @@ import System.FilePath (()) import Text.Hakyll.Hakyll (Hakyll) import Text.Hakyll.Context (ContextManipulation, changeValue) -import Text.Hakyll.Render.Internal (finalSubstitute) import Text.Hakyll.Regex -import Text.Hakyll.Template import Text.Hakyll.Util import Text.Hakyll.Page import Text.Hakyll.Internal.Cache +import Text.Hakyll.Internal.Template -- | Read a tag map. This creates a map from tags to page paths. -- diff --git a/src/Text/Hakyll/Template.hs b/src/Text/Hakyll/Template.hs deleted file mode 100644 index 9ba30fb..0000000 --- a/src/Text/Hakyll/Template.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Text.Hakyll.Template - ( Template - , fromString - , readTemplate - , substitute - ) where - -import qualified Data.Map as M -import Data.List (isPrefixOf) -import Data.Char (isAlphaNum) -import Data.Binary -import Control.Monad (liftM, liftM2) -import Data.Maybe (fromMaybe) -import System.FilePath (()) -import Control.Monad.Reader (liftIO) - -import Text.Hakyll.Hakyll (Hakyll) -import Text.Hakyll.Context (Context) -import Text.Hakyll.Internal.Cache - -data Template = Chunk String Template - | Identifier String Template - | EscapeCharacter Template - | End - deriving (Show, Read) - -fromString :: String -> Template -fromString [] = End -fromString string - | "$$" `isPrefixOf` string = EscapeCharacter (fromString $ tail tail') - | "$" `isPrefixOf` string = let (key, rest) = span isAlphaNum tail' - in Identifier key (fromString rest) - | otherwise = let (chunk, rest) = break (== '$') string - in Chunk chunk (fromString rest) - where - tail' = tail string - -readTemplate :: FilePath -> Hakyll Template -readTemplate path = do - isCacheMoreRecent' <- isCacheMoreRecent fileName [path] - if isCacheMoreRecent' then getFromCache fileName - else do content <- liftIO $ readFile path - let template = fromString content - storeInCache template fileName - return template - where - fileName = "templates" path - --- | Substitutes @$identifiers@ in the given string by values from the given --- "Context". When a key is not found, it is left as it is. You can here --- specify the characters used to replace escaped dollars (@$$@). -substitute :: String -> Template -> Context -> String -substitute escaper (Chunk chunk template) context = - chunk ++ substitute escaper template context -substitute escaper (Identifier key template) context = - replacement ++ substitute escaper template context - where - replacement = fromMaybe ('$' : key) $ M.lookup key context -substitute escaper (EscapeCharacter template) context = - escaper ++ substitute escaper template context -substitute _ End _ = [] - -instance Binary Template where - put (Chunk string template) = put (0 :: Word8) >> put string >> put template - put (Identifier key template) = put (1 :: Word8) >> put key >> put template - put (EscapeCharacter template) = put (2 :: Word8) >> put template - put (End) = put (3 :: Word8) - - get = do tag <- getWord8 - case tag of 0 -> liftM2 Chunk get get - 1 -> liftM2 Identifier get get - 2 -> liftM EscapeCharacter get - 3 -> return End - _ -> error "Error reading template" -- cgit v1.2.3