From dae0258a62a714fb7fd9b47473bf259eb858f9f1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 11 Jan 2010 13:56:32 +0100 Subject: Readability++. --- src/Text/Hakyll.hs | 9 ++++---- src/Text/Hakyll/CompressCSS.hs | 12 ++++++---- src/Text/Hakyll/Context.hs | 17 +++++++------- src/Text/Hakyll/File.hs | 23 +++++++++++-------- src/Text/Hakyll/Page.hs | 51 +++++++++++++++++++++++------------------ src/Text/Hakyll/Render.hs | 49 +++++++++++++++++++++------------------ src/Text/Hakyll/Tags.hs | 52 +++++++++++++++++++++++------------------- src/Text/Hakyll/Util.hs | 8 ++++--- 8 files changed, 124 insertions(+), 97 deletions(-) (limited to 'src/Text') diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs index d34c1c8..7c74b2e 100644 --- a/src/Text/Hakyll.hs +++ b/src/Text/Hakyll.hs @@ -28,10 +28,11 @@ build buildFunction = do putStrLn "Generating..." 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 () diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs index 4b35558..f9a062c 100644 --- a/src/Text/Hakyll/CompressCSS.hs +++ b/src/Text/Hakyll/CompressCSS.hs @@ -24,8 +24,10 @@ 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 index 074c88f..d2c6047 100644 --- a/src/Text/Hakyll/Context.hs +++ b/src/Text/Hakyll/Context.hs @@ -38,11 +38,12 @@ renderDate :: String -- ^ Key in which the rendered date should be placed. -> String -- ^ Default value when the date cannot be parsed. -> ContextManipulation 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 + 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 index d8ee8db..0ed91d5 100644 --- a/src/Text/Hakyll/File.hs +++ b/src/Text/Hakyll/File.hs @@ -25,8 +25,9 @@ removeLeadingSeparator [] = [] removeLeadingSeparator path | (head path') `elem` pathSeparators = (tail path') | otherwise = path' - where path' = if "$root" `isPrefixOf` path then drop 5 path - else 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 @@ -46,21 +47,24 @@ toURL path = if takeExtension path `elem` [".markdown", ".md", ".tex"] toRoot :: FilePath -> FilePath toRoot = emptyException . joinPath . map parent . splitPath . takeDirectory . removeLeadingSeparator - where parent = const ".." - emptyException [] = "." - emptyException x = x + 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. @@ -75,7 +79,8 @@ getRecursiveContents topdir = do 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 index c5ddc3a..682f1b9 100644 --- a/src/Text/Hakyll/Page.hs +++ b/src/Text/Hakyll/Page.hs @@ -42,7 +42,8 @@ getPageURL (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page -- | Get the original page path. getPagePath :: Page -> String -getPagePath (Page page) = fromMaybe (error "No page path") $ M.lookup "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. @@ -56,21 +57,24 @@ writerOptions = defaultWriterOptions -- | 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,10 +91,11 @@ cachePage page@(Page mapping) = do hPutStrLn handle "---" hPutStr handle $ getBody page hClose handle - where writePair h (k, v) = hPutStr h k >> - hPutStr h ": " >> - hPutStr h v >> - hPutStrLn h "" + where + writePair h (k, v) = do hPutStr h k + hPutStr h ": " + hPutStr h 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 @@ -104,11 +109,12 @@ readPage pagePath = do -- 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) + (context, body) <- + if isDelimiter line + then do md <- readMetaData handle + c <- hGetContents handle + return (md, c) + else hGetContents handle >>= \b -> return ([], line ++ b) -- Render file let rendered = (renderFunction $ takeExtension path) body @@ -123,8 +129,9 @@ readPage pagePath = do -- Cache if needed if getFromCache then return () else cachePage page return page - where url = toURL pagePath - cacheFile = toCache url + where + url = toURL pagePath + cacheFile = toCache url -- Make pages renderable. instance Renderable Page where diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs index 41f76b8..caf0221 100644 --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -43,11 +43,12 @@ 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 + 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 @@ -97,11 +98,12 @@ renderAndConcatWith :: Renderable a -> IO String renderAndConcatWith manipulation templatePath renderables = foldM concatRender' [] renderables - where concatRender' :: Renderable a => String -> a -> IO String - concatRender' chunk renderable = do - rendered <- renderWith manipulation templatePath renderable - let body = getBody rendered - return $ chunk ++ body + where + concatRender' :: Renderable a => String -> a -> IO String + concatRender' chunk renderable = do + rendered <- renderWith manipulation templatePath renderable + let body = getBody rendered + return $ chunk ++ body -- | 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 @@ -125,23 +127,26 @@ 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) + where + url = getURL page +    -- Substitute $root here, just before writing. +    body = finalSubstitute (getBody page) +                           (M.singleton "root" $ toRoot url) -- | 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/Tags.hs b/src/Text/Hakyll/Tags.hs index 801b9b1..625584e 100644 --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -21,10 +21,11 @@ import Control.Arrow (second) -- 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 $ splitRegex "," $ 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'. @@ -34,28 +35,31 @@ renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTag -> String -- ^ Result of the render. renderTagCloud tagMap urlFunction minSize maxSize = intercalate " " $ map renderTag tagCount - 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) - - tagCount :: [(String, Float)] - tagCount = map (second $ fromIntegral . length) $ M.toList tagMap + 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) + + 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' = intercalate ", " - . map (\t -> link t $ urlFunction t) - . map trim . splitRegex "," + 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 index 018c404..858b3fb 100644 --- a/src/Text/Hakyll/Util.hs +++ b/src/Text/Hakyll/Util.hs @@ -9,7 +9,8 @@ import Data.Char (isSpace) -- | 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 @@ stripHTML str = let (beforeTag, rest) = break (== '<') str (_, 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. -- -- cgit v1.2.3