dae0258 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Readability++.

dae0258Jasper Van der Jeugt17 years ago

src/Network/Hakyll/SimpleServer.hs+63−51

compare with master

unifiedsplit

@@ -78,8 +78,9 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"

79-- | Create a response for a given HTTP request.

80createResponse :: Request -> Server Response

81+createResponse request

81−createResponse request | requestMethod request == B.pack "GET" = createGetResponse request

82+ | requestMethod request == B.pack "GET" = createGetResponse request

82− | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")

83+ | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")

84-- | Create a simple error response.

85-- | Create a simple error response.

85createErrorResponse :: Int -- ^ Error code.

86createErrorResponse :: Int -- ^ Error code.

@@ -89,9 +90,10 @@ createErrorResponse statusCode phrase = defaultResponse

89 { responseStatusCode = statusCode

90 { responseStatusCode = statusCode

90 , responsePhrase = phrase

91 , responsePhrase = phrase

91 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")

92 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")

93+ , responseBody = B.pack $

92− , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"

94+ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"

93− ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"

95+ ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"

94− ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"

96+ ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"

95 }

97 }

97-- | Create a simple get response.

99-- | Create a simple get response.

@@ -100,48 +102,56 @@ createGetResponse request = do

100 -- Construct the complete fileName of the requested resource.

102 -- Construct the complete fileName of the requested resource.

101 config <- ask

103 config <- ask

102 let uri = B.unpack (requestURI request)

104 let uri = B.unpack (requestURI request)

105+ log' = writeChan (logChannel config)

103 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri

106 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri

107+ let fileName =

104− let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"

108+ (documentRoot config) ++ if isDirectory then uri ++ "/index.html"

105− else uri

109+ else uri

106

110

107 create200 = do

111 create200 = do

108 body <- B.readFile fileName

112 body <- B.readFile fileName

113+ let headers =

109− let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)

114+ [ (B.pack "Content-Length", B.pack $ show $ B.length body)

110− ] ++ getMIMEHeader fileName

115+ ] ++ getMIMEHeader fileName

111− return $ defaultResponse { responseStatusCode = 200

116+ return $ defaultResponse

117+ { responseStatusCode = 200

112− , responsePhrase = B.pack "OK"

118+ , responsePhrase = B.pack "OK"

113− , responseHeaders = (responseHeaders defaultResponse)

119+ , responseHeaders = (responseHeaders defaultResponse)

114− `M.union` M.fromList headers

120+ `M.union` M.fromList headers

115− , responseBody = body

121+ , responseBody = body

116− }

122+ }

117

123

118 -- Called when an error occurs during the creation of a 200 response.

124 -- Called when an error occurs during the creation of a 200 response.

125+ create500 e = do

119− create500 e = do writeChan (logChannel config) $ "Internal Error: " ++ show e

126+ log' $ "Internal Error: " ++ show e

120− return $ createErrorResponse 500 (B.pack "Internal Server Error")

127+ return $ createErrorResponse 500 (B.pack "Internal Server Error")

121

128

122 -- Send back the page if found.

129 -- Send back the page if found.

123 exists <- liftIO $ doesFileExist fileName

130 exists <- liftIO $ doesFileExist fileName

131+ if exists

124− if exists then do response <- liftIO $ catch create200 create500

132+ then do response <- liftIO $ catch create200 create500

125− return response

133+ return response

126− else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName

134+ else do liftIO $ log' $ "Not Found: " ++ fileName

127− return $ createErrorResponse 404 (B.pack "Not Found")

135+ return $ createErrorResponse 404 (B.pack "Not Found")

128

136

129-- | Get the mime header for a certain filename. This is based on the extension

137-- | Get the mime header for a certain filename. This is based on the extension

130-- of the given 'FilePath'.

138-- of the given 'FilePath'.

131getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]

139getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]

140+getMIMEHeader fileName =

132−getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]

141+ case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]

133− Nothing -> []

142+ Nothing -> []

143+ where

