From 87da7dc6816aa83b4e4066a13019ce67a0326c72 Mon Sep 17 00:00:00 2001 From: stwill Date: Thu, 21 Oct 2010 14:44:10 -0400 Subject: [PATCH] Test.hs: quick clean-up to code style guide --- test/suite/Text/Templating/Heist/Tests.hs | 338 ++++++++++++---------- 1 file changed, 185 insertions(+), 153 deletions(-) diff --git a/test/suite/Text/Templating/Heist/Tests.hs b/test/suite/Text/Templating/Heist/Tests.hs index 21f1599..8ec4070 100644 --- a/test/suite/Text/Templating/Heist/Tests.hs +++ b/test/suite/Text/Templating/Heist/Tests.hs @@ -31,6 +31,7 @@ import Text.XML.Expat.Cursor import Text.XML.Expat.Format import qualified Text.XML.Expat.Tree as X + tests :: [Test] tests = [ testProperty "simpleBindTest" $ monadicIO $ forAllM arbitrary prop_simpleBindTest , testProperty "simpleApplyTest" $ monadicIO $ forAllM arbitrary prop_simpleApplyTest @@ -41,71 +42,80 @@ tests = [ testProperty "simpleBindTest" $ monadicIO $ forAllM arbitrary prop_sim , testCase "fsLoadTest" fsLoadTest , testCase "renderNoNameTest" renderNoNameTest , testCase "doctypeTest" doctypeTest - , testCase "attributeSubstitution" attrSubstTest - , testCase "bindAttribute" bindAttrTest + , testCase "attributeSubstitutionTest" attrSubstTest + , testCase "bindAttributeTest" bindAttrTest , testCase "applyTest" applyTest ] -applyTest :: H.Assertion -applyTest = do - let es = emptyTemplateState :: TemplateState IO - res <- evalTemplateMonad applyImpl - (X.Element "apply" [("template", "nonexistant")] []) es - H.assertEqual "apply nothing" res [] - + +prop_simpleBindTest :: Bind -> PropertyM IO () +prop_simpleBindTest bind = do + let template = buildBindTemplate bind + result = buildResult bind + spliceResult <- run $ evalTemplateMonad (runNodeList template) + (X.Text "") + emptyTemplateState + assert $ result == spliceResult + + +prop_simpleApplyTest :: Apply -> PropertyM IO () +prop_simpleApplyTest apply = do + let correct = calcCorrect apply + result <- run $ calcResult apply + assert $ correct == result + + monoidTest :: IO () monoidTest = do - H.assertBool "left monoid identity" $ mempty `mappend` es == es - H.assertBool "right monoid identity" $ es `mappend` mempty == es + H.assertBool "left monoid identity" $ mempty `mappend` es == es + H.assertBool "right monoid identity" $ es `mappend` mempty == es where es = emptyTemplateState :: TemplateState IO + addTest :: IO () addTest = do - H.assertBool "lookup test" $ Just [] == (fmap (_itNodes . fst) $ lookupTemplate "aoeu" ts) - H.assertBool "splice touched" $ Map.size (_spliceMap ts) == 0 + H.assertBool "lookup test" $ Just [] == (fmap (_itNodes . fst) $ lookupTemplate "aoeu" ts) + H.assertBool "splice touched" $ Map.size (_spliceMap ts) == 0 where ts = addTemplate "aoeu" [] (mempty::TemplateState IO) -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft (Right _) = False +getDocTest :: H.Assertion +getDocTest = do + d <- getDoc "bkteoar" + H.assertBool "non-existent doc" $ isLeft d + f <- getDoc "templates/index.tpl" + H.assertBool "index doc" $ not $ isLeft f -loadT :: String -> IO (Either String (TemplateState IO)) -loadT s = loadTemplates s emptyTemplateState loadTest :: H.Assertion loadTest = do - ets <- loadT "templates" - either (error "Error loading templates") - (\ts -> do let tm = _templateMap ts - H.assertBool "loadTest size" $ Map.size tm == 16 - ) ets - -renderNoNameTest :: H.Assertion -renderNoNameTest = do - ets <- loadT "templates" - either (error "Error loading templates") - (\ts -> do t <- renderTemplate ts "" - H.assertBool "renderNoName" $ t == Nothing - ) ets + ets <- loadT "templates" + either (error "Error loading templates") + (\ts -> do let tm = _templateMap ts + H.assertBool "loadTest size" $ Map.size tm == 16 + ) ets -getDocTest :: H.Assertion -getDocTest = do - d <- getDoc "bkteoar" - H.assertBool "non-existent doc" $ isLeft d - f <- getDoc "templates/index.tpl" - H.assertBool "index doc" $ not $ isLeft f fsLoadTest :: H.Assertion fsLoadTest = do - ets <- loadT "templates" - let tm = either (error "Error loading templates") _templateMap ets - let ts = setTemplates tm emptyTemplateState :: TemplateState IO - f p n = H.assertBool ("loading template "++n) $ p $ lookupTemplate (B.pack n) ts - f isNothing "abc/def/xyz" - f isJust "a" - f isJust "bar/a" - f isJust "/bar/a" + ets <- loadT "templates" + let tm = either (error "Error loading templates") _templateMap ets + let ts = setTemplates tm emptyTemplateState :: TemplateState IO + f p n = H.assertBool ("loading template " ++ n) $ p $ lookupTemplate (B.pack n) ts + f isNothing "abc/def/xyz" + f isJust "a" + f isJust "bar/a" + f isJust "/bar/a" + + +renderNoNameTest :: H.Assertion +renderNoNameTest = do + ets <- loadT "templates" + either (error "Error loading templates") + (\ts -> do t <- renderTemplate ts "" + H.assertBool "renderNoName" $ t == Nothing + ) ets + doctypeTest :: H.Assertion doctypeTest = do @@ -116,6 +126,7 @@ doctypeTest = do ioc <- renderTemplate ts "ioc" H.assertBool "doctype test ioc" $ hasDoctype $ fromJust ioc + attrSubstTest :: H.Assertion attrSubstTest = do ets <- loadT "templates" @@ -126,7 +137,7 @@ attrSubstTest = do setTs val = bindSplice "foo" (return [X.Text val]) check ts str = do res <- renderTemplate ts "attrs" - H.assertBool ("attr subst "++(show str)) $ + H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $ snd $ B.breakSubstring str $ fromJust res H.assertBool ("attr subst foo") $ not $ B.null $ snd $ B.breakSubstring "$(foo)" $ fromJust res @@ -146,6 +157,14 @@ bindAttrTest = do B.null $ snd $ B.breakSubstring "$(bar)" $ fromJust res +applyTest :: H.Assertion +applyTest = do + let es = emptyTemplateState :: TemplateState IO + res <- evalTemplateMonad applyImpl + (X.Element "apply" [("template", "nonexistant")] []) es + H.assertEqual "apply nothing" res [] + + -- dotdotTest :: H.Assertion -- dotdotTest = do -- ets <- loadT "templates" @@ -153,68 +172,65 @@ bindAttrTest = do -- let ts = setTemplates tm emptyTemplateState :: TemplateState IO -- f p n = H.assertBool ("loading template "++n) $ p $ lookupTemplate (B.pack n) ts + +{- +-- Utility functions +-} +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft (Right _) = False + + +loadT :: String -> IO (Either String (TemplateState IO)) +loadT s = loadTemplates s emptyTemplateState + + +loadTS :: FilePath -> IO (TemplateState IO) +loadTS baseDir = do + etm <- loadTemplates baseDir emptyTemplateState + return $ either error id etm + + identStartChar :: [Char] identStartChar = ['a'..'z'] -identChar :: [Char] -identChar = '_' : identStartChar -newtype Name = Name { unName :: B.ByteString } deriving (Show) -instance Arbitrary Name where - arbitrary = do - x <- elements identStartChar - n <- choose (4,10) - rest <- vectorOf n $ elements identChar - return $ Name $ B.pack (x:rest) +identChar :: [Char] +identChar = '_' : identStartChar -instance Arbitrary Node where - arbitrary = limitedDepth 3 - shrink (X.Text _) = [] - shrink (X.Element _ [] []) = [] - shrink (X.Element n [] (_:cs)) = [X.Element n [] cs] - shrink (X.Element n (_:as) []) = [X.Element n as []] - shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs] textGen :: Gen [Char] textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar) + limitedDepth :: Int -> Gen Node limitedDepth 0 = liftM (X.Text . B.pack) textGen limitedDepth n = oneof [ liftM (X.Text . B.pack) textGen , liftM3 X.Element arbitrary (liftM (take 2) arbitrary) - (liftM (take 3) $ listOf $ limitedDepth (n-1)) + (liftM (take 3) $ listOf $ limitedDepth (n - 1)) ] -instance Arbitrary B.ByteString where - arbitrary = liftM unName arbitrary - -{- - - Code for inserting nodes into any point of a tree - -} - -type Loc = Cursor B.ByteString B.ByteString -type Insert a = State Int a - -{- - - Returns the number of unique insertion points in the tree. - - If h = insertAt f n g", the following property holds: - - insSize h == (insSize f) + (insSize g) - 1 - -} +-- | Returns the number of unique insertion points in the tree. +-- If h = insertAt f n g", the following property holds: +-- insSize h == (insSize f) + (insSize g) - 1 insSize :: [X.Node tag text] -> Int insSize ns = 1 + (sum $ map nodeSize ns) where nodeSize (X.Text _) = 1 nodeSize (X.Element _ _ c) = 1 + (insSize c) + insertAt :: [Node] -> Int -> [Node] -> [Node] insertAt elems 0 ns = elems ++ ns insertAt elems _ [] = elems insertAt elems n list = maybe [] (toForest . root) $ - evalState (processNode elems $ fromJust $ fromForest list) n + evalState (processNode elems $ fromJust $ fromForest list) n + move :: Insert () move = modify (\x -> x-1) + processNode :: [Node] -> Loc -> Insert (Maybe Loc) processNode elems loc = liftM2 mplus (move >> goDown loc) (move >> goRight loc) where goDown l = case current l of @@ -227,45 +243,86 @@ processNode elems loc = liftM2 mplus (move >> goDown loc) (move >> goRight loc) then return $ insertFunc l else maybe (return Nothing) (processNode elems) $ next l + +-- | Reloads the templates from disk and renders the specified +-- template. (Old convenience code.) +quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) +quickRender baseDir name = do + ts <- loadTS baseDir + renderTemplate ts name + + +newtype Name = Name { unName :: B.ByteString } deriving (Show) + +instance Arbitrary Name where + arbitrary = do + x <- elements identStartChar + n <- choose (4,10) + rest <- vectorOf n $ elements identChar + return $ Name $ B.pack (x:rest) + +instance Arbitrary Node where + arbitrary = limitedDepth 3 + shrink (X.Text _) = [] + shrink (X.Element _ [] []) = [] + shrink (X.Element n [] (_:cs)) = [X.Element n [] cs] + shrink (X.Element n (_:as) []) = [X.Element n as []] + shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs] + + +instance Arbitrary B.ByteString where + arbitrary = liftM unName arbitrary + +{- + - Code for inserting nodes into any point of a tree + -} +type Loc = Cursor B.ByteString B.ByteString +type Insert a = State Int a + + {- - tests -} -- Data type encapsulating the parameters for a bind operation -data Bind = Bind { - _bindElemName :: Name, - _bindChildren :: [Node], - _bindDoc :: [Node], - _bindPos :: Int, - _bindRefPos :: Int -} -- deriving (Show) +data Bind = Bind + { _bindElemName :: Name + , _bindChildren :: [Node] + , _bindDoc :: [Node] + , _bindPos :: Int + , _bindRefPos :: Int + } -- deriving (Show) + instance Show Bind where show b@(Bind e c d p r) = unlines - ["\n" - ,"Bind element name: "++(show e) - ,"Bind pos: "++(show p) - ,"Bind ref pos: "++(show r) - ,"Bind document:" - ,L.unpack $ L.concat $ map formatNode d - ,"Bind children:" - ,L.unpack $ L.concat $ map formatNode c - ,"Result:" - ,L.unpack $ L.concat $ map formatNode $ buildResult b - ,"Splice result:" - ,L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ + [ "\n" + , "Bind element name: " ++ (show e) + , "Bind pos: " ++ (show p) + , "Bind ref pos: " ++ (show r) + , "Bind document:" + , L.unpack $ L.concat $ map formatNode d + , "Bind children:" + , L.unpack $ L.concat $ map formatNode c + , "Result:" + , L.unpack $ L.concat $ map formatNode $ buildResult b + , "Splice result:" + , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ evalTemplateMonad (runNodeList $ buildBindTemplate b) (X.Text "") emptyTemplateState - ,"Template:" - ,L.unpack $ L.concat $ map formatNode $ buildBindTemplate b + , "Template:" + , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b ] + buildNode :: B.ByteString -> B.ByteString -> Bind -> Node buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c + buildBind :: Bind -> Node buildBind = buildNode "bind" "tag" + instance Arbitrary Bind where arbitrary = do name <- arbitrary @@ -279,87 +336,64 @@ instance Arbitrary Bind where shrink (Bind e (_:cs) d p r) = [Bind e cs d p r] shrink _ = [] + empty :: tag -> X.Node tag text empty n = X.Element n [] [] + buildBindTemplate :: Bind -> [Node] buildBindTemplate s@(Bind n _ d b r) = - insertAt [empty $ unName $ n] pos $ withBind + insertAt [empty $ unName $ n] pos $ withBind where bind = [buildBind s] bindSize = insSize bind withBind = insertAt bind b d pos = b + bindSize - 1 + r + buildResult :: Bind -> [Node] -buildResult (Bind _ c d b r) = insertAt c (b+r) d +buildResult (Bind _ c d b r) = insertAt c (b + r) d -prop_simpleBindTest :: Bind -> PropertyM IO () -prop_simpleBindTest bind = do - let template = buildBindTemplate bind - result = buildResult bind - spliceResult <- run $ evalTemplateMonad (runNodeList template) - (X.Text "") - emptyTemplateState - - assert $ result == spliceResult {- - tests -} +data Apply = Apply + { _applyName :: Name + , _applyCaller :: [Node] + , _applyCallee :: Template + , _applyChildren :: [Node] + , _applyPos :: Int + } deriving (Show) -data Apply = Apply { - _applyName :: Name, - _applyCaller :: [Node], - _applyCallee :: Template, - _applyChildren :: [Node], - _applyPos :: Int -} deriving (Show) instance Arbitrary Apply where - arbitrary = do - name <- arbitrary - kids <- liftM (take 3) $ listOf $ limitedDepth 2 - caller <- liftM (take 5) arbitrary - callee <- liftM (take 1) $ listOf $ limitedDepth 3 - let s = insSize caller - loc <- choose (0, s-1) - return $ Apply name caller callee kids loc + arbitrary = do + name <- arbitrary + kids <- liftM (take 3) $ listOf $ limitedDepth 2 + caller <- liftM (take 5) arbitrary + callee <- liftM (take 1) $ listOf $ limitedDepth 3 + let s = insSize caller + loc <- choose (0, s-1) + return $ Apply name caller callee kids loc + buildApplyCaller :: Apply -> [Node] buildApplyCaller (Apply name caller _ kids pos) = - insertAt [X.Element "apply" [("template", unName name)] kids] pos caller + insertAt [X.Element "apply" [("template", unName name)] kids] pos caller + calcCorrect :: Apply -> [Node] calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller + calcResult :: (MonadIO m) => Apply -> m [Node] calcResult apply@(Apply name _ callee _ _) = - evalTemplateMonad (runNodeList $ buildApplyCaller apply) - (X.Text "") ts - + evalTemplateMonad (runNodeList $ buildApplyCaller apply) + (X.Text "") ts where ts = setTemplates (Map.singleton [unName name] - (InternalTemplate Nothing callee)) - emptyTemplateState + (InternalTemplate Nothing callee)) + emptyTemplateState -prop_simpleApplyTest :: Apply -> PropertyM IO () -prop_simpleApplyTest apply = do - let correct = calcCorrect apply - result <- run $ calcResult apply - assert $ correct == result - - -loadTS :: FilePath -> IO (TemplateState IO) -loadTS baseDir = do - etm <- loadTemplates baseDir emptyTemplateState - return $ either error id etm - ------------------------------------------------------------------------------- --- | Reloads the templates from disk and renders the specified --- template. (Old convenience code.) -quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) -quickRender baseDir name = do - ts <- loadTS baseDir - renderTemplate ts name {- @@ -387,8 +421,6 @@ r name etm = do let ts = either (error "Danger Will Robinson!") id etm ns <- runNodeList ts name return $ (Just . formatList') =<< ns - - -}