diff options
| -rw-r--r-- | hakyll.cabal | 1 | ||||
| -rw-r--r-- | src/Network/Hakyll/SimpleServer.hs | 2 | ||||
| -rw-r--r-- | src/Text/Hakyll/CompressCSS.hs | 10 | ||||
| -rw-r--r-- | src/Text/Hakyll/Context.hs | 26 | ||||
| -rw-r--r-- | src/Text/Hakyll/Page.hs | 39 | ||||
| -rw-r--r-- | src/Text/Hakyll/Regex.hs | 34 | ||||
| -rw-r--r-- | src/Text/Hakyll/Render.hs | 44 | ||||
| -rw-r--r-- | src/Text/Hakyll/Renderable.hs | 2 | ||||
| -rw-r--r-- | src/Text/Hakyll/Renderables.hs | 12 | ||||
| -rw-r--r-- | src/Text/Hakyll/Tags.hs | 7 | ||||
| -rw-r--r-- | tests/Tests.hs | 10 |
11 files changed, 97 insertions, 90 deletions
diff --git a/hakyll.cabal b/hakyll.cabal index 45f9414..f1d0ad7 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -24,7 +24,6 @@ library ghc-options: -Wall hs-source-dirs: src/ build-depends: base >= 4 && < 5, - template >= 0.1.1, filepath >= 1.1, directory >= 1, containers >= 0.1, diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs index 7b058f3..017a764 100644 --- a/src/Network/Hakyll/SimpleServer.hs +++ b/src/Network/Hakyll/SimpleServer.hs @@ -48,7 +48,7 @@ instance Show Request where readRequest :: Handle -> Server Request readRequest handle = do requestLine <- liftIO $ hGetLine handle - let [method, uri, version] = map trim $ split " " requestLine + let [method, uri, version] = map trim $ splitRegex " " requestLine return $ Request { requestMethod = B.pack method , requestURI = B.pack uri , requestVersion = B.pack version diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs index 85c061d..4b35558 100644 --- a/src/Text/Hakyll/CompressCSS.hs +++ b/src/Text/Hakyll/CompressCSS.hs @@ -3,7 +3,7 @@ module Text.Hakyll.CompressCSS ) 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,13 +13,13 @@ compressCSS = compressSeparators -- | 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 diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs index 22409bf..074c88f 100644 --- a/src/Text/Hakyll/Context.hs +++ b/src/Text/Hakyll/Context.hs @@ -1,20 +1,23 @@ -- | 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 @@ -22,11 +25,11 @@ 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,12 +37,11 @@ renderDate :: String -- ^ Key in which the rendered date should be placed. -> 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 +renderDate key format defaultValue context = M.insert key 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) + 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 diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs index 83ca654..f70d898 100644 --- a/src/Text/Hakyll/Page.hs +++ b/src/Text/Hakyll/Page.hs @@ -8,7 +8,6 @@ module Text.Hakyll.Page 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 System.FilePath (FilePath, takeExtension) @@ -16,10 +15,10 @@ 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. @@ -31,26 +30,22 @@ fromContext = Page -- | 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 @@ -86,13 +81,13 @@ cachePage page@(Page mapping) = do 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 >> + where writePair h (k, v) = hPutStr h k >> + hPutStr h ": " >> + hPutStr h v >> hPutStrLn h "" -- | Read a page from a file. Metadata is supported, and if the filename @@ -114,13 +109,13 @@ readPage pagePath = do else hGetContents handle >>= \b -> return ([], line ++ b) -- Render file - let rendered = B.pack $ (renderFunction $ takeExtension path) body + let rendered = (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 + [ ("body", rendered) + , ("url", url) + , ("path", pagePath) + ] ++ context -- Cache if needed if getFromCache then return () else cachePage page diff --git a/src/Text/Hakyll/Regex.hs b/src/Text/Hakyll/Regex.hs index e2e21bc..37bbc7e 100644 --- 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 :: Regex -> String -> Maybe (String, String, String, [String]) 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 @@ subRegex regexp inp replacement = -- | 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 @@ splitRegex delim strIn = loop strIn where 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 index d3e4a34..1719e83 100644 --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -10,15 +10,16 @@ module Text.Hakyll.Render , css ) where -import Text.Template hiding (render) -import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M +import Data.List (isPrefixOf) import Control.Monad (unless, liftM, foldM) +import Data.Char (isAlpha) +import Data.Maybe (fromMaybe) import System.Directory (copyFile) import System.IO -import Text.Hakyll.Context (ContextManipulation) +import Text.Hakyll.Context (Context, ContextManipulation) import Text.Hakyll.Page import Text.Hakyll.Renderable import Text.Hakyll.File @@ -33,6 +34,19 @@ depends file dependencies action = do valid <- isCacheValid (toDestination file) dependencies unless valid action +-- | Substitutes `$identifiers` in the given string by values from the given +-- "Context". When a key is not found, it is left as it is. +substitute :: String -> Context -> String +substitute [] _ = [] +substitute string context + | "$$" `isPrefixOf` string = "$$" ++ (substitute (tail tail') context) + | "$" `isPrefixOf` string = substitute' + | otherwise = (head string) : (substitute tail' context) + where tail' = tail string + (key, rest) = break (not . isAlpha) tail' + replacement = fromMaybe ('$' : key) $ M.lookup key context + substitute' = replacement ++ substitute rest context + -- | Render to a Page. render :: Renderable a => FilePath -- ^ Template to use for rendering. @@ -49,18 +63,18 @@ renderWith :: Renderable a -> 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 + templateString <- hGetContents handle seq templateString $ hClose handle context <- liftM manipulation $ toContext renderable -- Ignore $root when substituting here. We will only replace that in the -- final render (just before writing). - let contextIgnoringRoot = M.insert (B.pack "root") (B.pack "$root") context + let contextIgnoringRoot = M.insert "root" "$root" context body = substitute templateString contextIgnoringRoot - return $ fromContext (M.insert (B.pack "body") body context) + return $ fromContext (M.insert "body" body 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 @@ -70,14 +84,14 @@ renderAndConcatWith :: Renderable a => ContextManipulation -> FilePath -> [a] - -> IO B.ByteString + -> IO String renderAndConcatWith manipulation templatePath renderables = - foldM concatRender' B.empty renderables - where concatRender' :: Renderable a => B.ByteString -> a -> IO B.ByteString + 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 $ B.append chunk $ body + 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 @@ -100,11 +114,11 @@ writePage :: Page -> IO () writePage page = do let destination = toDestination url makeDirectories destination - B.writeFile destination body + writeFile destination body where url = getURL page - -- Substitute $root here, just before writing. - body = substitute (getBody page) - (M.singleton (B.pack "root") (B.pack $ toRoot url)) + -- Substitute $root here, just before writing. + body = substitute (getBody page) + (M.singleton "root" $ toRoot url) -- | Mark a certain file as static, so it will just be copied when the site is -- generated. diff --git a/src/Text/Hakyll/Renderable.hs b/src/Text/Hakyll/Renderable.hs index 4ca6f46..c8e780e 100644 --- a/src/Text/Hakyll/Renderable.hs +++ b/src/Text/Hakyll/Renderable.hs @@ -3,7 +3,7 @@ module Text.Hakyll.Renderable ) 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 index bd474e2..26d1e86 100644 --- a/src/Text/Hakyll/Renderables.hs +++ b/src/Text/Hakyll/Renderables.hs @@ -6,7 +6,6 @@ module Text.Hakyll.Renderables ) 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 @@ import Text.Hakyll.File 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,10 +29,9 @@ instance Renderable CustomPage where 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 index 69386be..801b9b1 100644 --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -7,7 +7,6 @@ module Text.Hakyll.Tags ) where import qualified Data.Map as M -import qualified Data.ByteString.Lazy.Char8 as B import Data.List (intercalate) import Control.Monad (foldM) @@ -24,7 +23,7 @@ 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 + let tags = map trim $ splitRegex "," $ getValue ("tags") page return $ foldr (\t -> M.insertWith (++) t [path]) current tags -- | Render a tag cloud. @@ -57,6 +56,6 @@ renderTagCloud tagMap urlFunction minSize maxSize = renderTagLinks :: (String -> String) -- ^ Function that produces an url for a tag. -> ContextManipulation renderTagLinks urlFunction = renderValue "tags" "tags" renderTagLinks' - where renderTagLinks' = B.pack . intercalate ", " + where renderTagLinks' = intercalate ", " . map (\t -> link t $ urlFunction t) - . map trim . split "," . B.unpack + . map trim . splitRegex "," diff --git a/tests/Tests.hs b/tests/Tests.hs index 38b072a..4ee84f7 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -26,8 +26,8 @@ tests = [ testGroup "Util group" [ testProperty "trim length" prop_trim_length , testCase "link 2" test_link2 ] - , testGroup "Regex group" [ testCase "split 1" test_split1 - , testCase "split 2" test_split2 + , testGroup "Regex group" [ testCase "splitRegex 1" test_split_regex1 + , testCase "splitRegex 2" test_split_regex2 ] , testGroup "CompressCSS group" [ testProperty "compressCSS length" prop_compress_css_length @@ -71,9 +71,9 @@ test_strip_html3 = stripHTML "<b>Hakyll</b> is an <i>awesome</i> web framework < test_link1 = link "foo bar" "/foo/bar.html" @?= "<a href=\"/foo/bar.html\">foo bar</a>" test_link2 = link "back home" "/" @?= "<a href=\"/\">back home</a>" --- Split test cases. -test_split1 = split "," "1,2,3" @?= ["1", "2", "3"] -test_split2 = split "," ",1,2," @?= ["1", "2"] +-- Split Regex test cases. +test_split_regex1 = split "," "1,2,3" @?= ["1", "2", "3"] +test_split_regex2 = split "," ",1,2," @?= ["1", "2"] -- CSS compression should always decrease the text length. prop_compress_css_length str = length str >= length (compressCSS str) |