134− where result = lookup (takeExtension fileName) [ (".css", "text/css")

144+ result = lookup (takeExtension fileName) [ (".css", "text/css")

135− , (".gif", "image/gif")

145+ , (".gif", "image/gif")

136− , (".htm", "text/html")

146+ , (".htm", "text/html")

137− , (".html", "text/html")

147+ , (".html", "text/html")

138− , (".jpeg", "image/jpeg")

148+ , (".jpeg", "image/jpeg")

139− , (".jpg", "image/jpeg")

149+ , (".jpg", "image/jpeg")

140− , (".js", "text/javascript")

150+ , (".js", "text/javascript")

141− , (".png", "image/png")

151+ , (".png", "image/png")

142− , (".txt", "text/plain")

152+ , (".txt", "text/plain")

143− , (".xml", "text/xml")

153+ , (".xml", "text/xml")

144− ]

154+ ]

145

155

146-- | Respond to an incoming request.

156-- | Respond to an incoming request.

147respond :: Handle -> Server ()

157respond :: Handle -> Server ()

@@ -152,24 +162,28 @@ respond handle = do

152

162

153 -- Generate some output.

163 -- Generate some output.

154 config <- ask

164 config <- ask

155− liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response

165+ liftIO $ writeChan (logChannel config)

166+ $ show request ++ " => " ++ show response

156

167

157 -- Send the response back to the handle.

168 -- Send the response back to the handle.

158 liftIO $ putResponse response

169 liftIO $ putResponse response

170+ where

159− where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")

171+ putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")

160− [ responseVersion response

172+ [ responseVersion response

161− , B.pack $ show $ responseStatusCode response

173+ , B.pack $ show $ responseStatusCode response

162− , responsePhrase response

174+ , responsePhrase response

163− ]

175+ ]

164− hPutStr handle "\r\n"

176+ hPutStr handle "\r\n"

177+ mapM_ putHeader

165− mapM_ putHeader (M.toList $ responseHeaders response)

178+ (M.toList $ responseHeaders response)

166− hPutStr handle "\r\n"

179+ hPutStr handle "\r\n"

167− B.hPutStr handle $ responseBody response

180+ B.hPutStr handle $ responseBody response

168− hPutStr handle "\r\n"

181+ hPutStr handle "\r\n"

169− hClose handle

182+ hClose handle

170−

183+

184+ putHeader (key, value) =

171− putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "

185+ B.hPutStr handle $ key `B.append` B.pack ": "

172− `B.append` value `B.append` B.pack "\r\n"

186+ `B.append` value `B.append` B.pack "\r\n"

173

187

174-- | Start a simple http server on the given 'PortNumber', serving the given

188-- | Start a simple http server on the given 'PortNumber', serving the given

175-- directory.

189-- directory.

@@ -194,5 +208,3 @@ simpleServer port root = do

194 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."

208 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."

195 socket <- listenOn (PortNumber port)

209 socket <- listenOn (PortNumber port)

196 forever (listen socket)

210 forever (listen socket)

197− where

198−

src/Text/Hakyll.hs+5−4

@@ -28,10 +28,11 @@ build buildFunction = do putStrLn "Generating..."

28clean :: IO ()

29clean = do remove' "_cache"

30 remove' "_site"

31+ where

31− where remove' dir = do putStrLn $ "Removing " ++ dir ++ "..."

32+ remove' dir = do putStrLn $ "Removing " ++ dir ++ "..."

32− exists <- doesDirectoryExist dir

33+ exists <- doesDirectoryExist dir

33− if exists then removeDirectoryRecursive dir

34+ if exists then removeDirectoryRecursive dir

34− else return ()

35+ else return ()

36-- | Show usage information.

37-- | Show usage information.

37help :: IO ()

38help :: IO ()

src/Text/Hakyll/CompressCSS.hs+7−5

@@ -24,8 +24,10 @@ compressWhitespace = substituteRegex "[ \t\n][ \t\n]*" " "

24-- | Function that strips CSS comments away.

25stripComments :: String -> String

26stripComments [] = []

27+stripComments str

27−stripComments str | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str

28+ | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str

28− | otherwise = (head str) : (stripComments $ tail str)

29+ | otherwise = (head str) : (stripComments $ tail str)

30+ where

29− where eatComments str' | null str' = []

31+ eatComments str' | null str' = []

30− | isPrefixOf "*/" str' = drop 2 str'

32+ | isPrefixOf "*/" str' = drop 2 str'

31− | otherwise = eatComments $ tail str'

