diff --git a/hakyll.cabal b/hakyll.cabal index d458000..c168cd4 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -34,7 +34,8 @@ library mtl >= 1.1, old-locale >= 1, time >= 1, - binary >= 0.5 + binary >= 0.5, + QuickCheck >= 2 exposed-modules: Network.Hakyll.SimpleServer Text.Hakyll Text.Hakyll.Context @@ -47,7 +48,7 @@ library Text.Hakyll.Page Text.Hakyll.Util Text.Hakyll.Tags - other-modules: Text.Hakyll.Internal.Cache - Text.Hakyll.Internal.CompressCSS - Text.Hakyll.Internal.Render - Text.Hakyll.Internal.Template + Text.Hakyll.Internal.Cache + Text.Hakyll.Internal.CompressCSS + Text.Hakyll.Internal.Render + Text.Hakyll.Internal.Template diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs index 41d279c..155189b 100644 --- a/src/Text/Hakyll/Internal/Template.hs +++ b/src/Text/Hakyll/Internal/Template.hs @@ -11,21 +11,25 @@ import qualified Data.Map as M import Data.List (isPrefixOf) import Data.Char (isAlphaNum) import Data.Binary -import Control.Monad (liftM, liftM2) +import Control.Monad (liftM, liftM2, replicateM) import Data.Maybe (fromMaybe) import System.FilePath (()) import Control.Monad.Reader (liftIO) +import Test.QuickCheck + import Text.Hakyll.Hakyll (Hakyll) import Text.Hakyll.Context (Context) import Text.Hakyll.Internal.Cache +-- | Datatype used for template substitutions. data Template = Chunk String Template | Identifier String Template | EscapeCharacter Template | End - deriving (Show, Read) + deriving (Show, Read, Eq) +-- | Construct a "Template" from a string. fromString :: String -> Template fromString [] = End fromString string @@ -37,6 +41,8 @@ fromString string where tail' = tail string +-- | Read a "Template" from a file. This function might fetch the "Template" +-- from the cache, if available. readTemplate :: FilePath -> Hakyll Template readTemplate path = do isCacheMoreRecent' <- isCacheMoreRecent fileName [path] @@ -84,3 +90,32 @@ instance Binary Template where 2 -> liftM EscapeCharacter get 3 -> return End _ -> error "Error reading template" + +-- | Generate arbitrary templates from a given length. +arbitraryTemplate :: Int -> Gen Template +arbitraryTemplate 0 = return End +arbitraryTemplate length' = oneof [ do chunk <- chunk' + template' >>= return . Chunk chunk + , do key <- key' + template' >>= return . Identifier key + , template' >>= return . EscapeCharacter + ] + where + template' = arbitraryTemplate (length' - 1) + -- Generate keys. + key' = do l <- choose (5, 10) + replicateM l $ choose ('a', 'z') + -- Generate non-empty chunks. + chunk' = do string <- arbitrary + let sanitized = filter (/= '$') string + return $ if null sanitized then "foo" + else sanitized + +-- | Make "Template" testable. +instance Arbitrary Template where + arbitrary = choose (0, 20) >>= arbitraryTemplate + + shrink (Chunk chunk template) = [template, Chunk chunk End] + shrink (Identifier key template) = [template, Identifier key End] + shrink (EscapeCharacter template) = [template, EscapeCharacter End] + shrink End = [] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..3654340 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,23 @@ +module Main where + +import Control.Monad (mapM_) +import Test.QuickCheck + +import Template +import Util + +main = do + runTests "Template" $ do + quickCheck prop_template_encode_id + quickCheck prop_substitute_id + quickCheck prop_substitute_case1 + + runTests "Util" $ do + quickCheck prop_trim_length + quickCheck prop_trim_id + quickCheck prop_stripHTML_length + quickCheck prop_stripHTML_id + + where + runTests name action = do putStrLn name + action diff --git a/tests/Template.hs b/tests/Template.hs new file mode 100644 index 0000000..9d1d39d --- /dev/null +++ b/tests/Template.hs @@ -0,0 +1,25 @@ +module Template where + +import qualified Data.Map as M + +import Test.QuickCheck +import Data.Binary + +import Text.Hakyll.Internal.Template + +-- Test encoding/decoding of templates. +prop_template_encode_id :: Template -> Bool +prop_template_encode_id template = decode (encode template) == template + +-- Check we get the same sting with empty substitutions. +prop_substitute_id string = + regularSubstitute (fromString string) M.empty == string + +-- substitute test case 1. +prop_substitute_case1 string1 string2 = + finalSubstitute template context == string1 ++ " costs $" ++ string2 ++ "." + where + template = fromString "$product costs $$$price." + context = M.fromList [ ("product", string1) + , ("price", string2) + ] diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 index f8a915e..0000000 --- a/tests/Tests.hs +++ /dev/null @@ -1,140 +0,0 @@ -import Data.Char -import qualified Data.Map as M - -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 -import Test.Framework.Providers.HUnit -import Test.QuickCheck -import Test.HUnit - -import Text.Hakyll.CompressCSS -import Text.Hakyll.Util -import Text.Hakyll.Regex -import Text.Hakyll.Context -import Text.Hakyll.File - -main = defaultMain tests - -tests = [ testGroup "Util group" - [ testProperty "trim length" prop_trim_length - -- , testProperty "trim id" prop_trim_id - -- , testProperty "trim empty" prop_trim_empty - , testCase "stripHTML 1" test_strip_html1 - , testCase "stripHTML 2" test_strip_html2 - , testCase "stripHTML 3" test_strip_html3 - , testCase "link 1" test_link1 - , testCase "link 2" test_link2 - ] - - , 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 - , testCase "compressCSS 1" test_compress_css1 - , testCase "compressCSS 2" test_compress_css2 - , testCase "compressCSS 3" test_compress_css3 - , testCase "compressCSS 4" test_compress_css4 - ] - - , testGroup "Context group" - [ testCase "renderDate 1" test_render_date1 - , testCase "renderDate 2" test_render_date1 - , testCase "changeExtension 1" test_change_extension1 - ] - - , testGroup "File group" - [ testCase "toRoot 1" test_to_root1 - , testCase "toRoot 2" test_to_root2 - , testCase "toRoot 3" test_to_root3 - , testCase "removeSpaces 1" test_remove_spaces1 - , testCase "removeSpaces 2" test_remove_spaces2 - -- , testProperty "havingExtension count" prop_having_extension_count - , testCase "havingExtension 1" test_having_extension1 - , testCase "havingExtension 2" test_having_extension2 - ] - ] - --- Test that a string always becomes shorter when trimmed. -prop_trim_length str = length str >= length (trim str) - --- Check that a string which does not start or end with a space is not trimmed. -prop_trim_id str = isAlreadyTrimmed ==> str == (trim str) - where - isAlreadyTrimmed :: Bool - isAlreadyTrimmed = (not $ isSpace $ head str) && (not $ isSpace $ last str) - --- An string of only spaces should be reduced to an empty string. -prop_trim_empty str = (all isSpace str) ==> null (trim str) - --- Strip HTML test cases. -test_strip_html1 = stripHTML "text" @?= "text" -test_strip_html2 = stripHTML "text" @?= "text" -test_strip_html3 = - stripHTML "Hakyll, a website generator" - @?= "Hakyll, a website generator" - --- Link test cases. -test_link1 = link "foo bar" "/foo/bar.html" - @?= "foo bar" -test_link2 = link "back home" "/" @?= "back home" - --- Split Regex test cases. -test_split_regex1 = splitRegex "," "1,2,3" @?= ["1", "2", "3"] -test_split_regex2 = splitRegex "," ",1,2," @?= ["1", "2"] - --- CSS compression should always decrease the text length. -prop_compress_css_length str = length str >= length (compressCSS str) - --- Compress CSS test cases. -test_compress_css1 = compressCSS "a { \n color : red; }" @?= "a{color:red}" -test_compress_css2 = compressCSS "img {border :none;;;; }" - @?= "img{border:none}" -test_compress_css3 = - compressCSS "p {font-size : 90%;} h1 {color :white;;; }" - @?= "p{font-size:90%}h1{color:white}" -test_compress_css4 = compressCSS "a { /* /* red is pretty cool */ color: red; }" - @?= "a{color:red}" - --- Date rendering test cases. -test_render_date1 = - M.lookup "date" rendered @?= Just "December 30, 2009" - where - rendered = renderDate "date" "%B %e, %Y" "Unknown date" - (M.singleton "path" "2009-12-30-a-title.markdown") - -test_render_date2 = M.lookup "date" rendered @?= Just "Unknown date" - where - rendered = renderDate "date" "%B %e, %Y" "Unknown date" $ - M.singleton "path" "2009-badness-30-a-title.markdown" - --- changeExtension test cases. -test_change_extension1 = M.lookup "url" rendered @?= Just "foo.php" - where - rendered = changeExtension "php" (M.singleton "url" "foo.html") - --- toRoot test cases -test_to_root1 = toRoot "/posts/foo.html" @?= ".." -test_to_root2 = toRoot "posts/foo.html" @?= ".." -test_to_root3 = toRoot "foo.html" @?= "." - --- removeSpaces test cases -test_remove_spaces1 = removeSpaces "$root/tags/random crap.html" - @?= "$root/tags/random-crap.html" -test_remove_spaces2 = removeSpaces "another simple example.zip" - @?= "another-simple-example.zip" - --- Add an extension, and test that they have that extension -prop_having_extension_count names extension = - not (any ('.' `elem`) names || any (`elem` extension) "./\\") - ==> havingExtension fullExtension withExtensions == withExtensions - where - fullExtension = '.' : extension - withExtensions = map (++ fullExtension) names - --- Having extension test cases -test_having_extension1 = havingExtension ".foo" ["file.bar", "file.txt"] @?= [] -test_having_extension2 = havingExtension ".foo" ["file.foo", "file.txt"] - @?= ["file.foo"] diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 index 0000000..9e2a0dd --- /dev/null +++ b/tests/Util.hs @@ -0,0 +1,23 @@ +module Util where + +import Data.Char + +import Test.QuickCheck + +import Text.Hakyll.Util + +-- Test that a string always becomes shorter when trimmed. +prop_trim_length str = length str >= length (trim str) + +-- Check that a string which does not start or end with a space is not trimmed. +prop_trim_id str = (not $ null str) && isAlreadyTrimmed ==> str == (trim str) + where + isAlreadyTrimmed :: Bool + isAlreadyTrimmed = (not $ isSpace $ head str) && (not $ isSpace $ last str) + +-- Check that a stripped string is shorter. +prop_stripHTML_length str = length str >= length (stripHTML str) + +-- Check that strings without tags remain untouched. +prop_stripHTML_id str = (not $ any (`elem` ['>', '<']) str) + ==> str == stripHTML str