yogsototh/hakyll
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Hakyll now passes HLint.

Browse source
This commit is contained in:
Jasper Van der Jeugt 2010-01-19 14:08:19 +01:00
parent e9dd4c75a2
commit f5a6c4974d
11 changed files with 48 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
src/Network/Hakyll/SimpleServer.hs
View file

@ -49,10 +49,11 @@ readRequest :: Handle -> Server Request
readRequest handle = do
requestLine <- liftIO $ hGetLine handle
let [method, uri, version] = map trim $ splitRegex " " requestLine
return $ Request { requestMethod = method
, requestURI = uri
, requestVersion = version
}
request = Request { requestMethod = method
, requestURI = uri
, requestVersion = version
}
return request
-- | Simple representation of the HTTP response we send back.
data Response = Response { responseVersion :: String
@ -64,7 +65,7 @@ data Response = Response { responseVersion :: String
instance Show Response where
show response = responseVersion response ++ " "
++ (show $ responseStatusCode response) ++ " "
++ show (responseStatusCode response) ++ " "
++ responsePhrase response
-- | A default response.
@ -105,20 +106,19 @@ createGetResponse request = do
log' = writeChan (logChannel config)
isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
let fileName =
(documentRoot config) ++ if isDirectory then uri ++ "/index.html"
else uri
documentRoot config ++ if isDirectory then uri ++ "/index.html"
else uri
create200 = do
h <- openBinaryFile fileName ReadMode
contentLength <- hFileSize h
body <- hGetContents h
let headers =
[ ("Content-Length", show $ contentLength)
] ++ getMIMEHeader fileName
let mimeHeader = getMIMEHeader fileName
headers = ("Content-Length", show contentLength) : mimeHeader
return $ defaultResponse
{ responseStatusCode = 200
, responsePhrase = "OK"
, responseHeaders = (responseHeaders defaultResponse)
, responseHeaders = responseHeaders defaultResponse
`M.union` M.fromList headers
, responseBody = body
}
@ -131,8 +131,7 @@ createGetResponse request = do
-- Send back the page if found.
exists <- liftIO $ doesFileExist fileName
if exists
then do response <- liftIO $ catch create200 create500
return response
then liftIO $ catch create200 create500
else do liftIO $ log' $ "Not Found: " ++ fileName
return $ createErrorResponse 404 "Not Found"

6
src/Text/Hakyll.hs
View file

@ -4,6 +4,7 @@ module Text.Hakyll
) where
import Control.Monad.Reader (runReaderT)
import Control.Monad (when)
import qualified Data.Map as M
import System.Environment (getArgs, getProgName)
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
@ -43,8 +44,7 @@ clean = do remove' "_cache"
where
remove' dir = do putStrLn $ "Removing " ++ dir ++ "..."
exists <- doesDirectoryExist dir
if exists then removeDirectoryRecursive dir
else return ()
when exists $ removeDirectoryRecursive dir
-- | Show usage information.
help :: IO ()
@ -61,4 +61,4 @@ help = do
++ name ++ " server [port] Run a local test server.\n"
server :: Integer -> IO ()
server p = do simpleServer (fromIntegral $ p) "_site"
server p = simpleServer (fromIntegral p) "_site"

2
src/Text/Hakyll/CompressCSS.hs
View file

@ -27,7 +27,7 @@ stripComments :: String -> String
stripComments [] = []
stripComments str
| isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str
| otherwise = (head str) : (stripComments $ tail str)
| otherwise = head str : stripComments (tail str)
where
eatComments str' | null str' = []
| isPrefixOf "*/" str' = drop 2 str'

12
src/Text/Hakyll/File.hs
View file

@ -26,19 +26,19 @@ import Text.Hakyll.Hakyll (Hakyll)
removeLeadingSeparator :: FilePath -> FilePath
removeLeadingSeparator [] = []
removeLeadingSeparator path
| (head path') `elem` pathSeparators = (tail path')
| otherwise = 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
toDestination path = "_site" </> (removeLeadingSeparator path)
toDestination path = "_site" </> removeLeadingSeparator path
-- | Convert a relative filepath to a filepath in the cache (@_cache@).
toCache :: FilePath -> FilePath
toCache path = "_cache" </> (removeLeadingSeparator path)
toCache path = "_cache" </> removeLeadingSeparator path
-- | Get the url for a given page.
toURL :: FilePath -> FilePath
@ -106,9 +106,7 @@ havingExtension extension = filter ((==) extension . takeExtension)
-- | Perform a Hakyll action on every file in a given directory.
directory :: (FilePath -> Hakyll ()) -> FilePath -> Hakyll ()
directory action dir = do
contents <- getRecursiveContents dir
mapM_ action contents
directory action dir = getRecursiveContents dir >>= mapM_ action
-- | Check if a cache file is still valid.
isCacheValid :: FilePath -- ^ The cached file.

7
src/Text/Hakyll/Page.hs
View file

@ -11,6 +11,7 @@ import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Control.Parallel.Strategies (rdeepseq, ($|))
import Control.Monad.Reader (liftIO)
import Control.Monad (unless)
import System.FilePath (takeExtension)
import System.IO
@ -120,11 +121,11 @@ readSection renderFunction isFirst ls
| otherwise = body (tail ls)
where
isDelimiter' = isDelimiter (head ls)
isNamedDelimiter = (head ls) `matchesRegex` "----* *[a-zA-Z][a-zA-Z]*"
isNamedDelimiter = head ls `matchesRegex` "----* *[a-zA-Z][a-zA-Z]*"
body ls' = [("body", renderFunction $ unlines ls')]
readSimpleMetaData = map readPair
readPair = (trimPair . break (== ':'))
readPair = trimPair . break (== ':')
trimPair (key, value) = (trim key, trim $ tail value)
readSectionMetaData [] = []
@ -157,7 +158,7 @@ readPage pagePath = do
seq (($|) id rdeepseq context) $ liftIO $ hClose handle
-- Cache if needed
if getFromCache then return () else cachePage page
unless getFromCache $ cachePage page
return page
where
url = toURL pagePath