33+ | otherwise = eatComments $ tail str'

src/Text/Hakyll/Context.hs+9−8

@@ -38,11 +38,12 @@ renderDate :: String -- ^ Key in which the rendered date should be placed.

38 -> String -- ^ Default value when the date cannot be parsed.

39 -> ContextManipulation

40renderDate key format defaultValue context = M.insert key value context

41+ where

41− where value = fromMaybe defaultValue pretty

42+ value = fromMaybe defaultValue pretty

42− pretty = do filePath <- M.lookup "path" context

43+ pretty = do filePath <- M.lookup "path" context

43− let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1"

44+ let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1"

44− (takeFileName filePath)

45+ (takeFileName filePath)

45− time <- parseTime defaultTimeLocale

46+ time <- parseTime defaultTimeLocale

46− "%Y-%m-%d"

47+ "%Y-%m-%d"

47− dateString :: Maybe UTCTime

48+ dateString :: Maybe UTCTime

48− return $ formatTime defaultTimeLocale format time

49+ return $ formatTime defaultTimeLocale format time

src/Text/Hakyll/File.hs+14−9

@@ -25,8 +25,9 @@ removeLeadingSeparator [] = []

25removeLeadingSeparator path

26 | (head path') `elem` pathSeparators = (tail path')

27 | otherwise = path'

28+ where

28− where path' = if "$root" `isPrefixOf` path then drop 5 path

29+ path' = if "$root" `isPrefixOf` path then drop 5 path

29− else path

30+ else path

31-- | Convert a relative filepath to a filepath in the destination (_site).

32-- | Convert a relative filepath to a filepath in the destination (_site).

32toDestination :: FilePath -> FilePath

33toDestination :: FilePath -> FilePath

@@ -46,21 +47,24 @@ toURL path = if takeExtension path `elem` [".markdown", ".md", ".tex"]

46toRoot :: FilePath -> FilePath

47toRoot :: FilePath -> FilePath

47toRoot = emptyException . joinPath . map parent . splitPath

48toRoot = emptyException . joinPath . map parent . splitPath

48 . takeDirectory . removeLeadingSeparator

49 . takeDirectory . removeLeadingSeparator

50+ where

49− where parent = const ".."

51+ parent = const ".."

50− emptyException [] = "."

52+ emptyException [] = "."

51− emptyException x = x

53+ emptyException x = x

53-- | Swaps spaces for '-'.

55-- | Swaps spaces for '-'.

54removeSpaces :: FilePath -> FilePath

56removeSpaces :: FilePath -> FilePath

55removeSpaces = map swap

57removeSpaces = map swap

56− where swap ' ' = '-'

58+ where

59+ swap ' ' = '-'

57− swap x = x

60+ swap x = x

59-- | Given a path to a file, try to make the path writable by making

62-- | Given a path to a file, try to make the path writable by making

60-- all directories on the path.

63-- all directories on the path.

61makeDirectories :: FilePath -> IO ()

64makeDirectories :: FilePath -> IO ()

62makeDirectories path = createDirectoryIfMissing True dir

65makeDirectories path = createDirectoryIfMissing True dir

66+ where

63− where dir = takeDirectory path

67+ dir = takeDirectory path

65-- | Get all contents of a directory. Note that files starting with a dot (.)

69-- | Get all contents of a directory. Note that files starting with a dot (.)

66-- will be ignored.

70-- will be ignored.

@@ -75,7 +79,8 @@ getRecursiveContents topdir = do

75 then getRecursiveContents path

79 then getRecursiveContents path

76 else return [path]

80 else return [path]

77 return (concat paths)

81 return (concat paths)

82+ where

78− where isProper = not . (== '.') . head

83+ isProper = not . (== '.') . head

80-- | A filter that takes all file names with a given extension. Prefix the

85-- | A filter that takes all file names with a given extension. Prefix the

81-- extension with a dot:

86-- extension with a dot:

src/Text/Hakyll/Page.hs+29−22

