hakyll 0.4.1 → 1.0
raw patch · 14 files changed
+383/−256 lines, 14 filesdep +paralleldep −bytestringdep −template
Dependencies added: parallel
Dependencies removed: bytestring, template
Files
- hakyll.cabal +4/−4
- src/Network/Hakyll/SimpleServer.hs +92/−78
- src/Text/Hakyll.hs +8/−7
- src/Text/Hakyll/CompressCSS.hs +12/−10
- src/Text/Hakyll/Context.hs +20/−17
- src/Text/Hakyll/File.hs +28/−8
- src/Text/Hakyll/Page.hs +46/−50
- src/Text/Hakyll/Regex.hs +17/−17
- src/Text/Hakyll/Render.hs +28/−32
- src/Text/Hakyll/Render/Internal.hs +91/−0
- src/Text/Hakyll/Renderable.hs +1/−1
- src/Text/Hakyll/Renderables.hs +5/−6
- src/Text/Hakyll/Tags.hs +26/−23
- src/Text/Hakyll/Util.hs +5/−3
hakyll.cabal view
@@ -1,5 +1,5 @@ Name: hakyll-Version: 0.4.1+Version: 1.0 Synopsis: A simple static site generator library. Description:@@ -24,18 +24,17 @@ ghc-options: -Wall hs-source-dirs: src/ build-depends: base >= 4 && < 5,- template >= 0.1.1, filepath >= 1.1, directory >= 1, containers >= 0.1,- bytestring >= 0.9 && < 0.9.2, pandoc >= 1, regex-base >= 0.83, regex-tdfa >= 0.92, network >= 2, mtl >= 1.1, old-locale >= 1,- time >= 1+ time >= 1,+ parallel >= 1 exposed-modules: Text.Hakyll Text.Hakyll.Render Text.Hakyll.Renderable@@ -48,3 +47,4 @@ Text.Hakyll.Context Text.Hakyll.Regex Network.Hakyll.SimpleServer+ other-modules: Text.Hakyll.Render.Internal
src/Network/Hakyll/SimpleServer.hs view
@@ -8,13 +8,13 @@ import Network import Control.Monad (forever, mapM_) import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)-import System.IO (Handle, hClose, hGetLine, hPutStr, hPutStrLn, stderr)+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.ByteString.Char8 as B import qualified Data.Map as M+import Data.List (intercalate) import Text.Hakyll.Util import Text.Hakyll.Regex@@ -33,65 +33,67 @@ type Server = ReaderT ServerConfig IO -- | Simple representation of a HTTP request.-data Request = Request { requestMethod :: B.ByteString- , requestURI :: B.ByteString- , requestVersion :: B.ByteString+data Request = Request { requestMethod :: String+ , requestURI :: String+ , requestVersion :: String } deriving (Ord, Eq) instance Show Request where- show request = (B.unpack $ requestMethod request) ++ " "- ++ (B.unpack $ requestURI request) ++ " "- ++ (B.unpack $ requestVersion request)+ 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 $ split " " requestLine- return $ Request { requestMethod = B.pack method- , requestURI = B.pack uri- , requestVersion = B.pack version+ let [method, uri, version] = map trim $ splitRegex " " requestLine+ return $ Request { requestMethod = method+ , requestURI = uri+ , requestVersion = version } -- | Simple representation of the HTTP response we send back.-data Response = Response { responseVersion :: B.ByteString+data Response = Response { responseVersion :: String , responseStatusCode :: Int- , responsePhrase :: B.ByteString- , responseHeaders :: M.Map B.ByteString B.ByteString- , responseBody :: B.ByteString+ , responsePhrase :: String+ , responseHeaders :: M.Map String String+ , responseBody :: String } deriving (Ord, Eq) instance Show Response where- show response = (B.unpack $ responseVersion response) ++ " "+ show response = responseVersion response ++ " " ++ (show $ responseStatusCode response) ++ " "- ++ (B.unpack $ responsePhrase response)+ ++ responsePhrase response -- | A default response. defaultResponse :: Response-defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"+defaultResponse = Response { responseVersion = "HTTP/1.1" , responseStatusCode = 0- , responsePhrase = B.empty+ , responsePhrase = "" , responseHeaders = M.empty- , responseBody = B.empty+ , responseBody = "" } -- | Create a response for a given HTTP request. createResponse :: Request -> Server Response-createResponse request | requestMethod request == B.pack "GET" = createGetResponse request- | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")+createResponse request+ | requestMethod request == "GET" = createGetResponse request+ | otherwise = return $ createErrorResponse 501 "Not Implemented" -- | Create a simple error response.-createErrorResponse :: Int -- ^ Error code.- -> B.ByteString -- ^ Error phrase.- -> Response -- ^ Result.+createErrorResponse :: Int -- ^ Error code.+ -> String -- ^ Error phrase.+ -> Response -- ^ Result. createErrorResponse statusCode phrase = defaultResponse { responseStatusCode = statusCode , responsePhrase = phrase- , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")- , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"- ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"- ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"+ , responseHeaders = M.singleton "Content-Type" "text/html"+ , responseBody =+ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"+ ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"+ ++ "<p>" ++ phrase ++ "</p> </body> </html>" } -- | 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 -
src/Text/Hakyll.hs view
@@ -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"
src/Text/Hakyll/CompressCSS.hs view
@@ -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'
src/Text/Hakyll/Context.hs view
@@ -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
src/Text/Hakyll/File.hs view
@@ -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:
src/Text/Hakyll/Page.hs view
@@ -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
src/Text/Hakyll/Regex.hs view
@@ -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
src/Text/Hakyll/Render.hs view
@@ -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)
+ src/Text/Hakyll/Render/Internal.hs view
@@ -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)
src/Text/Hakyll/Renderable.hs view
@@ -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
src/Text/Hakyll/Renderables.hs view
@@ -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.
src/Text/Hakyll/Tags.hs view
@@ -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) = "<a style=\"font-size: "- ++ sizeTag count ++ "\" href=\""- ++ urlFunction tag ++ "\">"- ++ tag ++ "</a>"+ where+ renderTag :: (String, Float) -> String+ renderTag (tag, count) = "<a style=\"font-size: "+ ++ sizeTag count ++ "\" href=\""+ ++ urlFunction tag ++ "\">"+ ++ tag ++ "</a>" - 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 ","
src/Text/Hakyll/Util.hs view
@@ -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. --