14
src/Text/Hakyll/Regex.hs
View file

@ -12,7 +12,7 @@ import Text.Regex.TDFA
-- | Match a regular expression against a string, returning more information
-- about the match.
matchRegexAll :: Regex -> String -> Maybe (String, String, String, [String])
matchRegexAll p str = matchM p str
matchRegexAll = matchM
-- | Replaces every occurance of the given regexp with the replacement string.
subRegex :: Regex -- ^ Search pattern
@ -30,10 +30,10 @@ subRegex regexp inp replacement =
Nothing -> repl
Just (lead, _, trail, bgroups) ->
let newval =
if (head bgroups) == "\\"
if head bgroups == "\\"
then "\\"
else let index :: Int
index = (read (head bgroups)) - 1
index = read (head bgroups) - 1
in if index == -1
then match'
else groups !! index
@ -41,7 +41,7 @@ subRegex regexp inp replacement =
in case matchRegexAll regexp inp of
Nothing -> inp
Just (lead, match', trail, groups) ->
lead ++ lookup' match' replacement groups ++ (subRegex regexp trail replacement)
lead ++ lookup' match' replacement groups ++ subRegex regexp trail replacement
-- | Splits a string based on a regular expression. The regular expression
-- should identify one delimiter.
@ -70,5 +70,7 @@ substituteRegex pattern replacement string =
subRegex (makeRegex pattern) string replacement
-- | Simple regex matching.
matchesRegex :: String -> String -> Bool
matchesRegex string pattern = string =~ pattern
matchesRegex :: String -- ^ Input string.
-> String -- ^ Pattern to match.
-> Bool
matchesRegex = (=~)

2
src/Text/Hakyll/Render.hs
View file

@ -99,7 +99,7 @@ renderChainWith :: Renderable a
renderChainWith manipulation templatePaths renderable =
depends (getURL renderable) dependencies render'
where
dependencies = (getDependencies renderable) ++ templatePaths
dependencies = getDependencies renderable ++ templatePaths
render' = do templates <- liftIO $ mapM readFile templatePaths
context <- toContext renderable
let result = pureRenderChainWith manipulation templates context

6
src/Text/Hakyll/Render/Internal.hs
View file

@ -30,10 +30,10 @@ substitute _ [] _ = []
substitute escaper string context
| "$$" `isPrefixOf` string = escaper ++ substitute' (tail tail')
| "$" `isPrefixOf` string = substituteKey
| otherwise = (head string) : (substitute' tail')
| otherwise = head string : substitute' tail'
where
tail' = tail string
(key, rest) = break (not . isAlpha) tail'
(key, rest) = span isAlpha tail'
replacement = fromMaybe ('$' : key) $ M.lookup key context
substituteKey = replacement ++ substitute' rest
substitute' str = substitute escaper str context
@ -86,7 +86,7 @@ writePage :: Page -> Hakyll ()
writePage page = do
additionalContext' <- askHakyll additionalContext
let destination = toDestination url
context = additionalContext' `M.union` (M.singleton "root" $ toRoot url)
context = additionalContext' `M.union` M.singleton "root" (toRoot url)
makeDirectories destination
    -- Substitute $root here, just before writing.