@@ -42,7 +42,8 @@ getPageURL (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page

43-- | Get the original page path.

44getPagePath :: Page -> String

45+getPagePath (Page page) =

45−getPagePath (Page page) = fromMaybe (error "No page path") $ M.lookup "path" page

46+ fromMaybe (error "No page path") $ M.lookup "path" page

47-- | Get the body for a certain page. When not defined, the body will be

48-- | Get the body for a certain page. When not defined, the body will be

48-- empty.

49-- empty.

@@ -56,21 +57,24 @@ writerOptions = defaultWriterOptions

56-- | Get a render function for a given extension.

57-- | Get a render function for a given extension.

57renderFunction :: String -> (String -> String)

58renderFunction :: String -> (String -> String)

58renderFunction ".html" = id

59renderFunction ".html" = id

59−renderFunction ext = writeHtmlString writerOptions .

60+renderFunction ext = writeHtmlString writerOptions

60− readFunction ext defaultParserState

61+ . readFunction ext defaultParserState

62+ where

61− where readFunction ".markdown" = readMarkdown

63+ readFunction ".markdown" = readMarkdown

62− readFunction ".md" = readMarkdown

64+ readFunction ".md" = readMarkdown

63− readFunction ".tex" = readLaTeX

65+ readFunction ".tex" = readLaTeX

64− readFunction _ = readMarkdown

66+ readFunction _ = readMarkdown

66-- | Read metadata header from a file handle.

68-- | Read metadata header from a file handle.

67readMetaData :: Handle -> IO [(String, String)]

69readMetaData :: Handle -> IO [(String, String)]

68readMetaData handle = do

70readMetaData handle = do

69 line <- hGetLine handle

71 line <- hGetLine handle

70− if isDelimiter line then return []

72+ if isDelimiter line

73+ then return []

71− else do others <- readMetaData handle

74+ else do others <- readMetaData handle

72− return $ (trimPair . break (== ':')) line : others

75+ return $ (trimPair . break (== ':')) line : others

76+ where

73− where trimPair (key, value) = (trim key, trim $ tail value)

77+ trimPair (key, value) = (trim key, trim $ tail value)

75-- | Check if the given string is a metadata delimiter.

79-- | Check if the given string is a metadata delimiter.

76isDelimiter :: String -> Bool

80isDelimiter :: String -> Bool

@@ -87,10 +91,11 @@ cachePage page@(Page mapping) = do

87 hPutStrLn handle "---"

91 hPutStrLn handle "---"

88 hPutStr handle $ getBody page

92 hPutStr handle $ getBody page

89 hClose handle

93 hClose handle

94+ where

90− where writePair h (k, v) = hPutStr h k >>

95+ writePair h (k, v) = do hPutStr h k

91− hPutStr h ": " >>

96+ hPutStr h ": "

92− hPutStr h v >>

97+ hPutStr h v

93− hPutStrLn h ""

98+ hPutStrLn h ""

95-- | Read a page from a file. Metadata is supported, and if the filename

100-- | Read a page from a file. Metadata is supported, and if the filename

96-- has a .markdown extension, it will be rendered using pandoc. Note that

101-- has a .markdown extension, it will be rendered using pandoc. Note that

@@ -104,11 +109,12 @@ readPage pagePath = do

104 -- Read file.

109 -- Read file.

105 handle <- openFile path ReadMode

110 handle <- openFile path ReadMode

106 line <- hGetLine handle

111 line <- hGetLine handle

112+ (context, body) <-

107− (context, body) <- if isDelimiter line

113+ if isDelimiter line

108− then do md <- readMetaData handle

114+ then do md <- readMetaData handle

109− c <- hGetContents handle

115+ c <- hGetContents handle

110− return (md, c)

116+ return (md, c)

111− else hGetContents handle >>= \b -> return ([], line ++ b)

117+ else hGetContents handle >>= \b -> return ([], line ++ b)

112

118

113 -- Render file

119 -- Render file

114 let rendered = (renderFunction $ takeExtension path) body

120 let rendered = (renderFunction $ takeExtension path) body

@@ -123,8 +129,9 @@ readPage pagePath = do

123 -- Cache if needed

129 -- Cache if needed

124 if getFromCache then return () else cachePage page

130 if getFromCache then return () else cachePage page

125 return page

131 return page

132+ where

126− where url = toURL pagePath

133+ url = toURL pagePath

127− cacheFile = toCache url

134+ cacheFile = toCache url

128

135

129-- Make pages renderable.

136-- Make pages renderable.

130instance Renderable Page where

137instance Renderable Page where

src/Text/Hakyll/Render.hs+27−22

@@ -43,11 +43,12 @@ substitute escaper string context

43 | "$$" `isPrefixOf` string = escaper ++ substitute' (tail tail')

