diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -2,5 +2,6 @@ Gregory Collins Carl Howells Edward Kmett +Will Langstroth Shane O'Brien James Sanders diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,32 @@ -Heist ------ +# Heist -Heist, part of the Snap Framework (http://www.snapframework.com/), is a Haskell -library for xhtml templating. FIXME: more description here +Heist, part of the [Snap Framework](http://www.snapframework.com/), is a +Haskell library for xhtml templating. It uses simple XML tags to bind values +to your templates in a straightforward way. For example, if you were to put +the following in a template: -Building heist --------------------- + some text +

+the resulting xhtml would be + +

some text

+ +Likewise, if you need to add text to an attribute, + + special-id +
very special
+ +gives you + +
very special
+ +Values can also be pulled from "Splices" (see +[the documentation](http://snapframework.com/docs/tutorials/heist#heist-programming) +for more information.) + +## Building heist + The heist library is built using [Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run @@ -35,6 +55,5 @@ From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh - The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. diff --git a/heist.cabal b/heist.cabal --- a/heist.cabal +++ b/heist.cabal @@ -1,5 +1,5 @@ name: heist -version: 0.2.3 +version: 0.2.4 synopsis: An xhtml templating system license: BSD3 license-file: LICENSE @@ -88,14 +88,14 @@ Text.Templating.Heist.Types build-depends: - attoparsec >= 0.8.0.2 && < 0.9, + attoparsec >= 0.8.1 && < 0.9, base >= 4 && < 5, bytestring, containers, directory, directory-tree, filepath, - hexpat >= 0.18.2 && <0.19, + hexpat >= 0.19 && <0.20, MonadCatchIO-transformers >= 0.2.1 && < 0.3, monads-fd, process, diff --git a/src/Text/Templating/Heist/Internal.hs b/src/Text/Templating/Heist/Internal.hs --- a/src/Text/Templating/Heist/Internal.hs +++ b/src/Text/Templating/Heist/Internal.hs @@ -233,14 +233,15 @@ -- | Performs splice processing on a single node. runNode :: Monad m => Node -> Splice m runNode n@(X.Text _) = return [n] -runNode n@(X.Element nm at ch) = do +runNode (X.Element nm at ch) = do + newAtts <- mapM attSubst at + let n = X.Element nm newAtts ch s <- liftM (lookupSplice nm) getTS - maybe runChildren (recurseSplice n) s + maybe (runChildren newAtts) (recurseSplice n) s where - runChildren = do + runChildren newAtts = do newKids <- runNodeList ch - newAtts <- mapM attSubst at return [X.Element nm newAtts newKids] diff --git a/src/Text/Templating/Heist/Types.hs b/src/Text/Templating/Heist/Types.hs --- a/src/Text/Templating/Heist/Types.hs +++ b/src/Text/Templating/Heist/Types.hs @@ -9,7 +9,7 @@ {-| This module contains the core Heist data types. TemplateMonad intentionally -does not expose any of it's functionality via MonadState or MonadReader +does not expose any of its functionality via MonadState or MonadReader functions. We define passthrough instances for the most common types of monads. These instances allow the user to use TemplateMonad in a monad stack without needing calls to `lift`. diff --git a/test/heist-testsuite.cabal b/test/heist-testsuite.cabal --- a/test/heist-testsuite.cabal +++ b/test/heist-testsuite.cabal @@ -9,7 +9,7 @@ build-depends: QuickCheck >= 2, - attoparsec >= 0.8.0.2 && < 0.9, + attoparsec >= 0.8.1 && < 0.9, base >= 4 && < 5, bytestring, containers, @@ -17,7 +17,7 @@ directory-tree, process, filepath, - hexpat >= 0.18.2 && <0.19, + hexpat >= 0.19 && <0.20, HUnit >= 1.2 && < 2, monads-fd, random, diff --git a/test/suite/Text/Templating/Heist/Tests.hs b/test/suite/Text/Templating/Heist/Tests.hs --- a/test/suite/Text/Templating/Heist/Tests.hs +++ b/test/suite/Text/Templating/Heist/Tests.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Text.Templating.Heist.Tests ( tests , quickRender @@ -26,85 +30,136 @@ import Text.Templating.Heist.Internal import Text.Templating.Heist.Types import Text.Templating.Heist.Splices.Apply +import Text.Templating.Heist.Splices.Ignore +import Text.Templating.Heist.Splices.Markdown 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 - , testCase "stateMonoidTest" monoidTest - , testCase "templateAddTest" addTest - , testCase "getDocTest" getDocTest - , testCase "loadTest" loadTest - , testCase "fsLoadTest" fsLoadTest - , testCase "renderNoNameTest" renderNoNameTest - , testCase "doctypeTest" doctypeTest - , testCase "attributeSubstitution" attrSubst - , testCase "applyTest" applyTest +tests = [ testProperty "heist/simpleBind" simpleBindTest + , testProperty "heist/simpleApply" simpleApplyTest + , testCase "heist/stateMonoid" monoidTest + , testCase "heist/templateAdd" addTest + , testCase "heist/hasTemplate" hasTemplateTest + , testCase "heist/getDoc" getDocTest + , testCase "heist/load" loadTest + , testCase "heist/fsLoad" fsLoadTest + , testCase "heist/renderNoName" renderNoNameTest + , testCase "heist/doctype" doctypeTest + , testCase "heist/attributeSubstitution" attrSubstTest + , testCase "heist/bindAttribute" bindAttrTest + , testCase "heist/markdown" markdownTest + , testCase "heist/markdownText" markdownTextTest + , testCase "heist/apply" applyTest + , testCase "heist/ignore" ignoreTest ] -applyTest :: H.Assertion -applyTest = do - let es = emptyTemplateState :: TemplateState IO - res <- evalTemplateMonad applyImpl - (X.Element "apply" [("template", "nonexistant")] []) es - H.assertEqual "apply nothing" res [] - + +------------------------------------------------------------------------------ +simpleBindTest :: Property +simpleBindTest = monadicIO $ forAllM arbitrary prop + where + prop :: Bind -> PropertyM IO () + prop bind = do + let template = buildBindTemplate bind + let result = buildResult bind + + spliceResult <- run $ evalTemplateMonad (runNodeList template) + (X.Text "") + emptyTemplateState + assert $ result == spliceResult + + +------------------------------------------------------------------------------ +simpleApplyTest :: Property +simpleApplyTest = monadicIO $ forAllM arbitrary prop + where + prop :: Apply -> PropertyM IO () + prop 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 - where ts = addTemplate "aoeu" [] (mempty::TemplateState IO) + H.assertEqual "lookup test" (Just []) $ + fmap (_itNodes . fst) $ lookupTemplate "aoeu" ts -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft (Right _) = False + H.assertEqual "splice touched" 0 $ Map.size (_spliceMap ts) + where + ts = addTemplate "aoeu" [] (mempty::TemplateState IO) -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 == 15 - ) ets +------------------------------------------------------------------------------ +hasTemplateTest :: H.Assertion +hasTemplateTest = do + ets <- loadT "templates" + let tm = either (error "Error loading templates") _templateMap ets + let ts = setTemplates tm emptyTemplateState :: TemplateState IO + H.assertBool "hasTemplate ts" (hasTemplate "index" ts) -renderNoNameTest :: H.Assertion -renderNoNameTest = do - ets <- loadT "templates" - either (error "Error loading templates") - (\ts -> do t <- renderTemplate ts "" - H.assertBool "renderNoName" $ t == Nothing - ) 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 + d <- getDoc "bkteoar" + H.assertBool "non-existent doc" $ isLeft d + f <- getDoc "templates/index.tpl" + H.assertBool "index doc" $ not $ isLeft f + +------------------------------------------------------------------------------ +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 == 17 + ) ets + + +------------------------------------------------------------------------------ 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 + let f = g ts + f isNothing "abc/def/xyz" + f isJust "a" + f isJust "bar/a" + f isJust "/bar/a" + + where + g ts p n = H.assertBool ("loading template " ++ n) $ p $ + lookupTemplate (B.pack n) ts + +------------------------------------------------------------------------------ +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 ets <- loadT "templates" @@ -114,237 +169,344 @@ ioc <- renderTemplate ts "ioc" H.assertBool "doctype test ioc" $ hasDoctype $ fromJust ioc -attrSubst :: H.Assertion -attrSubst = do + +------------------------------------------------------------------------------ +attrSubstTest :: H.Assertion +attrSubstTest = do ets <- loadT "templates" let ts = either (error "Error loading templates") id ets check (setTs "meaning_of_everything" ts) "pre_meaning_of_everything_post" check ts "pre__post" + where 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 --- dotdotTest :: H.Assertion --- dotdotTest = 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 +------------------------------------------------------------------------------ +bindAttrTest :: H.Assertion +bindAttrTest = do + ets <- loadT "templates" + let ts = either (error "Error loading templates") id ets + check ts "

This is a test.

" + + +------------------------------------------------------------------------------ +-- | Markdown test on a file +markdownTest :: H.Assertion +markdownTest = do + ets <- loadT "templates" + let ts = either (error "Error loading templates") id ets + + check ts htmlExpected + + where + check ts str = do + result <- liftM (fmap $ B.filter (/= '\n')) $ + renderTemplate ts "markdown" + H.assertEqual ("Should match " ++ (show str)) str (fromJust result) + + +------------------------------------------------------------------------------ +-- | Markdown test on supplied text +markdownTextTest :: H.Assertion +markdownTextTest = do + result <- evalTemplateMonad markdownSplice + (X.Text "This *is* a test.") emptyTemplateState + H.assertEqual "Markdown text" htmlExpected + (B.filter (/= '\n') $ formatList' result) + + +------------------------------------------------------------------------------ +applyTest :: H.Assertion +applyTest = do + let es = emptyTemplateState :: TemplateState IO + res <- evalTemplateMonad applyImpl + (X.Element "apply" [("template", "nonexistant")] []) es + + H.assertEqual "apply nothing" [] res + + +------------------------------------------------------------------------------ +ignoreTest :: H.Assertion +ignoreTest = do + let es = emptyTemplateState :: TemplateState IO + res <- evalTemplateMonad ignoreImpl + (X.Element "ignore" [("tag", "ignorable")] + [X.Text "This should be ignored"]) es + H.assertEqual " tag" [] res + + +------------------------------------------------------------------------------ +-- 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 - first <- elements identStartChar - n <- choose (4,10) - rest <- vectorOf n $ elements identChar - return $ Name $ B.pack $ first : 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] - +------------------------------------------------------------------------------ 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)) - ] +limitedDepth n = + oneof [ liftM (X.Text . B.pack) textGen + , liftM3 X.Element arbitrary + (liftM (take 2) arbitrary) + (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) +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 +processNode elems loc = + liftM2 mplus (move >> goDown loc) (move >> goRight loc) + + where + goDown l = + case current l of X.Text _ -> modify (+1) >> return Nothing - X.Element _ _ _ -> doneCheck (insertManyFirstChild elems) firstChild l - goRight = doneCheck (Just . insertManyRight elems) right - doneCheck insertFunc next l = do - s <- get - if s == 0 - then return $ insertFunc l - else maybe (return Nothing) (processNode elems) $ next l + X.Element _ _ _ -> doneCheck (insertManyFirstChild elems) + firstChild + l -{- - - tests - -} + goRight = doneCheck (Just . insertManyRight elems) right --- Data type encapsulating the parameters for a bind operation -data Bind = Bind { - _bindElemName :: Name, - _bindChildren :: [Node], - _bindDoc :: [Node], - _bindPos :: Int, - _bindRefPos :: Int -} -- deriving (Show) + doneCheck insertFunc next l = do + s <- get + if s == 0 + then return $ insertFunc l + else maybe (return Nothing) (processNode elems) $ next l -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 $ - evalTemplateMonad (runNodeList $ buildBindTemplate b) - (X.Text "") emptyTemplateState - ,"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 +------------------------------------------------------------------------------ +-- | 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 -buildBind :: Bind -> Node -buildBind = buildNode "bind" "tag" +------------------------------------------------------------------------------ +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) + + instance Arbitrary Bind where arbitrary = do name <- arbitrary kids <- liftM (take 3) arbitrary doc <- liftM (take 5) arbitrary let s = insSize doc - loc <- choose (0, s-1) - loc2 <- choose (0, s-loc-1) + loc <- choose (0, s - 1) + loc2 <- choose (0, s - loc - 1) return $ Bind name kids doc loc loc2 shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r] shrink (Bind e (_:cs) d p r) = [Bind e cs d p r] shrink _ = [] + +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 $ + evalTemplateMonad (runNodeList $ buildBindTemplate b) + (X.Text "") emptyTemplateState + , "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" + + +------------------------------------------------------------------------------ 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 - -} +------------------------------------------------------------------------------ +-- 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 - - {- -- The beginning of some future tests for hook functions. @@ -370,8 +532,6 @@ let ts = either (error "Danger Will Robinson!") id etm ns <- runNodeList ts name return $ (Just . formatList') =<< ns - - -}