liftIO $ writeFile destination $ finalSubstitute (getBody page) context

6
src/Text/Hakyll/Renderables.hs
View file

@ -40,8 +40,8 @@ instance Renderable CustomPage where
getURL = customPageURL
toContext page = do
values <- mapM (either return id . snd) (customPageContext page)
return $ M.fromList $ [ ("url", customPageURL page)
] ++ zip (map fst $ customPageContext page) values
let pairs = zip (map fst $ customPageContext page) values
return $ M.fromList $ ("url", customPageURL page) : pairs
-- | PagePath is a class that wraps a FilePath. This is used to render Pages
-- without reading them first through use of caching.
@ -96,4 +96,4 @@ instance (Renderable a, Renderable b)
return $ c1 `M.union` c2
toContext (CombinedRenderableWithURL url a b) = do
c <- toContext (CombinedRenderable a b)
return $ (M.singleton "url" url) `M.union` c
return $ M.singleton "url" url `M.union` c

14
src/Text/Hakyll/Tags.hs
View file

@ -26,8 +26,8 @@ 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
let tags = map trim $ splitRegex "," $ getValue "tags" page
return $ foldr (flip (M.insertWith (++)) [path]) current tags
-- | Render a tag cloud.
renderTagCloud :: M.Map String [FilePath] -- ^ Map as produced by "readTagMap".
@ -50,10 +50,10 @@ renderTagCloud tagMap urlFunction minSize maxSize =
sizeTag count = show size' ++ "%"
where
size' :: Int
size' = floor (minSize + (relative count) * (maxSize - minSize))
size' = floor $ minSize + relative count * (maxSize - minSize)
minCount = minimum $ map snd $ tagCount
maxCount = maximum $ map snd $ tagCount
minCount = minimum $ map snd tagCount
maxCount = maximum $ map snd tagCount
relative count = (count - minCount) / (maxCount - minCount)
tagCount :: [(String, Float)]
@ -65,5 +65,5 @@ renderTagLinks :: (String -> String) -- ^ Function that produces an url for a ta
renderTagLinks urlFunction = renderValue "tags" "tags" renderTagLinks'
where
renderTagLinks' = intercalate ", "
. map (\t -> link t $ urlFunction t)
. map trim . splitRegex ","
. map ((\t -> link t $ urlFunction t) . trim)
. splitRegex ","

2
src/Text/Hakyll/Util.hs
View file

@ -17,7 +17,7 @@ stripHTML :: String -> String
stripHTML [] = []
stripHTML str = let (beforeTag, rest) = break (== '<') str
(_, afterTag) = break (== '>') rest
in beforeTag ++ (stripHTML $ tail' afterTag)
in beforeTag ++ stripHTML (tail' afterTag)
-- We need a failsafe tail function.
where
tail' [] = []