44 | "$" `isPrefixOf` string = substituteKey

45 | otherwise = (head string) : (substitute' tail')

46+ where

46− where tail' = tail string

47+ tail' = tail string

47− (key, rest) = break (not . isAlpha) tail'

48+ (key, rest) = break (not . isAlpha) tail'

48− replacement = fromMaybe ('$' : key) $ M.lookup key context

49+ replacement = fromMaybe ('$' : key) $ M.lookup key context

49− substituteKey = replacement ++ substitute' rest

50+ substituteKey = replacement ++ substitute' rest

50− substitute' str = substitute escaper str context

51+ substitute' str = substitute escaper str context

52-- | "substitute" for use during a chain.

53-- | "substitute" for use during a chain.

53regularSubstitute :: String -> Context -> String

54regularSubstitute :: String -> Context -> String

@@ -97,11 +98,12 @@ renderAndConcatWith :: Renderable a

97 -> IO String

98 -> IO String

98renderAndConcatWith manipulation templatePath renderables =

99renderAndConcatWith manipulation templatePath renderables =

99 foldM concatRender' [] renderables

100 foldM concatRender' [] renderables

101+ where

100− where concatRender' :: Renderable a => String -> a -> IO String

102+ concatRender' :: Renderable a => String -> a -> IO String

101− concatRender' chunk renderable = do

103+ concatRender' chunk renderable = do

102− rendered <- renderWith manipulation templatePath renderable

104+ rendered <- renderWith manipulation templatePath renderable

103− let body = getBody rendered

105+ let body = getBody rendered

104− return $ chunk ++ body

106+ return $ chunk ++ body

105

107

106-- | Chain a render action for a page with a number of templates. This will

108-- | Chain a render action for a page with a number of templates. This will

107-- also write the result to the site destination. This is the preferred way

109-- also write the result to the site destination. This is the preferred way

@@ -125,23 +127,26 @@ writePage page = do

125 let destination = toDestination url

127 let destination = toDestination url

126 makeDirectories destination

128 makeDirectories destination

127 writeFile destination body

129 writeFile destination body

130+ where

128− where url = getURL page

131+ url = getURL page

129− -- Substitute $root here, just before writing.

132+ -- Substitute $root here, just before writing.

130− body = finalSubstitute (getBody page)

133+ body = finalSubstitute (getBody page)

131− (M.singleton "root" $ toRoot url)

134+ (M.singleton "root" $ toRoot url)

132

135

133-- | Mark a certain file as static, so it will just be copied when the site is

136-- | Mark a certain file as static, so it will just be copied when the site is

134-- generated.

137-- generated.

135static :: FilePath -> IO ()

138static :: FilePath -> IO ()

136−static source = depends destination [source]

139+static source = depends destination [source] action

140+ where

141+ destination = toDestination source

142+ action = do makeDirectories destination

137− (makeDirectories destination >> copyFile source destination)

143+ copyFile source destination

138− where destination = toDestination source

139

144

140-- | Render a css file, compressing it.

145-- | Render a css file, compressing it.

141css :: FilePath -> IO ()

146css :: FilePath -> IO ()

142css source = depends destination [source] css'

147css source = depends destination [source] css'

148+ where

143− where destination = toDestination source

149+ destination = toDestination source

144− css' = do h <- openFile source ReadMode

150+ css' = do contents <- readFile source

145− contents <- hGetContents h

146− makeDirectories destination

151+ makeDirectories destination

147− writeFile destination (compressCSS contents)

152+ writeFile destination (compressCSS contents)

src/Text/Hakyll/Tags.hs+28−24

@@ -21,10 +21,11 @@ import Control.Arrow (second)

21-- commas.

22readTagMap :: [FilePath] -> IO (M.Map String [FilePath])

23readTagMap paths = foldM addPaths M.empty paths

24+ where

24− where addPaths current path = do

25+ addPaths current path = do

25− page <- readPage path

26+ page <- readPage path

26− let tags = map trim $ splitRegex "," $ getValue ("tags") page

