" ++ (B.unpack phrase) ++ "
" + , responseHeaders = M.singleton "Content-Type" "text/html" + , responseBody = + "" ++ phrase ++ "
" } -- | Create a simple get response. @@ -99,49 +101,60 @@ createGetResponse request = do -- Construct the complete fileName of the requested resource. config <- ask - let uri = B.unpack (requestURI request) + let uri = requestURI request + log' = writeChan (logChannel config) isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri - let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html" - else uri + let fileName = + (documentRoot config) ++ if isDirectory then uri ++ "/index.html" + else uri create200 = do - body <- B.readFile fileName - let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body) - ] ++ getMIMEHeader fileName - return $ defaultResponse { responseStatusCode = 200 - , responsePhrase = B.pack "OK" - , responseHeaders = (responseHeaders defaultResponse) - `M.union` M.fromList headers - , responseBody = body - } + h <- openFile fileName ReadMode + contentLength <- hFileSize h + hClose h + body <- readFile fileName + let headers = + [ ("Content-Length", show $ contentLength) + ] ++ getMIMEHeader fileName + 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 writeChan (logChannel config) $ "Internal Error: " ++ show e - return $ createErrorResponse 500 (B.pack "Internal Server Error") + 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 do response <- liftIO $ catch create200 create500 - return response - else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName - return $ createErrorResponse 404 (B.pack "Not Found") + if exists + then do response <- liftIO $ catch create200 create500 + return response + 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 -> [(B.ByteString, B.ByteString)] -getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack 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") - ] +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 () @@ -152,24 +165,27 @@ -- Generate some output. config <- ask - liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response + liftIO $ writeChan (logChannel config) + $ show request ++ " => " ++ show response -- Send the response back to the handle. liftIO $ putResponse response - where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ") - [ responseVersion response - , B.pack $ show $ responseStatusCode response - , responsePhrase response - ] - hPutStr handle "\r\n" - mapM_ putHeader (M.toList $ responseHeaders response) - hPutStr handle "\r\n" - B.hPutStr handle $ responseBody response - hPutStr handle "\r\n" - hClose handle + 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) = B.hPutStr handle $ key `B.append` B.pack ": " - `B.append` value `B.append` B.pack "\r\n" + putHeader (key, value) = + hPutStr handle $ key ++ ": " ++ value ++ "\r\n" -- | Start a simple http server on the given 'PortNumber', serving the given -- directory. @@ -194,5 +210,3 @@ writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..." socket <- listenOn (PortNumber port) forever (listen socket) - where - diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs --- a/src/Text/Hakyll.hs +++ b/src/Text/Hakyll.hs @@ -11,7 +11,7 @@ hakyll :: IO () -> IO () hakyll buildFunction = do args <- getArgs - case args of [] -> build buildFunction + case args of ["build"] -> build buildFunction ["clean"] -> clean ["preview", p] -> build buildFunction >> server (read p) ["preview"] -> build buildFunction >> server 8000 @@ -28,20 +28,21 @@ clean :: IO () clean = do remove' "_cache" remove' "_site" - where remove' dir = do putStrLn $ "Removing " ++ dir ++ "..." - exists <- doesDirectoryExist dir - if exists then removeDirectoryRecursive dir - else return () + where + remove' dir = do putStrLn $ "Removing " ++ dir ++ "..." + exists <- doesDirectoryExist dir + if exists then removeDirectoryRecursive dir + else return () -- | Show usage information. help :: IO () help = do name <- getProgName - putStrLn $ "This is a hakyll site generator program. You should always\n" + putStrLn $ "This is a Hakyll site generator program. You should always\n" ++ "run it from the project root directory.\n" ++ "\n" ++ "Usage:\n" - ++ name ++ " Generate the site.\n" + ++ name ++ " build Generate the site.\n" ++ name ++ " clean Clean up and remove cache.\n" ++ name ++ " help Show this message.\n" ++ name ++ " preview [port] Generate site, then start a server.\n" diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs --- a/src/Text/Hakyll/CompressCSS.hs +++ b/src/Text/Hakyll/CompressCSS.hs @@ -3,7 +3,7 @@ ) where import Data.List (isPrefixOf) -import Text.Hakyll.Regex (substitute) +import Text.Hakyll.Regex (substituteRegex) -- | Compress CSS to speed up your site. compressCSS :: String -> String @@ -13,19 +13,21 @@ -- | Compresses certain forms of separators. compressSeparators :: String -> String -compressSeparators = substitute "; *}" "}" - . substitute " *([{};:]) *" "\\1" - . substitute ";;*" ";" +compressSeparators = substituteRegex "; *}" "}" + . substituteRegex " *([{};:]) *" "\\1" + . substituteRegex ";;*" ";" -- | Compresses all whitespace. compressWhitespace :: String -> String -compressWhitespace = substitute "[ \t\n][ \t\n]*" " " +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' +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/Context.hs b/src/Text/Hakyll/Context.hs --- a/src/Text/Hakyll/Context.hs +++ b/src/Text/Hakyll/Context.hs @@ -1,32 +1,35 @@ -- | Module containing various functions to manipulate contexts. module Text.Hakyll.Context - ( ContextManipulation + ( Context + , ContextManipulation , renderValue , renderDate ) where import qualified Data.Map as M -import qualified Data.ByteString.Lazy.Char8 as B +import Data.Map (Map) import System.Locale (defaultTimeLocale) import System.FilePath (takeFileName) -import Text.Template (Context) import Data.Time.Format (parseTime, formatTime) import Data.Time.Clock (UTCTime) import Data.Maybe (fromMaybe) -import Text.Hakyll.Regex (substitute) +import Text.Hakyll.Regex (substituteRegex) +-- | Type for a context. +type Context = Map String String + -- | Type for context manipulating functions. type ContextManipulation = Context -> Context -- | Do something with a value of a context. renderValue :: String -- ^ Key of which the value should be copied. -> String -- ^ Key the value should be copied to. - -> (B.ByteString -> B.ByteString) -- ^ Function to apply on the value. + -> (String -> String) -- ^ Function to apply on the value. -> ContextManipulation -renderValue src dst f context = case M.lookup (B.pack src) context of +renderValue src dst f context = case M.lookup src context of Nothing -> context - (Just value) -> M.insert (B.pack dst) (f value) context + (Just value) -> M.insert dst (f value) context -- | When the context has a key called `path` in a `yyyy-mm-dd-title.extension` -- format (default for pages), this function can render the date. @@ -34,13 +37,13 @@ -> String -- ^ Format to use on the date. -> String -- ^ Default value when the date cannot be parsed. -> ContextManipulation -renderDate key format defaultValue context = - M.insert (B.pack key) (B.pack value) context - where value = fromMaybe defaultValue pretty - pretty = do filePath <- M.lookup (B.pack "path") context - let dateString = substitute "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" - (takeFileName $ B.unpack filePath) - time <- parseTime defaultTimeLocale - "%Y-%m-%d" - dateString :: Maybe UTCTime - return $ formatTime defaultTimeLocale format time +renderDate key format defaultValue context = M.insert key value context + where + value = fromMaybe defaultValue pretty + pretty = do filePath <- M.lookup "path" context + let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" + (takeFileName filePath) + time <- parseTime defaultTimeLocale + "%Y-%m-%d" + dateString :: Maybe UTCTime + return $ formatTime defaultTimeLocale format time diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs --- a/src/Text/Hakyll/File.hs +++ b/src/Text/Hakyll/File.hs @@ -4,6 +4,7 @@ ( toDestination , toCache , toURL + , toRoot , removeSpaces , makeDirectories , getRecursiveContents @@ -15,13 +16,18 @@ import System.Directory import System.FilePath import Control.Monad +import Data.List (isPrefixOf) -- | Auxiliary function to remove pathSeparators form the start. We don't deal --- with absolute paths here. +-- with absolute paths here. We also remove $root from the start. removeLeadingSeparator :: FilePath -> FilePath removeLeadingSeparator [] = [] -removeLeadingSeparator p@(x:xs) | x `elem` pathSeparators = xs - | otherwise = p +removeLeadingSeparator path + | (head path') `elem` pathSeparators = (tail path') + | otherwise = path' + where + path' = if "$root" `isPrefixOf` path then drop 5 path + else path -- | Convert a relative filepath to a filepath in the destination (_site). toDestination :: FilePath -> FilePath @@ -33,19 +39,32 @@ -- | Get the url for a given page. toURL :: FilePath -> FilePath -toURL = flip addExtension ".html" . dropExtension +toURL path = if takeExtension path `elem` [".markdown", ".md", ".tex"] + then flip addExtension ".html" $ dropExtension path + else 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 + -- | Swaps spaces for '-'. removeSpaces :: FilePath -> FilePath removeSpaces = map swap - where swap ' ' = '-' - swap x = x + 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 -> IO () makeDirectories path = createDirectoryIfMissing True dir - where dir = takeDirectory path + where + dir = takeDirectory path -- | Get all contents of a directory. Note that files starting with a dot (.) -- will be ignored. @@ -60,7 +79,8 @@ then getRecursiveContents path else return [path] return (concat paths) - where isProper = not . (== '.') . head + where + isProper = not . (== '.') . head -- | A filter that takes all file names with a given extension. Prefix the -- extension with a dot: diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs --- a/src/Text/Hakyll/Page.hs +++ b/src/Text/Hakyll/Page.hs @@ -4,23 +4,23 @@ , getValue , getBody , readPage - , writePage ) where import qualified Data.Map as M import qualified Data.List as L -import qualified Data.ByteString.Lazy.Char8 as B import Data.Maybe (fromMaybe) +import Control.Parallel.Strategies (rnf, ($|)) + import System.FilePath (FilePath, takeExtension) import System.IO import Text.Hakyll.File import Text.Hakyll.Util (trim) +import Text.Hakyll.Context (Context) import Text.Hakyll.Renderable import Text.Pandoc -import Text.Template (Context) -- | A Page is basically key-value mapping. Certain keys have special -- meanings, like for example url, body and title. @@ -32,26 +32,23 @@ -- | Obtain a value from a page. Will resturn an empty string when nothing is -- found. -getValue :: String -> Page -> B.ByteString -getValue str (Page page) = fromMaybe B.empty $ M.lookup (B.pack str) page - --- | Auxiliary function to pack a pair. -packPair :: (String, String) -> (B.ByteString, B.ByteString) -packPair (a, b) = (B.pack a, B.pack b) +getValue :: String -> Page -> String +getValue str (Page page) = fromMaybe [] $ M.lookup str page -- | Get the URL for a certain page. This should always be defined. If -- not, it will error. getPageURL :: Page -> String -getPageURL (Page page) = B.unpack $ fromMaybe (error "No page url") $ M.lookup (B.pack "url") page +getPageURL (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page -- | Get the original page path. getPagePath :: Page -> String -getPagePath (Page page) = B.unpack $ fromMaybe (error "No page path") $ M.lookup (B.pack "path") page +getPagePath (Page page) = + fromMaybe (error "No page path") $ M.lookup "path" page -- | Get the body for a certain page. When not defined, the body will be -- empty. -getBody :: Page -> B.ByteString -getBody (Page page) = fromMaybe B.empty $ M.lookup (B.pack "body") page +getBody :: Page -> String +getBody (Page page) = fromMaybe [] $ M.lookup "body" page -- | The default writer options for pandoc rendering. writerOptions :: WriterOptions @@ -60,21 +57,24 @@ -- | Get a render function for a given extension. renderFunction :: String -> (String -> String) renderFunction ".html" = id -renderFunction ext = writeHtmlString writerOptions . - readFunction ext defaultParserState - where readFunction ".markdown" = readMarkdown - readFunction ".md" = readMarkdown - readFunction ".tex" = readLaTeX - readFunction _ = readMarkdown +renderFunction ext = writeHtmlString writerOptions + . readFunction ext defaultParserState + where + readFunction ".markdown" = readMarkdown + readFunction ".md" = readMarkdown + readFunction ".tex" = readLaTeX + readFunction _ = readMarkdown -- | Read metadata header from a file handle. readMetaData :: Handle -> IO [(String, String)] readMetaData handle = do line <- hGetLine handle - if isDelimiter line then return [] - else do others <- readMetaData handle - return $ (trimPair . break (== ':')) line : others - where trimPair (key, value) = (trim key, trim $ tail value) + if isDelimiter line + then return [] + else do others <- readMetaData handle + return $ (trimPair . break (== ':')) line : others + where + trimPair (key, value) = (trim key, trim $ tail value) -- | Check if the given string is a metadata delimiter. isDelimiter :: String -> Bool @@ -87,14 +87,13 @@ makeDirectories destination handle <- openFile destination WriteMode hPutStrLn handle "---" - mapM_ (writePair handle) $ M.toList $ M.delete (B.pack "body") mapping + mapM_ (writePair handle) $ M.toList $ M.delete "body" mapping hPutStrLn handle "---" - B.hPut handle $ getBody page + hPutStr handle $ getBody page hClose handle - where writePair h (k, v) = B.hPut h k >> - B.hPut h (B.pack ": ") >> - B.hPut h v >> - hPutStrLn h "" + where + writePair h (k, v) = do hPutStr h $ k ++ ": " ++ v + hPutStrLn h "" -- | Read a page from a file. Metadata is supported, and if the filename -- has a .markdown extension, it will be rendered using pandoc. Note that @@ -108,33 +107,30 @@ -- Read file. handle <- openFile path ReadMode line <- hGetLine handle - (context, body) <- if isDelimiter line - then do md <- readMetaData handle - c <- hGetContents handle - return (md, c) - else hGetContents handle >>= \b -> return ([], line ++ b) + (metaData, body) <- + if isDelimiter line + then do md <- readMetaData handle + b <- hGetContents handle + return (md, b) + else do b <- hGetContents handle + return ([], line ++ "\n" ++ b) -- Render file - let rendered = B.pack $ (renderFunction $ takeExtension path) body - seq rendered $ hClose handle - let page = fromContext $ M.fromList $ - [ (B.pack "body", rendered) - , packPair ("url", url) - , packPair ("path", pagePath) - ] ++ map packPair context + let rendered = (renderFunction $ takeExtension path) body + page = fromContext $ M.fromList $ + [ ("body", rendered) + , ("url", url) + , ("path", pagePath) + ] ++ metaData + seq (($|) id rnf rendered) $ hClose handle + -- Cache if needed if getFromCache then return () else cachePage page return page - where url = toURL pagePath - cacheFile = toCache url - --- | Write a page to the site destination. -writePage :: Page -> IO () -writePage page = do - let destination = toDestination $ getURL page - makeDirectories destination - B.writeFile destination (getBody page) + where + url = toURL pagePath + cacheFile = toCache url -- Make pages renderable. instance Renderable Page where diff --git a/src/Text/Hakyll/Regex.hs b/src/Text/Hakyll/Regex.hs --- a/src/Text/Hakyll/Regex.hs +++ b/src/Text/Hakyll/Regex.hs @@ -1,8 +1,8 @@ -- | A module that exports a simple regex interface. This code is mostly copied -- from the regex-compat package at hackage. module Text.Hakyll.Regex - ( split - , substitute + ( splitRegex + , substituteRegex ) where import Text.Regex.TDFA @@ -13,10 +13,10 @@ matchRegexAll p str = matchM p str -- | 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 :: 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 @@ -43,9 +43,9 @@ -- | 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 +splitRegex' :: Regex -> String -> [String] +splitRegex' _ [] = [] +splitRegex' delim strIn = loop strIn where loop str = case matchOnceText delim str of Nothing -> [str] Just (firstline, _, remainder) -> @@ -54,13 +54,13 @@ else firstline : loop remainder -- | Split a list at a certain element. -split :: String -> String -> [String] -split pattern = filter (not . null) - . splitRegex (makeRegex pattern) +splitRegex :: String -> String -> [String] +splitRegex pattern = filter (not . null) + . splitRegex' (makeRegex pattern) -- | Substitute a regex. Simplified interface. -substitute :: String -- ^ Pattern to replace (regex). - -> String -- ^ Replacement string. - -> String -- ^ Input string. - -> String -- ^ Result. -substitute pattern replacement str = subRegex (makeRegex pattern) str replacement +substituteRegex :: String -- ^ Pattern to replace (regex). + -> String -- ^ Replacement string. + -> String -- ^ Input string. + -> String -- ^ Result. +substituteRegex pattern replacement str = subRegex (makeRegex pattern) str replacement diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -10,10 +10,7 @@ , css ) where -import Text.Template hiding (render) -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Data.Map as M -import Control.Monad (unless, liftM, foldM) +import Control.Monad (unless, mapM) import System.Directory (copyFile) import System.IO @@ -24,6 +21,8 @@ import Text.Hakyll.File import Text.Hakyll.CompressCSS +import Text.Hakyll.Render.Internal + -- | Execute an IO action only when the cache is invalid. depends :: FilePath -- ^ File to be rendered or created. -> [FilePath] -- ^ Files the render depends on. @@ -48,16 +47,13 @@ -> a -- ^ Renderable object to render with given template. -> IO Page -- ^ The body of the result will contain the render. renderWith manipulation templatePath renderable = do - handle <- openFile templatePath ReadMode - templateString <- liftM B.pack $ hGetContents handle - seq templateString $ hClose handle - context <- liftM manipulation $ toContext renderable - let body = substitute templateString context - return $ fromContext (M.insert (B.pack "body") body context) + template <- readFile templatePath + context <- toContext renderable + return $ fromContext $ pureRenderWith manipulation template context -- | Render each renderable with the given template, then concatenate the -- result. -renderAndConcat :: Renderable a => FilePath -> [a] -> IO B.ByteString +renderAndConcat :: Renderable a => FilePath -> [a] -> IO String renderAndConcat = renderAndConcatWith id -- | Render each renderable with the given template, then concatenate the @@ -67,14 +63,11 @@ => ContextManipulation -> FilePath -> [a] - -> IO B.ByteString -renderAndConcatWith manipulation templatePath renderables = - foldM concatRender' B.empty renderables - where concatRender' :: Renderable a => B.ByteString -> a -> IO B.ByteString - concatRender' chunk renderable = do - rendered <- renderWith manipulation templatePath renderable - let body = getBody rendered - return $ B.append chunk $ body + -> IO String +renderAndConcatWith manipulation templatePath renderables = do + template <- readFile templatePath + contexts <- mapM toContext renderables + return $ pureRenderAndConcatWith manipulation template 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 @@ -86,24 +79,27 @@ -- "ContextManipulation" which to apply on the context when it is read first. renderChainWith :: Renderable a => ContextManipulation -> [FilePath] -> a -> IO () -renderChainWith manipulation templates renderable = - depends (getURL renderable) (getDependencies renderable ++ templates) $ - do initialPage <- liftM manipulation $ toContext renderable - result <- foldM (flip render) (fromContext initialPage) templates - writePage result +renderChainWith manipulation templatePaths renderable = + depends (getURL renderable) (getDependencies renderable ++ templatePaths) $ + do templates <- mapM readFile templatePaths + context <- toContext renderable + let result = pureRenderChainWith manipulation templates context + writePage $ fromContext result -- | Mark a certain file as static, so it will just be copied when the site is -- generated. static :: FilePath -> IO () -static source = depends destination [source] - (makeDirectories destination >> copyFile source destination) - where destination = toDestination source +static source = depends destination [source] action + where + destination = toDestination source + action = do makeDirectories destination + copyFile source destination -- | Render a css file, compressing it. css :: FilePath -> IO () css source = depends destination [source] css' - where destination = toDestination source - css' = do h <- openFile source ReadMode - contents <- hGetContents h - makeDirectories destination - writeFile destination (compressCSS contents) + where + destination = toDestination source + css' = do contents <- readFile source + makeDirectories destination + writeFile destination (compressCSS contents) diff --git a/src/Text/Hakyll/Render/Internal.hs b/src/Text/Hakyll/Render/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Render/Internal.hs @@ -0,0 +1,91 @@ +-- | 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 Text.Hakyll.Context (Context, ContextManipulation) +import Data.List (isPrefixOf, foldl') +import Data.Char (isAlpha) +import Data.Maybe (fromMaybe) +import Control.Parallel.Strategies (rnf, ($|)) +import Text.Hakyll.Renderable +import Text.Hakyll.Page +import Text.Hakyll.File + +-- | 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 -> String -> Context -> String +substitute _ [] _ = [] +substitute escaper string context + | "$$" `isPrefixOf` string = escaper ++ substitute' (tail tail') + | "$" `isPrefixOf` string = substituteKey + | otherwise = (head string) : (substitute' tail') + where + tail' = tail string + (key, rest) = break (not . isAlpha) tail' + replacement = fromMaybe ('$' : key) $ M.lookup key context + substituteKey = replacement ++ substitute' rest + substitute' str = substitute escaper str context + +-- | "substitute" for use during a chain. +regularSubstitute :: String -> Context -> String +regularSubstitute = substitute "$$" + +-- | "substitute" for the end of a chain (just before writing). +finalSubstitute :: String -> Context -> String +finalSubstitute = substitute "$" + +-- | A pure render function. +pureRenderWith :: ContextManipulation -- ^ Manipulation to apply on the context. + -> String -- ^ 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 + -- Force the body to be rendered. + in ($|) id rnf (M.insert "body" body context) + +-- | A pure renderAndConcat function. +pureRenderAndConcatWith :: ContextManipulation + -> String -- ^ Template to use. + -> [Context] -- ^ Different renderables. + -> String +pureRenderAndConcatWith manipulation template contexts = + foldl' renderAndConcat [] contexts + where + renderAndConcat chunk context = + let rendered = pureRenderWith manipulation template context + in chunk ++ fromMaybe "" (M.lookup "body" rendered) + +-- | A pure renderChain function. +pureRenderChainWith :: ContextManipulation + -> [String] + -> 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 -> IO () +writePage page = do + let destination = toDestination url + makeDirectories destination + writeFile destination body + where + url = getURL page + -- Substitute $root here, just before writing. + body = finalSubstitute (getBody page) + (M.singleton "root" $ toRoot url) diff --git a/src/Text/Hakyll/Renderable.hs b/src/Text/Hakyll/Renderable.hs --- a/src/Text/Hakyll/Renderable.hs +++ b/src/Text/Hakyll/Renderable.hs @@ -3,7 +3,7 @@ ) where import System.FilePath (FilePath) -import Text.Template (Context) +import Text.Hakyll.Context (Context) -- | A class for datatypes that can be rendered to pages. class Renderable a where diff --git a/src/Text/Hakyll/Renderables.hs b/src/Text/Hakyll/Renderables.hs --- a/src/Text/Hakyll/Renderables.hs +++ b/src/Text/Hakyll/Renderables.hs @@ -6,7 +6,6 @@ ) where import System.FilePath (FilePath) -import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M import Text.Hakyll.Page import Text.Hakyll.Renderable @@ -16,13 +15,13 @@ data CustomPage = CustomPage { url :: String, dependencies :: [FilePath], - mapping :: [(String, Either String (IO B.ByteString))] + mapping :: [(String, Either String (IO String))] } -- | Create a custom page. createCustomPage :: String -- ^ Destination of the page, relative to _site. -> [FilePath] -- ^ Dependencies of the page. - -> [(String, Either String (IO B.ByteString))] -- ^ Key - value mapping for rendering. + -> [(String, Either String (IO String))] -- ^ Key - value mapping for rendering. -> CustomPage createCustomPage = CustomPage @@ -30,9 +29,9 @@ getDependencies = dependencies getURL = url toContext page = do - values <- mapM (either (return . B.pack) (>>= return) . snd) (mapping page) - let keys = map (B.pack . fst) (mapping page) - return $ M.fromList $ (B.pack "url", B.pack $ url page) : zip keys values + values <- mapM (either (return) (>>= return) . snd) (mapping page) + return $ M.fromList $ [ ("url", url page) + ] ++ zip (map fst $ mapping page) values -- | PagePath is a class that wraps a FilePath. This is used to render Pages -- without reading them first through use of caching. diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -7,7 +7,6 @@ ) where import qualified Data.Map as M -import qualified Data.ByteString.Lazy.Char8 as B import Data.List (intercalate) import Control.Monad (foldM) @@ -22,10 +21,11 @@ -- commas. readTagMap :: [FilePath] -> IO (M.Map String [FilePath]) readTagMap paths = foldM addPaths M.empty paths - where addPaths current path = do - page <- readPage path - let tags = map trim $ split "," $ B.unpack $ getValue ("tags") page - return $ foldr (\t -> M.insertWith (++) t [path]) current tags + where + addPaths current path = do + page <- readPage path + let tags = map trim $ splitRegex "," $ getValue ("tags") page + return $ foldr (\t -> M.insertWith (++) t [path]) current tags -- | Render a tag cloud. renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTagMap'. @@ -35,28 +35,31 @@ -> String -- ^ Result of the render. renderTagCloud tagMap urlFunction minSize maxSize = intercalate " " $ map renderTag tagCount - where renderTag :: (String, Float) -> String - renderTag (tag, count) = "" - ++ tag ++ "" + where + renderTag :: (String, Float) -> String + renderTag (tag, count) = "" + ++ tag ++ "" - sizeTag :: Float -> String - sizeTag count = show size' ++ "%" - where size' :: Int - size' = floor (minSize + (relative count) * (maxSize - minSize)) - - minCount = minimum $ map snd $ tagCount - maxCount = maximum $ map snd $ tagCount - relative count = (count - minCount) / (maxCount - minCount) + sizeTag :: Float -> String + sizeTag count = show size' ++ "%" + where + size' :: Int + size' = floor (minSize + (relative count) * (maxSize - minSize)) - tagCount :: [(String, Float)] - tagCount = map (second $ fromIntegral . length) $ M.toList tagMap + minCount = minimum $ map snd $ tagCount + maxCount = maximum $ map snd $ tagCount + relative count = (count - minCount) / (maxCount - minCount) + tagCount :: [(String, Float)] + tagCount = map (second $ fromIntegral . length) $ M.toList tagMap + -- Render all tags to links. renderTagLinks :: (String -> String) -- ^ Function that produces an url for a tag. -> ContextManipulation renderTagLinks urlFunction = renderValue "tags" "tags" renderTagLinks' - where renderTagLinks' = B.pack . intercalate ", " - . map (\t -> link t $ urlFunction t) - . map trim . split "," . B.unpack + where + renderTagLinks' = intercalate ", " + . map (\t -> link t $ urlFunction t) + . map trim . splitRegex "," diff --git a/src/Text/Hakyll/Util.hs b/src/Text/Hakyll/Util.hs --- a/src/Text/Hakyll/Util.hs +++ b/src/Text/Hakyll/Util.hs @@ -9,7 +9,8 @@ -- | Trim a string (drop spaces and tabs at both sides). trim :: String -> String trim = reverse . trim' . reverse . trim' - where trim' = dropWhile isSpace + where + trim' = dropWhile isSpace -- | Strip html tags. stripHTML :: String -> String @@ -18,8 +19,9 @@ (_, afterTag) = break (== '>') rest in beforeTag ++ (stripHTML $ tail' afterTag) -- We need a failsafe tail function. - where tail' [] = [] - tail' xs = tail xs + where + tail' [] = [] + tail' xs = tail xs -- | Make a HTML link. --