<b>ok</b>
1"
, "
falsefoo" ]
jsonExpected2 = "
ok1falsefoo"
------------------------------------------------------------------------------
jsonObjectTest :: H.Assertion
jsonObjectTest = do
renderTest "json_object" jsonExpected
where
jsonExpected = "
1ok12quuxquux1
ok"
------------------------------------------------------------------------------
-- | Render a template and assert that it matches an expected result
renderTest :: ByteString -- ^ template name
-> ByteString -- ^ expected result
-> H.Assertion
renderTest templateName expectedResult = do
ets <- loadT "templates" mempty pandocTestSplices mempty mempty
let ts = either (error "Error loading templates") id ets
check ts expectedResult
where
bind txt = bindJson v
where
v :: Value
v = fromJust $ decode txt
check ts0 str = do
let splices = do
"json" ## bind "[\"
ok\", 1, null, false, \"foo\"]"
"jsonObject" ##
(bind $ mconcat [
"{\"foo\": 1, \"bar\": \"
ok\", "
, "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, "
, "\"quux\": \"quux\" }"
])
let ts = bindSplices splices ts0
Just (doc, _) <- renderTemplate ts templateName
let result = B.filter (/= '\n') (toByteString doc)
H.assertEqual ("Should match " ++ (show str)) str result
------------------------------------------------------------------------------
-- | Expansion of a bound name inside a title-tag
titleExpansion :: H.Assertion
titleExpansion = renderTest "title_expansion" expected
where
expected = "
foo"
------------------------------------------------------------------------------
-- | Expansion of a bound name inside a textarea-tag
textareaExpansion :: H.Assertion
textareaExpansion = renderTest "textarea_expansion" expected
where
expected = B.concat
[ "
" ]
------------------------------------------------------------------------------
-- | Expansion of a bound name inside a div-tag
divExpansion :: H.Assertion
divExpansion = renderTest "div_expansion" expected
where
expected = "
foo
"
------------------------------------------------------------------------------
-- | Handling of
and bound parameters in a bound tag.
bindParam :: H.Assertion
bindParam = renderTest "bind_param" "Hi there world"
------------------------------------------------------------------------------
-- | Handling of and bound parameters in a bound tag.
attrSpliceContext :: H.Assertion
attrSpliceContext = renderTest "attrsubtest2"
"linkfoo"
------------------------------------------------------------------------------
-- | Markdown test on supplied text
markdownTextTest :: H.Assertion
markdownTextTest = do
hs <- loadEmpty mempty mempty mempty mempty
result <- evalHeistT markdownSplice
(X.TextNode "This *is* a test.")
hs
H.assertEqual "Markdown text" markdownHtmlExpected
(B.filter (/= '\n') $ toByteString $
X.render (X.HtmlDocument X.UTF8 Nothing result))
------------------------------------------------------------------------------
applyTest :: H.Assertion
applyTest = do
es <- loadEmpty mempty mempty mempty mempty
res <- evalHeistT applyImpl
(X.Element "apply" [("template", "nonexistant")] []) es
H.assertEqual "apply nothing" [] res
------------------------------------------------------------------------------
ignoreTest :: H.Assertion
ignoreTest = do
es <- loadEmpty mempty mempty mempty mempty
res <- evalHeistT ignoreImpl
(X.Element "ignore" [("tag", "ignorable")]
[X.TextNode "This should be ignored"]) es
H.assertEqual " tag" [] res
lookupTemplateTest :: IO ()
lookupTemplateTest = do
hs <- loadHS "templates"
let k = do
modifyHS (\st -> st { _curContext = ["foo"] })
getsHS $ (\hs' -> lookupTemplate "/user/menu" hs' _templateMap)
res <- runHeistT k (X.TextNode "") hs
H.assertBool "lookup context test" $ isJust $ fst res
------------------------------------------------------------------------------
xmlNotHtmlTest :: H.Assertion
xmlNotHtmlTest = renderTest "rss" expected where
expected = "http://www.devalot.com/"
------------------------------------------------------------------------------
identStartChar :: [Char]
identStartChar = ['a'..'z']
------------------------------------------------------------------------------
identChar :: [Char]
identChar = '_' : identStartChar
------------------------------------------------------------------------------
textGen :: Gen [Char]
textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar)
------------------------------------------------------------------------------
limitedDepth :: Int -> Gen X.Node
limitedDepth 0 = liftM (X.TextNode . T.pack) textGen
limitedDepth n =
oneof [ liftM (X.TextNode . T.pack) textGen
, liftM3 X.Element arbitrary
(liftM (take 2) arbitrary)
(liftM (take 3) $ listOf $ limitedDepth (n - 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] -> Int
insSize ns = 1 + (sum $ map nodeSize ns)
where nodeSize (X.Element _ _ c) = 1 + (insSize c)
nodeSize _ = 1
------------------------------------------------------------------------------
insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node]
insertAt elems 0 ns = elems ++ ns
insertAt elems _ [] = elems
insertAt elems n list = maybe [] X.topNodes $
evalState (processNode elems $ fromJust $ X.fromNodes list) n
------------------------------------------------------------------------------
move :: Insert ()
move = modify (\x -> x - 1)
------------------------------------------------------------------------------
processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor)
processNode elems loc =
liftM2 mplus (move >> goDown loc) (move >> goRight loc)
where
goDown l =
case X.current l of
X.TextNode _ -> modify (+1) >> return Nothing
X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems)
X.firstChild
l
X.Comment _ -> return Nothing
goRight = doneCheck (Just . X.insertManyRight elems) X.right
doneCheck insertFunc next l = do
s <- get
if s == 0
then return $ insertFunc l
else maybe (return Nothing) (processNode elems) $ next l
------------------------------------------------------------------------------
newtype Name = Name { unName :: Text } deriving (Show)
instance Arbitrary Name where
arbitrary = do
x <- elements identStartChar
n <- choose (4,10)
rest <- vectorOf n $ elements identChar
return $ Name $ T.pack (x:rest)
instance Arbitrary X.Node where
arbitrary = limitedDepth 3
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]
shrink _ = []
instance Arbitrary T.Text where
arbitrary = liftM unName arbitrary
--
-- Code for inserting nodes into any point of a tree
--
type Insert a = State Int a
------------------------------------------------------------------------------
-- tests
-- Data type encapsulating the parameters for a bind operation
data Bind = Bind
{ _bindElemName :: Name
, _bindChildren :: [X.Node]
, _bindDoc :: [X.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)
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 $ do
hs <- loadEmpty mempty mempty mempty mempty
evalHeistT (runNodeList $ buildBindTemplate b)
(X.TextNode "") hs
, "Template:"
, L.unpack $ L.concat $ map formatNode $ buildBindTemplate b
]
where
formatNode n = toLazyByteString $ X.render
$ X.HtmlDocument X.UTF8 Nothing [n]
------------------------------------------------------------------------------
buildNode :: Text -> Text -> Bind -> X.Node
buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c
------------------------------------------------------------------------------
buildBind :: Bind -> X.Node
buildBind = buildNode "bind" "tag"
------------------------------------------------------------------------------
empty :: Text -> X.Node
empty n = X.Element n [] []
------------------------------------------------------------------------------
buildBindTemplate :: Bind -> [X.Node]
buildBindTemplate s@(Bind n _ d b r) =
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 -> [X.Node]
buildResult (Bind _ c d b r) = insertAt c (b + r) d
------------------------------------------------------------------------------
-- tests
data Apply = Apply
{ _applyName :: Name
, _applyCaller :: [X.Node]
, _applyCallee :: Template
, _applyChildren :: [X.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
------------------------------------------------------------------------------
buildApplyCaller :: Apply -> [X.Node]
buildApplyCaller (Apply name caller _ kids pos) =
insertAt [X.Element "apply" [("template", unName name)] kids] pos caller
------------------------------------------------------------------------------
calcCorrect :: Apply -> [X.Node]
calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller
------------------------------------------------------------------------------
calcResult :: Apply -> IO [X.Node]
calcResult apply@(Apply name _ callee _ _) = do
hs <- loadEmpty defaultLoadTimeSplices mempty mempty mempty
let hs' = setTemplates (Map.singleton [T.encodeUtf8 $ unName name]
(DocumentFile (X.HtmlDocument X.UTF8 Nothing callee)
Nothing)) hs
evalHeistT (runNodeList $ buildApplyCaller apply)
(X.TextNode "") hs'
{-
- Convenience code for manual ghci experimentation
-}
--html :: [Node] -> Node
--html c = X.Element "html" [] [hhead, body c]
--hhead :: Node
--hhead = X.Element "head" [] [title, X.Element "script" [] []]
--title :: Node
--title = X.Element "title" [] [X.Text "Test Page"]
--body :: [Node] -> Node
--body = X.Element "body" []
--
--para :: Int -> Node
--para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n]
--para2 :: B.ByteString -> Node
--para2 c = X.Element "p" [] [X.Text c]
--para3 :: Node
--para3 = X.Element "p" [] [X.Text "AHA!"]
--
--foo :: Int -> [Node]
--foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]]
--
--tdoc :: [Node]
--tdoc = [para 1, para 2, para 3, para 4]
--
--bindElem :: [Node] -> Int -> Int -> Bind
--bindElem = Bind (Name "mytag") [para2 "bound paragraph"]
--
--addBind :: Bind -> [Node] -> [Node]
--addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2
--
--prn :: Node -> IO ()
--prn = L.putStrLn . formatNode
--runTests :: IO ()
--runTests = defaultMain tests