27+ let tags = map trim $ splitRegex "," $ getValue ("tags") page

27− return $ foldr (\t -> M.insertWith (++) t [path]) current tags

28+ return $ foldr (\t -> M.insertWith (++) t [path]) current tags

29-- | Render a tag cloud.

30-- | Render a tag cloud.

30renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTagMap'.

31renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTagMap'.

@@ -34,28 +35,31 @@ renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTag

34 -> String -- ^ Result of the render.

35 -> String -- ^ Result of the render.

35renderTagCloud tagMap urlFunction minSize maxSize =

36renderTagCloud tagMap urlFunction minSize maxSize =

36 intercalate " " $ map renderTag tagCount

37 intercalate " " $ map renderTag tagCount

38+ where

37− where renderTag :: (String, Float) -> String

39+ renderTag :: (String, Float) -> String

38− renderTag (tag, count) = "<a style=\"font-size: "

40+ renderTag (tag, count) = "<a style=\"font-size: "

39− ++ sizeTag count ++ "\" href=\""

41+ ++ sizeTag count ++ "\" href=\""

40− ++ urlFunction tag ++ "\">"

42+ ++ urlFunction tag ++ "\">"

41− ++ tag ++ "</a>"

43+ ++ tag ++ "</a>"

42−

44+

43− sizeTag :: Float -> String

45+ sizeTag :: Float -> String

44− sizeTag count = show size' ++ "%"

46+ sizeTag count = show size' ++ "%"

47+ where

45− where size' :: Int

48+ size' :: Int

46− size' = floor (minSize + (relative count) * (maxSize - minSize))

49+ size' = floor (minSize + (relative count) * (maxSize - minSize))

47−

50+

48− minCount = minimum $ map snd $ tagCount

51+ minCount = minimum $ map snd $ tagCount

49− maxCount = maximum $ map snd $ tagCount

52+ maxCount = maximum $ map snd $ tagCount

50− relative count = (count - minCount) / (maxCount - minCount)

53+ relative count = (count - minCount) / (maxCount - minCount)

51−

54+

52− tagCount :: [(String, Float)]

55+ tagCount :: [(String, Float)]

53− tagCount = map (second $ fromIntegral . length) $ M.toList tagMap

56+ tagCount = map (second $ fromIntegral . length) $ M.toList tagMap

55-- Render all tags to links.

58-- Render all tags to links.

56renderTagLinks :: (String -> String) -- ^ Function that produces an url for a tag.

59renderTagLinks :: (String -> String) -- ^ Function that produces an url for a tag.

57 -> ContextManipulation

60 -> ContextManipulation

58renderTagLinks urlFunction = renderValue "tags" "tags" renderTagLinks'

61renderTagLinks urlFunction = renderValue "tags" "tags" renderTagLinks'

62+ where

59− where renderTagLinks' = intercalate ", "

63+ renderTagLinks' = intercalate ", "

60− . map (\t -> link t $ urlFunction t)

64+ . map (\t -> link t $ urlFunction t)

61− . map trim . splitRegex ","

65+ . map trim . splitRegex ","

src/Text/Hakyll/Util.hs+5−3

@@ -9,7 +9,8 @@ import Data.Char (isSpace)

9-- | Trim a string (drop spaces and tabs at both sides).

10trim :: String -> String

11trim = reverse . trim' . reverse . trim'

12+ where

12− where trim' = dropWhile isSpace

13+ trim' = dropWhile isSpace

14-- | Strip html tags.

15-- | Strip html tags.

15stripHTML :: String -> String

16stripHTML :: String -> String

@@ -18,8 +19,9 @@ stripHTML str = let (beforeTag, rest) = break (== '<') str

18 (_, afterTag) = break (== '>') rest

19 (_, afterTag) = break (== '>') rest

19 in beforeTag ++ (stripHTML $ tail' afterTag)

20 in beforeTag ++ (stripHTML $ tail' afterTag)

20 -- We need a failsafe tail function.

21 -- We need a failsafe tail function.

21− where tail' [] = []

22+ where

23+ tail' [] = []

22− tail' xs = tail xs

24+ tail' xs = tail xs

24-- | Make a HTML link.

26-- | Make a HTML link.

25--

27--