Module cleanup.

3 files changed, 190 insertions, 0 deletions

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"