diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,54 +0,0 @@ -xmlhtml - XML and HTML 5 parsing and rendering - -This library implements both parsers and renderers for XML and HTML 5 document -fragments. The two share data structures to represent the document tree, so -that you can write code to easily work with either XML or HTML 5. Convenience -functions are also available to work with the internal data structure in -several natural ways. - -Caveats: - -- Both parsers are written to parse document fragments, not complete - documents. This means that they do not enforce rules about overall - document structure. There does not need to be only a single root node, - and the HTML 5 implementation never inserts any missing start tags. - -- The XML parser is incapable of handling processing instructions, or defined - entities. If will silently drop processing instructions, and will fail if - encounters an entity reference for anything by the predefined entities - (apos, quot, amp, lt, and gt). - -- The HTML parser is really an XML parser with HTML 5 quirks mode. It should - be just fine for parsing documents that conform to the HTML 5 specification. - However, it is *not* a compliant HTML 5 parser, as compliant parsers are - required to be compatible with non-compliant documents in many ways that we - aren't interested in. So this is a great basis for a template system, for - example, but a very poor basis for a web browser or web spider. - -To get started, just use the parseHTML or parseXML functions from Text.XmlHtml -to parse a ByteString into a document tree. On the other side, use render to -write the document tree back to a ByteString. - -Working with document trees is easily done in two ways. - -1. Text.XmlHtml exports the document tree types (notably, Document and Node) - and functions like getAttribute, setAttribute, tagName, childNodes, etc. for - working with them. - -2. Text.XmlHtml.Cursor exports a zipper for node forests, which you can use to - navigate and modify the document tree positionally. - -That's it, basically. This is hopefully a pretty simple package to use. - -TO DO Items: - -1. Do something better with character encodings. For now, they are basically - ignored, and we just use the byte order mark to distinguish between the - three required encodings. We should implement the encoding sniffing rules - for both XML (the declaration) and HTML 5. - -2. Benchmark and improve performance of the parsers and renderers. - -3. Ensure that rendering always gives an error rather than writing an invalid - document. (Is this a good idea? It does limit rendering speed.) - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +xmlhtml - XML and HTML 5 parsing and rendering +---------------------------------------------- + +[![Build Status](https://travis-ci.org/snapframework/xmlhtml.svg?branch=master)](https://travis-ci.org/snapframework/xmlhtml) + +This library implements both parsers and renderers for XML and HTML 5 document +fragments. The two share data structures to represent the document tree, so +that you can write code to easily work with either XML or HTML 5. Convenience +functions are also available to work with the internal data structure in +several natural ways. + +Caveats: + +- Both parsers are written to parse document fragments, not complete + documents. This means that they do not enforce rules about overall + document structure. There does not need to be only a single root node, + and the HTML 5 implementation never inserts any missing start tags. + +- The XML parser is incapable of handling processing instructions, or defined + entities. If will silently drop processing instructions, and will fail if + encounters an entity reference for anything by the predefined entities + (apos, quot, amp, lt, and gt). + +- The HTML parser is really an XML parser with HTML 5 quirks mode. It should + be just fine for parsing documents that conform to the HTML 5 specification. + However, it is *not* a compliant HTML 5 parser, as compliant parsers are + required to be compatible with non-compliant documents in many ways that we + aren't interested in. So this is a great basis for a template system, for + example, but a very poor basis for a web browser or web spider. + +To get started, just use the parseHTML or parseXML functions from Text.XmlHtml +to parse a ByteString into a document tree. On the other side, use render to +write the document tree back to a ByteString. + +Working with document trees is easily done in two ways. + +1. Text.XmlHtml exports the document tree types (notably, Document and Node) + and functions like getAttribute, setAttribute, tagName, childNodes, etc. for + working with them. + +2. Text.XmlHtml.Cursor exports a zipper for node forests, which you can use to + navigate and modify the document tree positionally. + +That's it, basically. This is hopefully a pretty simple package to use. + +TO DO Items: + +1. Do something better with character encodings. For now, they are basically + ignored, and we just use the byte order mark to distinguish between the + three required encodings. We should implement the encoding sniffing rules + for both XML (the declaration) and HTML 5. + +2. Benchmark and improve performance of the parsers and renderers. + +3. Ensure that rendering always gives an error rather than writing an invalid + document. (Is this a good idea? It does limit rendering speed.) + diff --git a/src/Text/Blaze/Renderer/XmlHtml.hs b/src/Text/Blaze/Renderer/XmlHtml.hs --- a/src/Text/Blaze/Renderer/XmlHtml.hs +++ b/src/Text/Blaze/Renderer/XmlHtml.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | Renderer that supports rendering to xmlhtml forests. This is a port of -- the Hexpat renderer. -- @@ -8,11 +10,11 @@ module Text.Blaze.Renderer.XmlHtml (renderHtml, renderHtmlNodes) where import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Text.Blaze.Html -import Text.Blaze.Internal -import Text.XmlHtml +import Text.Blaze.Internal as TBI +import Text.XmlHtml as X -- | Render a 'ChoiceString' to Text. This is only meant to be used for @@ -66,6 +68,10 @@ go ((fromChoiceStringText key, fromChoiceStringText value) : attrs) content go _ (Content content) = fromChoiceString content +#if MIN_VERSION_blaze_markup(0,6,3) + go _ (TBI.Comment comment) = + (X.Comment (fromChoiceStringText comment) :) +#endif go attrs (Append h1 h2) = go attrs h1 . go attrs h2 go _ Empty = id {-# NOINLINE go #-} diff --git a/src/Text/XmlHtml/HTML/Meta.hs b/src/Text/XmlHtml/HTML/Meta.hs --- a/src/Text/XmlHtml/HTML/Meta.hs +++ b/src/Text/XmlHtml/HTML/Meta.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -O0 -fno-case-merge -fno-strictness -fno-cse #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.XmlHtml.HTML.Meta @@ -10,7 +11,9 @@ , predefinedRefs ) where +#if !MIN_VERSION_base(4,8,0) import Data.Monoid +#endif import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.HashSet (HashSet) diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -6,7 +7,6 @@ import Blaze.ByteString.Builder import Control.Applicative import Data.Maybe -import Data.Monoid import qualified Text.Parsec as P import Text.XmlHtml.Common import Text.XmlHtml.TextParser @@ -19,6 +19,10 @@ import qualified Data.HashSet as S +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + ------------------------------------------------------------------------------ -- | And, the rendering code. render :: Encoding -> Maybe DocType -> [Node] -> Builder @@ -82,7 +86,7 @@ firstNode e (Element t a c) = node e (Element t a c) firstNode _ (TextNode "") = mempty firstNode e (TextNode t) = let (c,t') = fromJust $ T.uncons t - in escaped "<>& \t\r\n" e (T.singleton c) + in escaped "<>& \t\r" e (T.singleton c) `mappend` node e (TextNode t') diff --git a/src/Text/XmlHtml/TextParser.hs b/src/Text/XmlHtml/TextParser.hs --- a/src/Text/XmlHtml/TextParser.hs +++ b/src/Text/XmlHtml/TextParser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -16,7 +17,9 @@ , module Text.Parsec.Text ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Data.Char import Data.Maybe import Text.XmlHtml.Common diff --git a/src/Text/XmlHtml/XML/Render.hs b/src/Text/XmlHtml/XML/Render.hs --- a/src/Text/XmlHtml/XML/Render.hs +++ b/src/Text/XmlHtml/XML/Render.hs @@ -1,3 +1,5 @@ + +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.XmlHtml.XML.Render where @@ -5,13 +7,16 @@ import Blaze.ByteString.Builder import Data.Char import Data.Maybe -import Data.Monoid import Text.XmlHtml.Common import Data.Text (Text) import qualified Data.Text as T +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + ------------------------------------------------------------------------------ render :: Encoding -> Maybe DocType -> [Node] -> Builder render e dt ns = byteOrder @@ -106,7 +111,7 @@ firstNode e (Element t a c) = node e (Element t a c) firstNode _ (TextNode "") = mempty firstNode e (TextNode t) = let (c,t') = fromJust $ T.uncons t - in escaped "<>& \t\r\n" e (T.singleton c) + in escaped "<>& \t\r" e (T.singleton c) `mappend` node e (TextNode t') diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh deleted file mode 100644 --- a/test/runTestsAndCoverage.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/bin/sh - -set -e - -if [ -z "$DEBUG" ]; then - export DEBUG="testsuite" -fi - -SUITE=./dist/build/testsuite/testsuite - -export LC_ALL=C -export LANG=C - -rm -f testsuite.tix - -if [ ! -f $SUITE ]; then - cat </dev/null 2>&1 - -rm -f testsuite.tix - -cat < n == current (fromNode n)) ns + where ns = [ + TextNode "foo", + Comment "bar", + Element "foo" [] [], + Element "root" [] [ + TextNode "foo", + Comment "bar", + Element "foo" [] [] + ] + ] + +fromNodesAndSiblings :: Bool +fromNodesAndSiblings = n == siblings (fromJust $ fromNodes n) + where n = [ + TextNode "foo", + Comment "bar", + Element "foo" [] [], + Element "root" [] [ + TextNode "foo", + Comment "bar", + Element "foo" [] [] + ] + ] + +leftSiblings :: Bool +leftSiblings = fromJust $ do + r <- do + c1 <- fromNodes n + c2 <- right c1 + c3 <- right c2 + return c3 + return (n == siblings r) + where n = [ + TextNode "foo", + Comment "bar", + Element "foo" [] [], + Element "root" [] [ + TextNode "foo", + Comment "bar", + Element "foo" [] [] + ] + ] + +emptyFromNodes :: Bool +emptyFromNodes = isNothing (fromNodes []) + +cursorNEQ :: Bool +cursorNEQ = let a = fromNode (Element "a" [] []) + b = fromNode (Element "b" [] []) + in a /= b + +-- Sample node structure for running cursor tests. +cursorTestTree :: Node +cursorTestTree = Element "department" [("code", "A17")] [ + Element "employee" [("name", "alice")] [ + Element "address" [] [ + TextNode "124 My Road" + ], + Element "phone" [] [ + TextNode "555-1234" + ] + ], + Element "employee" [("name", "bob")] [ + Comment "My best friend", + Element "address" [] [ + TextNode "123 My Road" + ], + Element "temp" [] [] + ], + Element "employee" [("name", "camille")] [ + Element "phone" [] [ + TextNode "800-888-8888" + ] + ] + ] + +cursorNavigation :: Assertion +cursorNavigation = do + let r = fromNode cursorTestTree + + let Just e1 = firstChild r + let Just e2 = getChild 1 r + let Just e3 = lastChild r + + assertBool "rootElem" $ isElement (current r) + assertBool "parent of root" $ isNothing (parent r) + + assertBool "getChild bounds" $ isNothing (getChild 3 r) + assertBool "getChild negative bounds" $ isNothing (getChild (-1) r) + assertBool "firstChild" $ + getAttribute "name" (current e1) == Just "alice" + assertBool "childAt 1 " $ + getAttribute "name" (current e2) == Just "bob" + assertBool "lastChild " $ + getAttribute "name" (current e3) == Just "camille" + + do let Just a = lastChild e2 + assertBool "firstChild on empty element" $ isNothing (firstChild a) + assertBool "getChild on empty element" $ isNothing (getChild 0 a) + assertBool "lastChild on empty element" $ isNothing (lastChild a) + + do let Just a = right e1 + let Just b = right a + assertBool "two paths #1" $ a == e2 + assertBool "two paths #2" $ b == e3 + assertBool "right off end" $ isNothing (right b) + + let Just c = left e3 + let Just d = left e2 + assertBool "two paths #3" $ c == e2 + assertBool "two paths #4" $ d == e1 + assertBool "left off end" $ isNothing (left d) + + do let Just r1 = parent e2 + assertEqual "child -> parent" (current r) (current r1) + + do let Just cmt = firstChild e2 + assertBool "topNode" $ tagName (topNode cmt) == Just "department" + assertBool "topNodes" $ map tagName (topNodes cmt) == [ Just "department" ] + + assertBool "first child of comment" $ isNothing (firstChild cmt) + assertBool "last child of comment" $ isNothing (lastChild cmt) + + do assertBool "nextDF down" $ nextDF r == Just e1 + + let Just cmt = firstChild e2 + assertBool "nextDF right" $ nextDF cmt == right cmt + + let Just em = lastChild e2 + assertBool "nextDF up-right" $ nextDF em == Just e3 + + let Just pelem = lastChild e3 + let Just ptext = lastChild pelem + assertBool "nextDF end" $ isNothing (nextDF ptext) + + +cursorSearch :: Assertion +cursorSearch = do + let r = fromNode cursorTestTree + + let Just e1 = findChild isFirst r + let Just e2 = findChild ((==(Just "bob")) . getAttribute "name" . current) r + let Just e3 = findChild isLast r + + assertBool "findChild isFirst" $ + getAttribute "name" (current e1) == Just "alice" + assertBool "findChild" $ + getAttribute "name" (current e2) == Just "bob" + assertBool "findChild isLast" $ + getAttribute "name" (current e3) == Just "camille" + + assertBool "findLeft Just" $ findLeft (const True) e2 == Just e1 + assertBool "findLeft Nothing" $ findLeft (const False) e2 == Nothing + assertBool "findRight Just" $ findRight (const True) e2 == Just e3 + assertBool "findRight Nothing" $ findRight (const False) e2 == Nothing + assertBool "findRec" $ findRec (not . hasChildren) r == (firstChild =<< firstChild e1) + + assertBool "isChild true" $ isChild e1 + assertBool "isChild false" $ not $ isChild r + assertBool "getNodeIndex" $ getNodeIndex e2 == 1 + + +cursorMutation :: Assertion +cursorMutation = do + let r = fromNode cursorTestTree + + let Just e1 = firstChild r + let Just e2 = right e1 + let Just e3 = lastChild r + + do let Just cmt = firstChild e2 + let cmt' = setNode (Comment "Not my friend any more") cmt + let Just e2' = parent cmt' + assertBool "setNode" $ current e2' == + Element "employee" [("name", "bob")] [ + Comment "Not my friend any more", + Element "address" [] [ + TextNode "123 My Road" + ], + Element "temp" [] [] + ] + + do let e1' = modifyNode (setAttribute "name" "bryan") e1 + let n = current e1' + assertBool "modifyNode" $ getAttribute "name" n == Just "bryan" + + do let myModifyM = return . setAttribute "name" "chelsea" + e3' <- modifyNodeM myModifyM e3 + let n = current e3' + assertBool "modifyNode" $ getAttribute "name" n == Just "chelsea" + + +cursorInsertion :: Assertion +cursorInsertion = do + let r = fromNode cursorTestTree + let Just alice = firstChild r + let Just bob = getChild 1 r + let Just camille = lastChild r + + let fred = Element "employee" [("name", "fred")] [] + + -- Stock insertLeft + do let ins = insertLeft fred bob + assertBool "insertLeft leaves cursor" $ + getAttribute "name" (current ins) == Just "bob" + + let Just a = findLeft isFirst ins + assertBool "insertLeft 1" $ + getAttribute "name" (current a) == Just "alice" + + let Just b = right a + assertBool "insertLeft 2" $ + getAttribute "name" (current b) == Just "fred" + + let Just c = right b + assertBool "insertLeft 3" $ + getAttribute "name" (current c) == Just "bob" + + let Just d = right c + assertBool "insertLeft 4" $ + getAttribute "name" (current d) == Just "camille" + + -- insertLeft on first child + do let ins = insertLeft fred alice + assertBool "insertLeft firstChild" $ + getAttribute "name" (current ins) == Just "alice" + + let Just a = findLeft isFirst ins + assertBool "insertLeft firstChild 1" $ + getAttribute "name" (current a) == Just "fred" + + -- Stock insertRight + do let ins = insertRight fred alice + assertBool "insertRight leaves cursor" $ + getAttribute "name" (current ins) == Just "alice" + + let Just a = findRight isLast ins + assertBool "insertRight 1" $ + getAttribute "name" (current a) == Just "camille" + + let Just b = left a + assertBool "insertRight 2" $ + getAttribute "name" (current b) == Just "bob" + + let Just c = left b + assertBool "insertRight 3" $ + getAttribute "name" (current c) == Just "fred" + + let Just d = left c + assertBool "insertRight 4" $ + getAttribute "name" (current d) == Just "alice" + + -- insertRight on last child + do let ins = insertRight fred camille + assertBool "insertRight lastChild" $ + getAttribute "name" (current ins) == Just "camille" + + let Just a = findRight isLast ins + assertBool "insertRight lastChild 1" $ + getAttribute "name" (current a) == Just "fred" + + let mary = Element "employee" [("name", "mary")] [] + let new = [fred, mary] + + -- insertManyLeft + do let ins = insertManyLeft new camille + assertBool "insertManyLeft leaves cursor" $ + getAttribute "name" (current ins) == Just "camille" + + let Just a = left ins + assertBool "insertManyLeft 1" $ + getAttribute "name" (current a) == Just "mary" + + let Just b = left a + assertBool "insertManyLeft 2" $ + getAttribute "name" (current b) == Just "fred" + + let Just c = left b + assertBool "insertManyLeft 3" $ + getAttribute "name" (current c) == Just "bob" + + -- insertManyRight + do let ins = insertManyRight new alice + assertBool "insertManyRight leaves cursor" $ + getAttribute "name" (current ins) == Just "alice" + + let Just a = right ins + assertBool "insertManyRight 1" $ + getAttribute "name" (current a) == Just "fred" + + let Just b = right a + assertBool "insertManyRight 2" $ + getAttribute "name" (current b) == Just "mary" + + let Just c = right b + assertBool "insertManyRight 3" $ + getAttribute "name" (current c) == Just "bob" + + -- insertFirstChild and insertLastChild + do let Just ins1 = insertFirstChild fred r + let Just ins2 = insertLastChild mary ins1 + + let Just a = firstChild ins2 + assertBool "insert children 1" $ + getAttribute "name" (current a) == Just "fred" + + let Just b = right a + assertBool "insert children 2" $ + getAttribute "name" (current b) == Just "alice" + + let Just c = right b + assertBool "insert children 3" $ + getAttribute "name" (current c) == Just "bob" + + let Just d = right c + assertBool "insert children 4" $ + getAttribute "name" (current d) == Just "camille" + + let Just e = right d + assertBool "insert children 5" $ + getAttribute "name" (current e) == Just "mary" + assertBool "insert children 6" $ isLast e + + -- non-element insertFirstChild and insertLastChild + do let Just cmt = firstChild bob + assertBool "non-elem insertFirstChild" $ + insertFirstChild fred cmt == Nothing + assertBool "non-elem insertLastChild" $ + insertLastChild fred cmt == Nothing + assertBool "non-elem insertManyFirstChild" $ + insertManyFirstChild new cmt == Nothing + assertBool "non-elem insertManyLastChild" $ + insertManyLastChild new cmt == Nothing + + -- insertManyFirstChild + do let Just ins = insertManyFirstChild new r + + let Just a = firstChild ins + assertBool "insertManyFirstChild 1" $ + getAttribute "name" (current a) == Just "fred" + + let Just b = right a + assertBool "insertManyFirstChild 2" $ + getAttribute "name" (current b) == Just "mary" + + let Just c = right b + assertBool "insertManyFirstChild 3" $ + getAttribute "name" (current c) == Just "alice" + + let Just d = right c + assertBool "insertManyFirstChild 4" $ + getAttribute "name" (current d) == Just "bob" + + let Just e = right d + assertBool "insertManyFirstChild 5" $ + getAttribute "name" (current e) == Just "camille" + assertBool "insertManyFirstChild 6" $ isLast e + + + -- insertManyLastChild + do let Just ins = insertManyLastChild new r + + let Just a = firstChild ins + assertBool "insertManyFirstChild 1" $ + getAttribute "name" (current a) == Just "alice" + + let Just b = right a + assertBool "insertManyFirstChild 2" $ + getAttribute "name" (current b) == Just "bob" + + let Just c = right b + assertBool "insertManyFirstChild 3" $ + getAttribute "name" (current c) == Just "camille" + + let Just d = right c + assertBool "insertManyFirstChild 4" $ + getAttribute "name" (current d) == Just "fred" + + let Just e = right d + assertBool "insertManyFirstChild 5" $ + getAttribute "name" (current e) == Just "mary" + assertBool "insertManyFirstChild 6" $ isLast e + + -- insertGoLeft from middle + do let ins = insertGoLeft fred bob + let Just a = right ins + assertBool "insertGoLeft 1" $ + getAttribute "name" (current ins) == Just "fred" + assertBool "insertGoLeft 2" $ + getAttribute "name" (current a) == Just "bob" + + -- insertGoLeft from end + do let ins = insertGoLeft fred alice + let Just a = right ins + assertBool "insertGoLeft 3" $ + getAttribute "name" (current ins) == Just "fred" + assertBool "insertGoLeft 4" $ + getAttribute "name" (current a) == Just "alice" + + -- insertGoRight from middle + do let ins = insertGoRight fred bob + let Just a = left ins + assertBool "insertGoRight 1" $ + getAttribute "name" (current ins) == Just "fred" + assertBool "insertGoRight 2" $ + getAttribute "name" (current a) == Just "bob" + + -- insertGoRight from end + do let ins = insertGoRight fred camille + let Just a = left ins + assertBool "insertGoRight 3" $ + getAttribute "name" (current ins) == Just "fred" + assertBool "insertGoRight 4" $ + getAttribute "name" (current a) == Just "camille" + + +cursorDeletion :: Assertion +cursorDeletion = do + let r = fromNode cursorTestTree + let Just alice = firstChild r + let Just bob = getChild 1 r + let Just camille = lastChild r + + -- removeLeft success + do let Just (n,del) = removeLeft bob + let [b,c] = siblings del + assertBool "removeLeft node1" $ getAttribute "name" n == Just "alice" + assertBool "removeLeft node2" $ getAttribute "name" b == Just "bob" + assertBool "removeLeft node3" $ getAttribute "name" c == Just "camille" + + -- removeLeft failure + do assertBool "removeLeft failure" $ isNothing (removeLeft alice) + + -- removeRight success + do let Just (n,del) = removeRight bob + let [a,b] = siblings del + assertBool "removeLeft node1" $ getAttribute "name" a == Just "alice" + assertBool "removeLeft node2" $ getAttribute "name" b == Just "bob" + assertBool "removeLeft node3" $ getAttribute "name" n == Just "camille" + + -- removeRight failure + do assertBool "removeLeft failure" $ isNothing (removeRight camille) + + -- removeGoLeft success + do let Just del = removeGoLeft bob + let Just c = right del + assertBool "removeGoLeft 1" $ + getAttribute "name" (current del) == Just "alice" + assertBool "removeGoLeft 2" $ + getAttribute "name" (current c) == Just "camille" + + -- removeGoLeft failure + do assertBool "removeGoLeft failure" $ isNothing (removeGoLeft alice) + + -- removeGoRight success + do let Just del = removeGoRight bob + let Just a = left del + assertBool "removeGoRight 1" $ + getAttribute "name" (current del) == Just "camille" + assertBool "removeGoRight 2" $ + getAttribute "name" (current a) == Just "alice" + + -- removeGoLeft failure + do assertBool "removeGoRight failure" $ isNothing (removeGoRight camille) + + -- removeGoUp success + do let Just del = removeGoUp bob + let [a,c] = childNodes (current del) + assertBool "removeGoUp 1" $ getAttribute "name" a == Just "alice" + assertBool "removeGoUp 2" $ getAttribute "name" c == Just "camille" + + -- removeGoUp failure + do assertBool "removeGoUp failure" $ isNothing (removeGoUp r) diff --git a/test/src/Text/XmlHtml/DocumentTests.hs b/test/src/Text/XmlHtml/DocumentTests.hs new file mode 100644 --- /dev/null +++ b/test/src/Text/XmlHtml/DocumentTests.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.XmlHtml.DocumentTests (documentTests) where + +import Data.Text () -- for string instance +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Node, Test) +import Text.XmlHtml +import Text.XmlHtml.TestCommon + + +------------------------------------------------------------------------------ +-- Tests of manipulating the Node tree and Document -------------------------- +------------------------------------------------------------------------------ + +documentTests :: [Test] +documentTests = [ + -- Exercise the (/=) operators; (==) is done plenty of places. + testIt "compareExternalIDs " $ compareExternalIDs, + testIt "compareInternalSubs " $ compareInternalSubs, + testIt "compareDoctypes " $ compareDoctypes, + testIt "compareNodes " $ compareNodes, + testIt "compareDocuments " $ compareDocuments, + testIt "compareEncodings " $ compareEncodings, + + -- Silly tests just to exercise the Show instances on types. + testCase "exerciseShows " $ exerciseShows, + + -- Exercise the accessors for Document and Node + testCase "docNodeAccessors " $ docNodeAccessors, + + testIt "isTextNodeYes " $ isTextNode someTextNode, + testIt "isTextNodeNo " $ not $ isTextNode someComment, + testIt "isTextNodeNo2 " $ not $ isTextNode someElement, + testIt "isCommentYes " $ isComment someComment, + testIt "isCommentNo " $ not $ isComment someTextNode, + testIt "isCommentNo2 " $ not $ isComment someElement, + testIt "isElementYes " $ isElement someElement, + testIt "isElementNo " $ not $ isElement someTextNode, + testIt "isElementNo2 " $ not $ isElement someComment, + testIt "tagNameElement " $ tagName someElement == Just "baz", + testIt "tagNameText " $ tagName someTextNode == Nothing, + testIt "tagNameComment " $ tagName someComment == Nothing, + testIt "getAttributePresent " $ getAttribute "fiz" someElement + == Just "buzz", + testIt "getAttributeMissing " $ getAttribute "baz" someElement + == Nothing, + testIt "getAttributeWrongType " $ getAttribute "fix" someTextNode + == Nothing, + testIt "hasAttributePresent " $ hasAttribute "fiz" someElement, + testIt "hasAttributeMissing " $ not $ hasAttribute "baz" someElement, + testIt "hasAttributeWrongType " $ not $ hasAttribute "fix" someTextNode, + testIt "setAttributeNew " $ setAttributeNew, + testIt "setAttributeReplace " $ setAttributeReplace, + testIt "setAttributeWrongType " $ setAttributeWrongType, + testIt "nestedNodeText " $ nestedNodeText, + testIt "childNodesElem " $ childNodesElem, + testIt "childNodesOther " $ childNodesOther, + testIt "childElemsTest " $ childElemsTest, + testIt "childElemsTagTest " $ childElemsTagTest, + testIt "childElemTagExists " $ childElemTagExists, + testIt "childElemTagNotExists " $ childElemTagNotExists, + testIt "childElemTagOther " $ childElemTagOther, + testIt "descNodesElem " $ descNodesElem, + testIt "descNodesOther " $ descNodesOther, + testIt "descElemsTest " $ descElemsTest, + testIt "descElemsTagTest " $ descElemsTagTest, + testIt "descElemTagExists " $ descElemTagExists, + testIt "descElemTagDFS " $ descElemTagDFS, + testIt "descElemTagNotExists " $ descElemTagNotExists, + testIt "descElemTagOther " $ descElemTagOther + ] + + +compareExternalIDs :: Bool +compareExternalIDs = Public "foo" "bar" /= System "bar" + +compareInternalSubs :: Bool +compareInternalSubs = InternalText "" /= NoInternalSubset + +compareDoctypes :: Bool +compareDoctypes = DocType "html" NoExternalID NoInternalSubset + /= DocType "foo" NoExternalID NoInternalSubset + +compareNodes :: Bool +compareNodes = TextNode "" /= Comment "" + +compareDocuments :: Bool +compareDocuments = XmlDocument UTF8 Nothing [] /= HtmlDocument UTF8 Nothing [] + +compareEncodings :: Bool +compareEncodings = UTF8 /= UTF16BE + +exerciseShows :: Assertion +exerciseShows = do + assertBool "1" $ length (showList [NoExternalID] "") > 0 + assertBool "2" $ length (showList [NoInternalSubset] "") > 0 + assertBool "3" $ length (showList [DocType "foo" NoExternalID NoInternalSubset] "") > 0 + assertBool "4" $ length (showList [TextNode ""] "") > 0 + assertBool "5" $ length (showList [XmlDocument UTF8 Nothing []] "") > 0 + assertBool "6" $ length (showList [UTF8] "") > 0 + +docNodeAccessors :: Assertion +docNodeAccessors = do + let hdoc = HtmlDocument UTF8 Nothing [] + assertEqual "html enc" (docEncoding hdoc) UTF8 + assertEqual "html type" (docType hdoc) Nothing + assertEqual "html nodes" (docContent hdoc) [] + + let xdoc = XmlDocument UTF8 Nothing [] + assertEqual "xml enc" (docEncoding xdoc) UTF8 + assertEqual "xml type" (docType xdoc) Nothing + assertEqual "xml nodes" (docContent xdoc) [] + + let elm = Element "foo" [] [] + let txt = TextNode "" + let cmt = Comment "" + assertEqual "elm tag" (elementTag elm) "foo" + assertEqual "elm attr" (elementAttrs elm) [] + assertEqual "elm child" (elementChildren elm) [] + assertBool "txt tag" $ isBottom (elementTag txt) + assertBool "txt attr" $ isBottom (elementAttrs txt) + assertBool "txt child" $ isBottom (elementChildren txt) + assertBool "cmt tag" $ isBottom (elementTag cmt) + assertBool "cmt attr" $ isBottom (elementAttrs cmt) + assertBool "cmt child" $ isBottom (elementChildren cmt) + + +someTextNode :: Node +someTextNode = TextNode "foo" + +someComment :: Node +someComment = Comment "bar" + +someElement :: Node +someElement = Element "baz" [("fiz","buzz")] [TextNode "content"] + +someTree :: Node +someTree = Element "department" [("code", "A17")] [ + Element "employee" [("name", "bob")] [ + Comment "My best friend", + Element "address" [] [ + TextNode "123 My Road" + ] + ], + Element "employee" [("name", "alice")] [ + Element "address" [] [ + TextNode "124 My Road" + ], + Element "phone" [] [ + TextNode "555-1234" + ] + ] + ] + +setAttributeNew :: Bool +setAttributeNew = + let e = setAttribute "flo" "friz" someElement + in length (elementAttrs e) == 2 + && getAttribute "fiz" e == Just "buzz" + && getAttribute "flo" e == Just "friz" + +setAttributeReplace :: Bool +setAttributeReplace = + let e = setAttribute "fiz" "bat" someElement + in length (elementAttrs e) == 1 + && getAttribute "fiz" e == Just "bat" + +setAttributeWrongType :: Bool +setAttributeWrongType = + setAttribute "fuss" "plus" someTextNode == someTextNode + && setAttribute "fuss" "plus" someComment == someComment + +nestedNodeText :: Bool +nestedNodeText = nodeText someTree == "123 My Road124 My Road555-1234" + +childNodesElem :: Bool +childNodesElem = length (childNodes n) == 3 + where n = Element "foo" [] [ TextNode "bar", + Comment "baz", + Element "bat" [] [] ] + +childNodesOther :: Bool +childNodesOther = childNodes (TextNode "foo") == [] + && childNodes (Comment "bar") == [] + +childElemsTest :: Bool +childElemsTest = length (childElements n) == 1 + where n = Element "foo" [] [ TextNode "bar", + Comment "baz", + Element "bat" [] [] ] + +childElemsTagTest :: Bool +childElemsTagTest = length (childElementsTag "good" n) == 2 + where n = Element "parent" [] [ + Element "good" [] [], + TextNode "foo", + Comment "bar", + Element "bad" [] [], + Element "good" [] [], + Element "bad" [] [] + ] + +childElemTagExists :: Bool +childElemTagExists = childElementTag "b" n == Just (Element "b" [] []) + where n = Element "parent" [] [ + Element "a" [] [], + Element "b" [] [], + Element "c" [] [] + ] + +childElemTagNotExists :: Bool +childElemTagNotExists = childElementTag "b" n == Nothing + where n = Element "parent" [] [ + Element "a" [] [], + Element "c" [] [] + ] + +childElemTagOther :: Bool +childElemTagOther = childElementTag "b" n == Nothing + where n = TextNode "" + + +descNodesElem :: Bool +descNodesElem = length (descendantNodes n) == 3 + where n = Element "foo" [] [ TextNode "bar", + Element "bat" [] [ Comment "baz" ] ] + +descNodesOther :: Bool +descNodesOther = descendantNodes (TextNode "foo") == [] + && descendantNodes (Comment "bar") == [] + +descElemsTest :: Bool +descElemsTest = length (descendantElements n) == 1 + where n = Element "foo" [] [ TextNode "bar", + Element "bat" [] [ Comment "baz" ] ] + +descElemsTagTest :: Bool +descElemsTagTest = length (descendantElementsTag "good" n) == 2 + where n = Element "parent" [] [ + TextNode "foo", + Element "good" [] [], + Comment "bar", + Element "parent" [] [ Element "good" [] [] ], + Element "bad" [] [] + ] + +descElemTagExists :: Bool +descElemTagExists = descendantElementTag "b" n == Just (Element "b" [] []) + where n = Element "parent" [] [ + Element "a" [] [ Element "b" [] [] ], + Element "c" [] [] + ] + +descElemTagDFS :: Bool +descElemTagDFS = descendantElementTag "b" n == Just (Element "b" [] []) + where n = Element "parent" [] [ + Element "a" [] [ Element "b" [] [] ], + Element "b" [("wrong", "")] [], + Element "c" [] [] + ] + +descElemTagNotExists :: Bool +descElemTagNotExists = descendantElementTag "b" n == Nothing + where n = Element "parent" [] [ + Element "a" [] [], + Element "c" [] [ Element "d" [] [] ] + ] + +descElemTagOther :: Bool +descElemTagOther = descendantElementTag "b" n == Nothing + where n = TextNode "" + diff --git a/test/src/Text/XmlHtml/OASISTest.hs b/test/src/Text/XmlHtml/OASISTest.hs new file mode 100644 --- /dev/null +++ b/test/src/Text/XmlHtml/OASISTest.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.XmlHtml.OASISTest (testsOASIS) where + +import Blaze.ByteString.Builder +import Control.Applicative +import Control.Monad +import qualified Data.ByteString as B +import Data.Maybe +import qualified Data.Text as T +import System.Directory +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, Node) +import Text.XmlHtml + +------------------------------------------------------------------------------ +-- | Runs the OASIS XML conformance test suite. The test cases sit in +-- directories inside of @test/resources@. This test reads them, parses them, +-- and ensures that they behave as expected: +-- +-- * If there is a file in the same directory named /filename/@.correct@ +-- or /filename/@.incorrect@, the parsing is expected to either succeed +-- or fail, as indicated. Otherwise, the remaining cases apply. +-- +-- * For those tests marked @not-wf@, the test expects an error message. +-- +-- * For tests marked @valid@ or @invalid@ (there is no distinction since +-- @xmlhtml@ is not a validating parser), the test expects a successful +-- parse, but does not verify the parse result. +-- +-- For tests that should succeed as XML but not HTML, or vice versa, files +-- can be named /filename/@.xml.correct@, and so on (all 4 combinations). + +testsOASIS :: [Test] +testsOASIS = [ + testCase "xmlhtml/ibm-not-wf " $ oasisP "ibm/ibm_oasis_not-wf.xml", + testCase "xmlhtml/ibm-invalid " $ oasisP "ibm/ibm_oasis_invalid.xml", + testCase "xmlhtml/ibm-valid " $ oasisP "ibm/ibm_oasis_valid.xml", + testCase "xmlhtml/oasis " $ oasisP "oasis/oasis.xml", + testCase "xmlhtml/r-ibm-not-wf " $ oasisR "ibm/ibm_oasis_not-wf.xml", + testCase "xmlhtml/r-ibm-invalid " $ oasisR "ibm/ibm_oasis_invalid.xml", + testCase "xmlhtml/r-ibm-valid " $ oasisR "ibm/ibm_oasis_valid.xml", + testCase "xmlhtml/r-oasis " $ oasisR "oasis/oasis.xml", + testCase "xmlhtml/h-ibm-not-wf " $ oasisHP "ibm/ibm_oasis_not-wf.xml", + testCase "xmlhtml/h-ibm-invalid " $ oasisHP "ibm/ibm_oasis_invalid.xml", + testCase "xmlhtml/h-ibm-valid " $ oasisHP "ibm/ibm_oasis_valid.xml", + testCase "xmlhtml/h-oasis " $ oasisHP "oasis/oasis.xml", + testCase "xmlhtml/hr-ibm-not-wf " $ oasisHR "ibm/ibm_oasis_not-wf.xml", + testCase "xmlhtml/hr-ibm-invalid " $ oasisHR "ibm/ibm_oasis_invalid.xml", + testCase "xmlhtml/hr-ibm-valid " $ oasisHR "ibm/ibm_oasis_valid.xml", + testCase "xmlhtml/hr-oasis " $ oasisHR "oasis/oasis.xml" + ] + + +oasisP :: String -> Assertion +oasisP name = do + tests <- getOASIS ".xml" name + forM_ tests $ \(fn, ty) -> case ty of + True -> oasisWF fn + False -> oasisNotWF fn + + +oasisR :: String -> Assertion +oasisR name = do + tests <- getOASIS ".xml" name + forM_ tests $ \(fn, ty) -> case ty of + True -> oasisRerender fn + False -> return () + + +oasisHP :: String -> Assertion +oasisHP name = do + tests <- getOASIS ".html" name + forM_ tests $ \(fn, ty) -> case ty of + True -> hOasisWF fn + False -> hOasisNotWF fn + + +oasisHR :: String -> Assertion +oasisHR name = do + tests <- getOASIS ".html" name + forM_ tests $ \(fn, ty) -> case ty of + True -> hOasisRerender fn + False -> return () + + +getOASIS :: String -> String -> IO [(String, Bool)] +getOASIS sub name = do + testListSrc <- B.readFile ("test/resources/" ++ name) + let Right (XmlDocument _ _ ns) = parseXML name testListSrc + let Just c = listToMaybe (filter isElement ns) + oasisTestCases sub name c + + +oasisTestCases :: String -> String -> Node -> IO [(String, Bool)] +oasisTestCases sub name n = do + fmap concat $ forM (childElements n) $ \t -> case tagName t of + Just "TESTCASES" -> oasisTestCases sub name t + Just "TEST" -> oasisTest sub name t + _ -> error (show t) + + +oasisTest :: String -> String -> Node -> IO [(String, Bool)] +oasisTest sub name t = do + let fn = file $ fromJust $ getAttribute "URI" t + fe <- doesFileExist fn + ce <- (||) <$> doesFileExist (fn ++ ".correct") + <*> doesFileExist (fn ++ sub ++ ".correct") + ie <- (||) <$> doesFileExist (fn ++ ".incorrect") + <*> doesFileExist (fn ++ sub ++ ".incorrect") + let ty = getAttribute "TYPE" t + if fe then case () of + () | ce -> return [(fn, True)] + | ie -> return [(fn, False)] + | ty == Just "not-wf" -> return [(fn, False)] + | ty == Just "invalid" -> return [(fn, True)] + | ty == Just "valid" -> return [(fn, True)] + | otherwise -> return [(fn, True)] + else return [] + where + file f = "test/resources/" ++ toLastSlash name ++ T.unpack f + toLastSlash s = snd (go s) + where go [] = (False, []) + go (c:cs) = let (found, ccs) = go cs + in if found then (True, c:ccs) + else if c == '/' then (True, "/") + else (False, c:cs) + + +oasisNotWF :: String -> Assertion +oasisNotWF name = do + src <- B.readFile name + assertBool ("not-wf parse " ++ name) $ isLeft (parseXML name src) + where + isLeft (Left _) = True + isLeft _ = False + + +oasisWF :: String -> Assertion +oasisWF name = do + src <- B.readFile name + assertBool ("wf parse " ++ name) $ isRight (parseXML name src) + where + isRight (Right _) = True + isRight _ = False + + +oasisRerender :: String -> Assertion +oasisRerender name = do + src <- B.readFile name + let Right d = parseXML "" src + let src2 = toByteString (render d) + let Right d2 = parseXML "" src2 + assertEqual ("rerender " ++ name) d d2 + + +hOasisNotWF :: String -> Assertion +hOasisNotWF name = do + src <- B.readFile name + assertBool ("not-wf parse " ++ name) $ isLeft (parseHTML name src) + where + isLeft (Left _) = True + isLeft _ = False + + +hOasisWF :: String -> Assertion +hOasisWF name = do + src <- B.readFile name + assertBool ("wf parse " ++ name) $ isRight (parseHTML name src) + where + isRight (Right _) = True + isRight _ = False + + +hOasisRerender :: String -> Assertion +hOasisRerender name = do + src <- B.readFile name + let Right d = parseHTML "" src + let src2 = toByteString (render d) + let Right d2 = parseHTML "" src2 + assertEqual ("rerender " ++ name) d d2 + diff --git a/test/src/Text/XmlHtml/TestCommon.hs b/test/src/Text/XmlHtml/TestCommon.hs new file mode 100644 --- /dev/null +++ b/test/src/Text/XmlHtml/TestCommon.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.XmlHtml.TestCommon where + +import Control.Exception as E +import System.IO.Unsafe +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, Node) + +------------------------------------------------------------------------------ +-- | Tests a simple Bool property. +testIt :: TestName -> Bool -> Test +testIt name b = testCase name $ assertBool name b + +------------------------------------------------------------------------------ +-- Code adapted from ChasingBottoms. +-- +-- Adding an actual dependency isn't possible because Cabal refuses to build +-- the package due to version conflicts. +-- +-- isBottom is impossible to write, but very useful! So we defy the +-- impossible, and write it anyway. +isBottom :: a -> Bool +isBottom a = unsafePerformIO $ + (E.evaluate a >> return False) `E.catches` [ + E.Handler $ \ (_ :: PatternMatchFail) -> return True, + E.Handler $ \ (_ :: ErrorCall) -> return True, + E.Handler $ \ (_ :: NoMethodError) -> return True, + E.Handler $ \ (_ :: RecConError) -> return True, + E.Handler $ \ (_ :: RecUpdError) -> return True, + E.Handler $ \ (_ :: RecSelError) -> return True + ] + +------------------------------------------------------------------------------ +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) + diff --git a/test/src/Text/XmlHtml/Tests.hs b/test/src/Text/XmlHtml/Tests.hs new file mode 100644 --- /dev/null +++ b/test/src/Text/XmlHtml/Tests.hs @@ -0,0 +1,963 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.XmlHtml.Tests (tests) where + +import Blaze.ByteString.Builder +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Monoid +import Data.String +import Data.Text () -- for string instance +import qualified Data.Text.Encoding as T +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, Node) +import Text.Blaze +import Text.Blaze.Html +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Text.Blaze.Internal as H +import Text.Blaze.Renderer.XmlHtml +import Text.XmlHtml +import Text.XmlHtml.CursorTests +import Text.XmlHtml.DocumentTests +import Text.XmlHtml.TestCommon +import Text.XmlHtml.OASISTest + + +------------------------------------------------------------------------------ +-- The master list of tests to run. ------------------------------------------ +------------------------------------------------------------------------------ + +tests :: [Test] +tests = xmlParsingTests + ++ htmlXMLParsingTests + ++ htmlParsingQuirkTests + ++ xmlRenderingTests + ++ htmlXMLRenderingTests + ++ htmlRenderingQuirkTests + ++ documentTests + ++ cursorTests + ++ blazeRenderTests + ++ testsOASIS + + +------------------------------------------------------------------------------ +-- XML Parsing Tests --------------------------------------------------------- +------------------------------------------------------------------------------ + +xmlParsingTests :: [Test] +xmlParsingTests = [ + testCase "byteOrderMark " byteOrderMark, + testIt "emptyDocument " emptyDocument, + testIt "publicDocType " publicDocType, + testIt "systemDocType " systemDocType, + testIt "emptyDocType " emptyDocType, + testCase "dtdInternalScan " dtdInternalScan, + testIt "textOnly " textOnly, + testIt "textWithRefs " textWithRefs, + testIt "untermRef " untermRef, + testIt "textWithCDATA " textWithCDATA, + testIt "cdataOnly " cdataOnly, + testIt "commentOnly " commentOnly, + testIt "emptyElement " emptyElement, + testIt "emptyElement2 " emptyElement2, + testIt "elemWithText " elemWithText, + testIt "xmlDeclXML " xmlDeclXML, + testIt "procInst " procInst, + testIt "badDoctype1 " badDoctype1, + testIt "badDoctype2 " badDoctype2, + testIt "badDoctype3 " badDoctype3, + testIt "badDoctype4 " badDoctype4, + testIt "badDoctype5 " badDoctype5, + testCase "tagNames " tagNames + ] + +byteOrderMark :: Assertion +byteOrderMark = do + assertEqual "BOM UTF16BE" (Right $ XmlDocument UTF16BE Nothing []) + (parseXML "" $ T.encodeUtf16BE "\xFEFF") + assertEqual "BOM UTF16LE" (Right $ XmlDocument UTF16LE Nothing []) + (parseXML "" $ T.encodeUtf16LE "\xFEFF") + assertEqual "BOM UTF8" (Right $ XmlDocument UTF8 Nothing []) + (parseXML "" $ T.encodeUtf8 "\xFEFF") + assertEqual "BOM None" (Right $ XmlDocument UTF8 Nothing []) + (parseXML "" $ T.encodeUtf8 "") + +emptyDocument :: Bool +emptyDocument = parseXML "" "" + == Right (XmlDocument UTF8 Nothing []) + +publicDocType :: Bool +publicDocType = parseXML "" "" + == Right (XmlDocument UTF8 (Just (DocType "tag" (Public "foo" "bar") NoInternalSubset)) []) + +systemDocType :: Bool +systemDocType = parseXML "" "" + == Right (XmlDocument UTF8 (Just (DocType "tag" (System "foo") NoInternalSubset)) []) + +emptyDocType :: Bool +emptyDocType = parseXML "" "" + == Right (XmlDocument UTF8 (Just (DocType "tag" NoExternalID NoInternalSubset)) []) + +dtdInternalScan :: Assertion +dtdInternalScan = do + assertEqual "empty" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[]" ))) [])) + assertBool "bad brackets" (isLeft $ parseXML "" "") + assertEqual "quoted" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[\"]\"]" ))) [])) + assertBool "bad quote" (isLeft $ parseXML "" "") + assertEqual "nested brackets" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[[[]]]" ))) [])) + assertEqual "part comment 1" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[<]" ))) [])) + assertEqual "part comment 2" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[[<]]" ))) [])) + assertEqual "part comment 3" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[<[]]" ))) [])) + assertEqual "part comment 4" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[[") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[]>") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[]" ))) [])) + assertEqual "docint 1" (parseXML "" "]>") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[<''<\"\"]" ))) [])) + assertEqual "docint2" (parseXML "" "") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[") + (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText + "[]>") + +textOnly :: Bool +textOnly = parseXML "" "sldhfsklj''a's s" + == Right (XmlDocument UTF8 Nothing [TextNode "sldhfsklj''a's s"]) + +textWithRefs :: Bool +textWithRefs = parseXML "" "This is Bob's sled" + == Right (XmlDocument UTF8 Nothing [TextNode "This is Bob's sled"]) + +untermRef :: Bool +untermRef = isLeft (parseXML "" "j") + +textWithCDATA :: Bool +textWithCDATA = parseXML "" "Testing c]data]]>" + == Right (XmlDocument UTF8 Nothing [TextNode "Testing with c]data"]) + +cdataOnly :: Bool +cdataOnly = parseXML "" "" + == Right (XmlDocument UTF8 Nothing [TextNode " Testing a \"comment -->" + == Right (XmlDocument UTF8 Nothing [Comment " this a \"comment "]) + +emptyElement :: Bool +emptyElement = parseXML "" "" + == Right (XmlDocument UTF8 Nothing [Element "myElement" [] []]) + +emptyElement2 :: Bool +emptyElement2 = parseXML "" "" + == Right (XmlDocument UTF8 Nothing [Element "myElement" [] []]) + +elemWithText :: Bool +elemWithText = parseXML "" "text" + == Right (XmlDocument UTF8 Nothing [Element "myElement" [] [TextNode "text"]]) + +xmlDeclXML :: Bool +xmlDeclXML = parseXML "" "" + == Right (XmlDocument UTF8 Nothing []) + +procInst :: Bool +procInst = parseXML "" " parsed!?>" + == Right (XmlDocument UTF8 Nothing []) + +badDoctype1 :: Bool +badDoctype1 = isLeft $ parseXML "" "" + +badDoctype2 :: Bool +badDoctype2 = isLeft $ parseXML "" "" + +badDoctype3 :: Bool +badDoctype3 = isLeft $ parseXML "" "" + +badDoctype4 :: Bool +badDoctype4 = isLeft $ parseXML "" "" + +badDoctype5 :: Bool +badDoctype5 = isLeft $ parseXML "" ("") + +tagNames :: Assertion +tagNames = do + assertBool "tag name 0" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "") + assertBool "tag name 1" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\xc0\&foo />") + assertBool "tag name 2" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\xd8\&foo />") + assertBool "tag name 3" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\xf8\&foo />") + assertBool "tag name 4" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x370\&foo />") + assertBool "tag name 5" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x37f\&foo />") + assertBool "tag name 6" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x200c\&foo />") + assertBool "tag name 7" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x2070\&foo />") + assertBool "tag name 8" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x2c00\&foo />") + assertBool "tag name 9" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x3001\&foo />") + assertBool "tag name 10" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\xf900\&foo />") + assertBool "tag name 11" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\xfdf0\&foo />") + assertBool "tag name 12" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "<\x10000\&foo />") + assertBool "tag name 13" $ id $ + isLeft $ parseXML "" (T.encodeUtf8 "<\xd7\&foo />") + assertBool "tag name 14" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "") + assertBool "tag name 15" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "") + assertBool "tag name 16" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "") + assertBool "tag name 17" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "") + assertBool "tag name 18" $ not $ + isLeft $ parseXML "" (T.encodeUtf8 "") + assertBool "tag name 19" $ id $ + isLeft $ parseXML "" (T.encodeUtf8 "") + + +------------------------------------------------------------------------------ +-- HTML Repetitions of XML Parsing Tests ------------------------------------- +------------------------------------------------------------------------------ + +htmlXMLParsingTests :: [Test] +htmlXMLParsingTests = [ + testIt "emptyDocumentHTML " emptyDocumentHTML, + testIt "publicDocTypeHTML " publicDocTypeHTML, + testIt "systemDocTypeHTML " systemDocTypeHTML, + testIt "emptyDocTypeHTML " emptyDocTypeHTML, + testIt "textOnlyHTML " textOnlyHTML, + testIt "textWithRefsHTML " textWithRefsHTML, + testIt "textWithCDataHTML " textWithCDataHTML, + testIt "cdataOnlyHTML " cdataOnlyHTML, + testIt "commentOnlyHTML " commentOnlyHTML, + testIt "emptyElementHTML " emptyElementHTML, + testIt "emptyElement2HTML " emptyElement2HTML, + testIt "elemWithTextHTML " elemWithTextHTML, + testIt "xmlDeclHTML " xmlDeclHTML, + testIt "procInstHTML " procInstHTML, + testIt "badDoctype1HTML " badDoctype1HTML, + testIt "badDoctype2HTML " badDoctype2HTML, + testIt "badDoctype3HTML " badDoctype3HTML, + testIt "badDoctype4HTML " badDoctype4HTML, + testIt "badDoctype5HTML " badDoctype5HTML + ] + +emptyDocumentHTML :: Bool +emptyDocumentHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing []) + +publicDocTypeHTML :: Bool +publicDocTypeHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 (Just (DocType "tag" (Public "foo" "bar") NoInternalSubset)) []) + +systemDocTypeHTML :: Bool +systemDocTypeHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 (Just (DocType "tag" (System "foo") NoInternalSubset)) []) + +emptyDocTypeHTML :: Bool +emptyDocTypeHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 (Just (DocType "tag" NoExternalID NoInternalSubset)) []) + +textOnlyHTML :: Bool +textOnlyHTML = parseHTML "" "sldhfsklj''a's s" + == Right (HtmlDocument UTF8 Nothing [TextNode "sldhfsklj''a's s"]) + +textWithRefsHTML :: Bool +textWithRefsHTML = parseHTML "" "This is Bob's sled" + == Right (HtmlDocument UTF8 Nothing [TextNode "This is Bob's sled"]) + +textWithCDataHTML :: Bool +textWithCDataHTML = parseHTML "" "Testing c]data]]>" + == Right (HtmlDocument UTF8 Nothing [TextNode "Testing with c]data"]) + +cdataOnlyHTML :: Bool +cdataOnlyHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [TextNode " Testing a \"comment -->" + == Right (HtmlDocument UTF8 Nothing [Comment " this a \"comment "]) + +emptyElementHTML :: Bool +emptyElementHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "myElement" [] []]) + +emptyElement2HTML :: Bool +emptyElement2HTML = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "myElement" [] []]) + +elemWithTextHTML :: Bool +elemWithTextHTML = parseHTML "" "text" + == Right (HtmlDocument UTF8 Nothing [Element "myElement" [] [TextNode "text"]]) + +xmlDeclHTML :: Bool +xmlDeclHTML = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing []) + +procInstHTML :: Bool +procInstHTML = parseHTML "" " parsed!?>" + == Right (HtmlDocument UTF8 Nothing []) + +badDoctype1HTML :: Bool +badDoctype1HTML = isLeft $ parseHTML "" "" + +badDoctype2HTML :: Bool +badDoctype2HTML = isLeft $ parseHTML "" "" + +badDoctype3HTML :: Bool +badDoctype3HTML = isLeft $ parseHTML "" "" + +badDoctype4HTML :: Bool +badDoctype4HTML = isLeft $ parseHTML "" "" + +badDoctype5HTML :: Bool +badDoctype5HTML = isLeft $ parseHTML "" ("") + + +------------------------------------------------------------------------------ +-- HTML Quirks Parsing Tests ------------------------------------------------- +------------------------------------------------------------------------------ + +htmlParsingQuirkTests :: [Test] +htmlParsingQuirkTests = [ + testIt "voidElem " voidElem, + testIt "caseInsDoctype1 " caseInsDoctype1, + testIt "caseInsDoctype2 " caseInsDoctype2, + testIt "voidEmptyElem " voidEmptyElem, + testIt "rawTextElem " rawTextElem, + testIt "endTagCase " endTagCase, + testIt "hexEntityCap " hexEntityCap, + testIt "laxAttrName " laxAttrName, + testCase "badAttrName " badAttrName, + testIt "emptyAttr " emptyAttr, + testIt "emptyAttr2 " emptyAttr2, + testIt "unquotedAttr " unquotedAttr, + testIt "laxAttrVal " laxAttrVal, + testIt "ampersandInText " ampersandInText, + testIt "omitOptionalEnds " omitOptionalEnds, + testIt "omitEndHEAD " omitEndHEAD, + testIt "omitEndLI " omitEndLI, + testIt "omitEndDT " omitEndDT, + testIt "omitEndDD " omitEndDD, + testIt "omitEndP " omitEndP, + testIt "omitEndRT " omitEndRT, + testIt "omitEndRP " omitEndRP, + testIt "omitEndOPTGRP " omitEndOPTGRP, + testIt "omitEndOPTION " omitEndOPTION, + testIt "omitEndCOLGRP " omitEndCOLGRP, + testIt "omitEndTHEAD " omitEndTHEAD, + testIt "omitEndTBODY " omitEndTBODY, + testIt "omitEndTFOOT " omitEndTFOOT, + testIt "omitEndTR " omitEndTR, + testIt "omitEndTD " omitEndTD, + testIt "omitEndTH " omitEndTH, + testIt "testNewRefs " testNewRefs, + testIt "errorImplicitClose " errorImplicitClose, + testIt "weirdScriptThing " weirdScriptThing + ] + +caseInsDoctype1 :: Bool +caseInsDoctype1 = parseHTML "" "" + == Right (HtmlDocument UTF8 (Just (DocType "html" (System "foo") NoInternalSubset)) []) + +caseInsDoctype2 :: Bool +caseInsDoctype2 = parseHTML "" "" + == Right (HtmlDocument UTF8 (Just (DocType "html" (Public "foo" "bar") NoInternalSubset)) []) + +voidElem :: Bool +voidElem = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "img" [] []]) + +voidEmptyElem :: Bool +voidEmptyElem = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "img" [] []]) + +rawTextElem :: Bool +rawTextElem = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "script" [("type", "text/javascript")] [ + TextNode "Thistest&"] + ]) + +endTagCase :: Bool +endTagCase = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "testing" [] []]) + +hexEntityCap :: Bool +hexEntityCap = parseHTML "" "j" + == Right (HtmlDocument UTF8 Nothing [TextNode "\x6a"]) + +laxAttrName :: Bool +laxAttrName = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "test" [("val") + assertBool "attr name 1" $ + isLeft $ parseHTML "" (T.encodeUtf8 "") + assertBool "attr name 2" $ + isLeft $ parseHTML "" (T.encodeUtf8 "") + assertBool "attr name 3" $ + isLeft $ parseHTML "" (T.encodeUtf8 "") + assertBool "attr name 4" $ + isLeft $ parseHTML "" (T.encodeUtf8 "") + +emptyAttr :: Bool +emptyAttr = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "test" [("attr", "")] []]) + +emptyAttr2 :: Bool +emptyAttr2 = parseHTML "" "
" + == Right (HtmlDocument UTF8 Nothing [Element "div" [("itemscope", ""), ("itemtype", "type")] []]) + +unquotedAttr :: Bool +unquotedAttr = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "test" [("attr", "you&me")] []]) + +laxAttrVal :: Bool +laxAttrVal = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "test" [("attr", "a & d < b & c")] []]) + +ampersandInText :: Bool +ampersandInText = parseHTML "" "j" + == Right (HtmlDocument UTF8 Nothing [TextNode "j"]) + +omitOptionalEnds :: Bool +omitOptionalEnds = parseHTML "" "

" + == Right (HtmlDocument UTF8 Nothing [Element "html" [] [ + Element "body" [] [ Element "p" [] []]]]) + +omitEndHEAD :: Bool +omitEndHEAD = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "head" [] [], Element "body" [] []]) + +omitEndLI :: Bool +omitEndLI = parseHTML "" "

  • " + == Right (HtmlDocument UTF8 Nothing [Element "li" [] [], Element "li" [] []]) + +omitEndDT :: Bool +omitEndDT = parseHTML "" "
    " + == Right (HtmlDocument UTF8 Nothing [Element "dt" [] [], Element "dd" [] []]) + +omitEndDD :: Bool +omitEndDD = parseHTML "" "
    " + == Right (HtmlDocument UTF8 Nothing [Element "dd" [] [], Element "dt" [] []]) + +omitEndP :: Bool +omitEndP = parseHTML "" "

    " + == Right (HtmlDocument UTF8 Nothing [Element "p" [] [], Element "h1" [] []]) + +omitEndRT :: Bool +omitEndRT = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "rt" [] [], Element "rp" [] []]) + +omitEndRP :: Bool +omitEndRP = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "rp" [] [], Element "rt" [] []]) + +omitEndOPTGRP :: Bool +omitEndOPTGRP = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "optgroup" [] [], Element "optgroup" [] []]) + +omitEndOPTION :: Bool +omitEndOPTION = parseHTML "" "');" + ] + ] + ]) + +------------------------------------------------------------------------------ +-- XML Rendering Tests ------------------------------------------------------- +------------------------------------------------------------------------------ + +xmlRenderingTests :: [Test] +xmlRenderingTests = [ + testIt "renderByteOrderMark " renderByteOrderMark, + testIt "renderByteOrderMarkLE " renderByteOrderMarkLE, + testIt "singleQuoteInSysID " singleQuoteInSysID, + testIt "doubleQuoteInSysID " doubleQuoteInSysID, + testIt "bothQuotesInSysID " bothQuotesInSysID, + testIt "doubleQuoteInPubID " doubleQuoteInPubID, + testIt "doubleDashInComment " doubleDashInComment, + testIt "trailingDashInComment " trailingDashInComment, + testIt "renderEmptyText " renderEmptyText, + testIt "singleQuoteInAttr " singleQuoteInAttr, + testIt "doubleQuoteInAttr " doubleQuoteInAttr, + testIt "bothQuotesInAttr " bothQuotesInAttr + ] + +renderByteOrderMark :: Bool +renderByteOrderMark = + toByteString (render (XmlDocument UTF16BE Nothing [])) + == T.encodeUtf16BE "\xFEFF\n" + +renderByteOrderMarkLE :: Bool +renderByteOrderMarkLE = + toByteString (render (XmlDocument UTF16LE Nothing [])) + == T.encodeUtf16LE "\xFEFF\n" + +-- (Appears at the beginning of all XML output) +utf8Decl :: ByteString +utf8Decl = T.encodeUtf8 "\n" + +singleQuoteInSysID :: Bool +singleQuoteInSysID = + toByteString (render (XmlDocument UTF8 + (Just (DocType "html" (System "test\'ing") NoInternalSubset)) + [])) + == utf8Decl `B.append` "\n" + +doubleQuoteInSysID :: Bool +doubleQuoteInSysID = + toByteString (render (XmlDocument UTF8 + (Just (DocType "html" (System "test\"ing") NoInternalSubset)) + [])) + == utf8Decl `B.append` "\n" + +bothQuotesInSysID :: Bool +bothQuotesInSysID = isBottom $ + toByteString (render (XmlDocument UTF8 + (Just (DocType "html" (System "test\"\'ing") NoInternalSubset)) + [])) + +doubleQuoteInPubID :: Bool +doubleQuoteInPubID = isBottom $ + toByteString (render (XmlDocument UTF8 + (Just (DocType "html" (Public "test\"ing" "foo") NoInternalSubset)) + [])) + +doubleDashInComment :: Bool +doubleDashInComment = isBottom $ + toByteString (render (XmlDocument UTF8 Nothing [ + Comment "test--ing" + ])) + +trailingDashInComment :: Bool +trailingDashInComment = isBottom $ + toByteString (render (XmlDocument UTF8 Nothing [ + Comment "testing-" + ])) + +renderEmptyText :: Bool +renderEmptyText = + toByteString (render (XmlDocument UTF8 Nothing [ + TextNode "" + ])) + == utf8Decl + +singleQuoteInAttr :: Bool +singleQuoteInAttr = + toByteString (render (XmlDocument UTF8 Nothing [ + Element "foo" [("bar", "test\'ing")] [] + ])) + == utf8Decl `B.append` "" + +doubleQuoteInAttr :: Bool +doubleQuoteInAttr = + toByteString (render (XmlDocument UTF8 Nothing [ + Element "foo" [("bar", "test\"ing")] [] + ])) + == utf8Decl `B.append` "" + +bothQuotesInAttr :: Bool +bothQuotesInAttr = + toByteString (render (XmlDocument UTF8 Nothing [ + Element "foo" [("bar", "test\'\"ing")] [] + ])) + == utf8Decl `B.append` "" + + +------------------------------------------------------------------------------ +-- HTML Repeats of XML Rendering Tests --------------------------------------- +------------------------------------------------------------------------------ + +htmlXMLRenderingTests :: [Test] +htmlXMLRenderingTests = [ + testIt "hRenderByteOrderMark " hRenderByteOrderMark, + testIt "hSingleQuoteInSysID " hSingleQuoteInSysID, + testIt "hDoubleQuoteInSysID " hDoubleQuoteInSysID, + testIt "hBothQuotesInSysID " hBothQuotesInSysID, + testIt "hDoubleQuoteInPubID " hDoubleQuoteInPubID, + testIt "hDoubleDashInComment " hDoubleDashInComment, + testIt "hTrailingDashInComment " hTrailingDashInComment, + testIt "hRenderEmptyText " hRenderEmptyText, + testIt "hSingleQuoteInAttr " hSingleQuoteInAttr, + testIt "hDoubleQuoteInAttr " hDoubleQuoteInAttr, + testIt "hBothQuotesInAttr " hBothQuotesInAttr + ] + +hRenderByteOrderMark :: Bool +hRenderByteOrderMark = + toByteString (render (HtmlDocument UTF16BE Nothing [])) + == "\xFE\xFF" + +hSingleQuoteInSysID :: Bool +hSingleQuoteInSysID = + toByteString (render (HtmlDocument UTF8 + (Just (DocType "html" (System "test\'ing") NoInternalSubset)) + [])) + == "\n" + +hDoubleQuoteInSysID :: Bool +hDoubleQuoteInSysID = + toByteString (render (HtmlDocument UTF8 + (Just (DocType "html" (System "test\"ing") NoInternalSubset)) + [])) + == "\n" + +hBothQuotesInSysID :: Bool +hBothQuotesInSysID = isBottom $ + toByteString (render (HtmlDocument UTF8 + (Just (DocType "html" (System "test\"\'ing") NoInternalSubset)) + [])) + +hDoubleQuoteInPubID :: Bool +hDoubleQuoteInPubID = isBottom $ + toByteString (render (HtmlDocument UTF8 + (Just (DocType "html" (Public "test\"ing" "foo") NoInternalSubset)) + [])) + +hDoubleDashInComment :: Bool +hDoubleDashInComment = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Comment "test--ing" + ])) + +hTrailingDashInComment :: Bool +hTrailingDashInComment = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Comment "testing-" + ])) + +hRenderEmptyText :: Bool +hRenderEmptyText = + toByteString (render (HtmlDocument UTF8 Nothing [ + TextNode "" + ])) + == "" + +hSingleQuoteInAttr :: Bool +hSingleQuoteInAttr = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo" [("bar", "test\'ing")] [] + ])) + == "" + +hDoubleQuoteInAttr :: Bool +hDoubleQuoteInAttr = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo" [("bar", "test\"ing")] [] + ])) + == "" + +hBothQuotesInAttr :: Bool +hBothQuotesInAttr = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo" [("bar", "test\'\"ing")] [] + ])) + == "" + + +------------------------------------------------------------------------------ +-- HTML Quirks Rendering Tests ----------------------------------------------- +------------------------------------------------------------------------------ + +htmlRenderingQuirkTests :: [Test] +htmlRenderingQuirkTests = [ + testIt "renderHTMLVoid " renderHTMLVoid, + testIt "renderHTMLVoid2 " renderHTMLVoid2, + testIt "renderHTMLRaw " renderHTMLRaw, + testIt "renderHTMLRawMult " renderHTMLRawMult, + testIt "renderHTMLRaw2 " renderHTMLRaw2, + testIt "renderHTMLRaw3 " renderHTMLRaw3, + testIt "renderHTMLRaw4 " renderHTMLRaw4, + testIt "renderHTMLAmpAttr1 " renderHTMLAmpAttr1, + testIt "renderHTMLAmpAttr2 " renderHTMLAmpAttr2, + testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3, + testIt "renderHTMLQVoid " renderHTMLQVoid, + testIt "renderHTMLQVoid2 " renderHTMLQVoid2, + testIt "renderHTMLQRaw " renderHTMLQRaw, + testIt "renderHTMLQRawMult " renderHTMLQRawMult, + testIt "renderHTMLQRaw2 " renderHTMLQRaw2, + testIt "renderHTMLQRaw3 " renderHTMLQRaw3, + testIt "renderHTMLQRaw4 " renderHTMLQRaw4 + ] + +renderHTMLVoid :: Bool +renderHTMLVoid = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "img" [("src", "foo")] [] + ])) + == "" + +renderHTMLVoid2 :: Bool +renderHTMLVoid2 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "img" [] [TextNode "foo"] + ])) + +renderHTMLRaw :: Bool +renderHTMLRaw = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "script" [("type", "text/javascript")] [ + TextNode "/&+" + ] + ])) + == "" + +renderHTMLRawMult :: Bool +renderHTMLRawMult = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "script" [("type", "text/javascript")] [ + TextNode "foo", + TextNode "bar" + ] + ])) + == "" + +renderHTMLRaw2 :: Bool +renderHTMLRaw2 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "script" [("type", "text/javascript")] [ + TextNode "" + ] + ])) + +renderHTMLRaw3 :: Bool +renderHTMLRaw3 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "script" [("type", "text/javascript")] [ + Comment "foo" + ] + ])) + +renderHTMLRaw4 :: Bool +renderHTMLRaw4 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "script" [("type", "text/javascript")] [ + TextNode "" + ] + ])) + +renderHTMLAmpAttr1 :: Bool +renderHTMLAmpAttr1 = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "body" [("foo", "a & b")] [] ])) + == "" + +renderHTMLAmpAttr2 :: Bool +renderHTMLAmpAttr2 = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "body" [("foo", "a & b")] [] ])) + == "" + +renderHTMLAmpAttr3 :: Bool +renderHTMLAmpAttr3 = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "body" [("foo", "a e b")] [] ])) + == "" + +renderHTMLQVoid :: Bool +renderHTMLQVoid = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:img" [("src", "foo")] [] + ])) + == "" + +renderHTMLQVoid2 :: Bool +renderHTMLQVoid2 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:img" [] [TextNode "foo"] + ])) + +renderHTMLQRaw :: Bool +renderHTMLQRaw = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "/&+" + ] + ])) + == "/&+" + +renderHTMLQRawMult :: Bool +renderHTMLQRawMult = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "foo", + TextNode "bar" + ] + ])) + == "foobar" + +renderHTMLQRaw2 :: Bool +renderHTMLQRaw2 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "" + ] + ])) + +renderHTMLQRaw3 :: Bool +renderHTMLQRaw3 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + Comment "foo" + ] + ])) + +renderHTMLQRaw4 :: Bool +renderHTMLQRaw4 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "" + ] + ])) + + +------------------------------------------------------------------------------ +-- Tests of rendering from the blaze-html package ---------------------------- +------------------------------------------------------------------------------ + +blazeRenderTests :: [Test] +blazeRenderTests = [ + testIt "blazeTestString " blazeTestString, + testIt "blazeTestText " blazeTestText, + testIt "blazeTestBS " blazeTestBS, + testIt "blazeTestPre " blazeTestPre, + testIt "blazeTestExternal " blazeTestExternal, + testIt "blazeTestCustom " blazeTestCustom, + testIt "blazeTestMulti " blazeTestMulti, + testIt "blazeTestEmpty " blazeTestEmpty + ] + +blazeTestIsString :: (IsString t1, IsString t) => + (t -> AttributeValue) -> (t1 -> Html) -> Bool +blazeTestIsString valFunc tagFunc = renderHtml html == result + where + html = H.div ! A.class_ (valFunc "foo") $ tagFunc "hello world" + result = HtmlDocument UTF8 Nothing [Element "div" [("class", "foo")] [TextNode "hello world"]] + +blazeTestString :: Bool +blazeTestString = blazeTestIsString H.stringValue H.string + +blazeTestText :: Bool +blazeTestText = blazeTestIsString H.textValue H.text + +blazeTestBS :: Bool +blazeTestBS = blazeTestIsString H.unsafeByteStringValue H.unsafeByteString + +blazeTestPre :: Bool +blazeTestPre = blazeTestIsString H.preEscapedStringValue H.preEscapedString + +blazeTestExternal :: Bool +blazeTestExternal = renderHtml html == result + where + html = do + H.script $ H.string "alert('hello world');" + result = HtmlDocument UTF8 Nothing [Element "script" [] [TextNode "alert('hello world');"]] + +blazeTestCustom :: Bool +blazeTestCustom = renderHtml html == result + where + html = do + H.select ! H.customAttribute "dojoType" (mappend "select " "this") $ "foo" + result = HtmlDocument UTF8 Nothing [Element "select" [("dojoType", "select this")] [TextNode "foo"]] + +blazeTestMulti :: Bool +blazeTestMulti = renderHtml (selectCustom `mappend` html) == result + where + html = do + H.link ! A.rel "stylesheet" + result = HtmlDocument UTF8 Nothing + [ Element "select" [("dojoType", "select")] [TextNode "foo ", TextNode "bar"] + , Element "link" [("rel", "stylesheet")] [] + ] + +blazeTestEmpty :: Bool +blazeTestEmpty = renderHtmlNodes mempty == [] + +selectCustom :: Html +selectCustom = H.select ! H.customAttribute "dojoType" "select" $ (mappend "foo " "bar") + + + diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs deleted file mode 100644 --- a/test/suite/TestSuite.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Test.Framework (defaultMain) -import Text.XmlHtml.Tests (tests) - -main :: IO () -main = defaultMain tests diff --git a/test/suite/Text/XmlHtml/CursorTests.hs b/test/suite/Text/XmlHtml/CursorTests.hs deleted file mode 100644 --- a/test/suite/Text/XmlHtml/CursorTests.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.XmlHtml.CursorTests (cursorTests) where - -import Data.Maybe -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, Node) -import Text.XmlHtml -import Text.XmlHtml.Cursor -import Text.XmlHtml.TestCommon - ------------------------------------------------------------------------------- --- Tests of navigating with the Cursor type ---------------------------------- ------------------------------------------------------------------------------- - -cursorTests :: [Test] -cursorTests = [ - testIt "fromNodeAndCurrent " $ fromNodeAndCurrent, - testIt "fromNodesAndSiblings " $ fromNodesAndSiblings, - testIt "leftSiblings " $ leftSiblings, - testIt "emptyFromNodes " $ emptyFromNodes, - testIt "cursorNEQ " $ cursorNEQ, - testCase "cursorNavigation " $ cursorNavigation, - testCase "cursorSearch " $ cursorSearch, - testCase "cursorMutation " $ cursorMutation, - testCase "cursorInsertion " $ cursorInsertion, - testCase "cursorDeletion " $ cursorDeletion - ] - -fromNodeAndCurrent :: Bool -fromNodeAndCurrent = all (\n -> n == current (fromNode n)) ns - where ns = [ - TextNode "foo", - Comment "bar", - Element "foo" [] [], - Element "root" [] [ - TextNode "foo", - Comment "bar", - Element "foo" [] [] - ] - ] - -fromNodesAndSiblings :: Bool -fromNodesAndSiblings = n == siblings (fromJust $ fromNodes n) - where n = [ - TextNode "foo", - Comment "bar", - Element "foo" [] [], - Element "root" [] [ - TextNode "foo", - Comment "bar", - Element "foo" [] [] - ] - ] - -leftSiblings :: Bool -leftSiblings = fromJust $ do - r <- do - c1 <- fromNodes n - c2 <- right c1 - c3 <- right c2 - return c3 - return (n == siblings r) - where n = [ - TextNode "foo", - Comment "bar", - Element "foo" [] [], - Element "root" [] [ - TextNode "foo", - Comment "bar", - Element "foo" [] [] - ] - ] - -emptyFromNodes :: Bool -emptyFromNodes = isNothing (fromNodes []) - -cursorNEQ :: Bool -cursorNEQ = let a = fromNode (Element "a" [] []) - b = fromNode (Element "b" [] []) - in a /= b - --- Sample node structure for running cursor tests. -cursorTestTree :: Node -cursorTestTree = Element "department" [("code", "A17")] [ - Element "employee" [("name", "alice")] [ - Element "address" [] [ - TextNode "124 My Road" - ], - Element "phone" [] [ - TextNode "555-1234" - ] - ], - Element "employee" [("name", "bob")] [ - Comment "My best friend", - Element "address" [] [ - TextNode "123 My Road" - ], - Element "temp" [] [] - ], - Element "employee" [("name", "camille")] [ - Element "phone" [] [ - TextNode "800-888-8888" - ] - ] - ] - -cursorNavigation :: Assertion -cursorNavigation = do - let r = fromNode cursorTestTree - - let Just e1 = firstChild r - let Just e2 = getChild 1 r - let Just e3 = lastChild r - - assertBool "rootElem" $ isElement (current r) - assertBool "parent of root" $ isNothing (parent r) - - assertBool "getChild bounds" $ isNothing (getChild 3 r) - assertBool "getChild negative bounds" $ isNothing (getChild (-1) r) - assertBool "firstChild" $ - getAttribute "name" (current e1) == Just "alice" - assertBool "childAt 1 " $ - getAttribute "name" (current e2) == Just "bob" - assertBool "lastChild " $ - getAttribute "name" (current e3) == Just "camille" - - do let Just a = lastChild e2 - assertBool "firstChild on empty element" $ isNothing (firstChild a) - assertBool "getChild on empty element" $ isNothing (getChild 0 a) - assertBool "lastChild on empty element" $ isNothing (lastChild a) - - do let Just a = right e1 - let Just b = right a - assertBool "two paths #1" $ a == e2 - assertBool "two paths #2" $ b == e3 - assertBool "right off end" $ isNothing (right b) - - let Just c = left e3 - let Just d = left e2 - assertBool "two paths #3" $ c == e2 - assertBool "two paths #4" $ d == e1 - assertBool "left off end" $ isNothing (left d) - - do let Just r1 = parent e2 - assertEqual "child -> parent" (current r) (current r1) - - do let Just cmt = firstChild e2 - assertBool "topNode" $ tagName (topNode cmt) == Just "department" - assertBool "topNodes" $ map tagName (topNodes cmt) == [ Just "department" ] - - assertBool "first child of comment" $ isNothing (firstChild cmt) - assertBool "last child of comment" $ isNothing (lastChild cmt) - - do assertBool "nextDF down" $ nextDF r == Just e1 - - let Just cmt = firstChild e2 - assertBool "nextDF right" $ nextDF cmt == right cmt - - let Just em = lastChild e2 - assertBool "nextDF up-right" $ nextDF em == Just e3 - - let Just pelem = lastChild e3 - let Just ptext = lastChild pelem - assertBool "nextDF end" $ isNothing (nextDF ptext) - - -cursorSearch :: Assertion -cursorSearch = do - let r = fromNode cursorTestTree - - let Just e1 = findChild isFirst r - let Just e2 = findChild ((==(Just "bob")) . getAttribute "name" . current) r - let Just e3 = findChild isLast r - - assertBool "findChild isFirst" $ - getAttribute "name" (current e1) == Just "alice" - assertBool "findChild" $ - getAttribute "name" (current e2) == Just "bob" - assertBool "findChild isLast" $ - getAttribute "name" (current e3) == Just "camille" - - assertBool "findLeft Just" $ findLeft (const True) e2 == Just e1 - assertBool "findLeft Nothing" $ findLeft (const False) e2 == Nothing - assertBool "findRight Just" $ findRight (const True) e2 == Just e3 - assertBool "findRight Nothing" $ findRight (const False) e2 == Nothing - assertBool "findRec" $ findRec (not . hasChildren) r == (firstChild =<< firstChild e1) - - assertBool "isChild true" $ isChild e1 - assertBool "isChild false" $ not $ isChild r - assertBool "getNodeIndex" $ getNodeIndex e2 == 1 - - -cursorMutation :: Assertion -cursorMutation = do - let r = fromNode cursorTestTree - - let Just e1 = firstChild r - let Just e2 = right e1 - let Just e3 = lastChild r - - do let Just cmt = firstChild e2 - let cmt' = setNode (Comment "Not my friend any more") cmt - let Just e2' = parent cmt' - assertBool "setNode" $ current e2' == - Element "employee" [("name", "bob")] [ - Comment "Not my friend any more", - Element "address" [] [ - TextNode "123 My Road" - ], - Element "temp" [] [] - ] - - do let e1' = modifyNode (setAttribute "name" "bryan") e1 - let n = current e1' - assertBool "modifyNode" $ getAttribute "name" n == Just "bryan" - - do let myModifyM = return . setAttribute "name" "chelsea" - e3' <- modifyNodeM myModifyM e3 - let n = current e3' - assertBool "modifyNode" $ getAttribute "name" n == Just "chelsea" - - -cursorInsertion :: Assertion -cursorInsertion = do - let r = fromNode cursorTestTree - let Just alice = firstChild r - let Just bob = getChild 1 r - let Just camille = lastChild r - - let fred = Element "employee" [("name", "fred")] [] - - -- Stock insertLeft - do let ins = insertLeft fred bob - assertBool "insertLeft leaves cursor" $ - getAttribute "name" (current ins) == Just "bob" - - let Just a = findLeft isFirst ins - assertBool "insertLeft 1" $ - getAttribute "name" (current a) == Just "alice" - - let Just b = right a - assertBool "insertLeft 2" $ - getAttribute "name" (current b) == Just "fred" - - let Just c = right b - assertBool "insertLeft 3" $ - getAttribute "name" (current c) == Just "bob" - - let Just d = right c - assertBool "insertLeft 4" $ - getAttribute "name" (current d) == Just "camille" - - -- insertLeft on first child - do let ins = insertLeft fred alice - assertBool "insertLeft firstChild" $ - getAttribute "name" (current ins) == Just "alice" - - let Just a = findLeft isFirst ins - assertBool "insertLeft firstChild 1" $ - getAttribute "name" (current a) == Just "fred" - - -- Stock insertRight - do let ins = insertRight fred alice - assertBool "insertRight leaves cursor" $ - getAttribute "name" (current ins) == Just "alice" - - let Just a = findRight isLast ins - assertBool "insertRight 1" $ - getAttribute "name" (current a) == Just "camille" - - let Just b = left a - assertBool "insertRight 2" $ - getAttribute "name" (current b) == Just "bob" - - let Just c = left b - assertBool "insertRight 3" $ - getAttribute "name" (current c) == Just "fred" - - let Just d = left c - assertBool "insertRight 4" $ - getAttribute "name" (current d) == Just "alice" - - -- insertRight on last child - do let ins = insertRight fred camille - assertBool "insertRight lastChild" $ - getAttribute "name" (current ins) == Just "camille" - - let Just a = findRight isLast ins - assertBool "insertRight lastChild 1" $ - getAttribute "name" (current a) == Just "fred" - - let mary = Element "employee" [("name", "mary")] [] - let new = [fred, mary] - - -- insertManyLeft - do let ins = insertManyLeft new camille - assertBool "insertManyLeft leaves cursor" $ - getAttribute "name" (current ins) == Just "camille" - - let Just a = left ins - assertBool "insertManyLeft 1" $ - getAttribute "name" (current a) == Just "mary" - - let Just b = left a - assertBool "insertManyLeft 2" $ - getAttribute "name" (current b) == Just "fred" - - let Just c = left b - assertBool "insertManyLeft 3" $ - getAttribute "name" (current c) == Just "bob" - - -- insertManyRight - do let ins = insertManyRight new alice - assertBool "insertManyRight leaves cursor" $ - getAttribute "name" (current ins) == Just "alice" - - let Just a = right ins - assertBool "insertManyRight 1" $ - getAttribute "name" (current a) == Just "fred" - - let Just b = right a - assertBool "insertManyRight 2" $ - getAttribute "name" (current b) == Just "mary" - - let Just c = right b - assertBool "insertManyRight 3" $ - getAttribute "name" (current c) == Just "bob" - - -- insertFirstChild and insertLastChild - do let Just ins1 = insertFirstChild fred r - let Just ins2 = insertLastChild mary ins1 - - let Just a = firstChild ins2 - assertBool "insert children 1" $ - getAttribute "name" (current a) == Just "fred" - - let Just b = right a - assertBool "insert children 2" $ - getAttribute "name" (current b) == Just "alice" - - let Just c = right b - assertBool "insert children 3" $ - getAttribute "name" (current c) == Just "bob" - - let Just d = right c - assertBool "insert children 4" $ - getAttribute "name" (current d) == Just "camille" - - let Just e = right d - assertBool "insert children 5" $ - getAttribute "name" (current e) == Just "mary" - assertBool "insert children 6" $ isLast e - - -- non-element insertFirstChild and insertLastChild - do let Just cmt = firstChild bob - assertBool "non-elem insertFirstChild" $ - insertFirstChild fred cmt == Nothing - assertBool "non-elem insertLastChild" $ - insertLastChild fred cmt == Nothing - assertBool "non-elem insertManyFirstChild" $ - insertManyFirstChild new cmt == Nothing - assertBool "non-elem insertManyLastChild" $ - insertManyLastChild new cmt == Nothing - - -- insertManyFirstChild - do let Just ins = insertManyFirstChild new r - - let Just a = firstChild ins - assertBool "insertManyFirstChild 1" $ - getAttribute "name" (current a) == Just "fred" - - let Just b = right a - assertBool "insertManyFirstChild 2" $ - getAttribute "name" (current b) == Just "mary" - - let Just c = right b - assertBool "insertManyFirstChild 3" $ - getAttribute "name" (current c) == Just "alice" - - let Just d = right c - assertBool "insertManyFirstChild 4" $ - getAttribute "name" (current d) == Just "bob" - - let Just e = right d - assertBool "insertManyFirstChild 5" $ - getAttribute "name" (current e) == Just "camille" - assertBool "insertManyFirstChild 6" $ isLast e - - - -- insertManyLastChild - do let Just ins = insertManyLastChild new r - - let Just a = firstChild ins - assertBool "insertManyFirstChild 1" $ - getAttribute "name" (current a) == Just "alice" - - let Just b = right a - assertBool "insertManyFirstChild 2" $ - getAttribute "name" (current b) == Just "bob" - - let Just c = right b - assertBool "insertManyFirstChild 3" $ - getAttribute "name" (current c) == Just "camille" - - let Just d = right c - assertBool "insertManyFirstChild 4" $ - getAttribute "name" (current d) == Just "fred" - - let Just e = right d - assertBool "insertManyFirstChild 5" $ - getAttribute "name" (current e) == Just "mary" - assertBool "insertManyFirstChild 6" $ isLast e - - -- insertGoLeft from middle - do let ins = insertGoLeft fred bob - let Just a = right ins - assertBool "insertGoLeft 1" $ - getAttribute "name" (current ins) == Just "fred" - assertBool "insertGoLeft 2" $ - getAttribute "name" (current a) == Just "bob" - - -- insertGoLeft from end - do let ins = insertGoLeft fred alice - let Just a = right ins - assertBool "insertGoLeft 3" $ - getAttribute "name" (current ins) == Just "fred" - assertBool "insertGoLeft 4" $ - getAttribute "name" (current a) == Just "alice" - - -- insertGoRight from middle - do let ins = insertGoRight fred bob - let Just a = left ins - assertBool "insertGoRight 1" $ - getAttribute "name" (current ins) == Just "fred" - assertBool "insertGoRight 2" $ - getAttribute "name" (current a) == Just "bob" - - -- insertGoRight from end - do let ins = insertGoRight fred camille - let Just a = left ins - assertBool "insertGoRight 3" $ - getAttribute "name" (current ins) == Just "fred" - assertBool "insertGoRight 4" $ - getAttribute "name" (current a) == Just "camille" - - -cursorDeletion :: Assertion -cursorDeletion = do - let r = fromNode cursorTestTree - let Just alice = firstChild r - let Just bob = getChild 1 r - let Just camille = lastChild r - - -- removeLeft success - do let Just (n,del) = removeLeft bob - let [b,c] = siblings del - assertBool "removeLeft node1" $ getAttribute "name" n == Just "alice" - assertBool "removeLeft node2" $ getAttribute "name" b == Just "bob" - assertBool "removeLeft node3" $ getAttribute "name" c == Just "camille" - - -- removeLeft failure - do assertBool "removeLeft failure" $ isNothing (removeLeft alice) - - -- removeRight success - do let Just (n,del) = removeRight bob - let [a,b] = siblings del - assertBool "removeLeft node1" $ getAttribute "name" a == Just "alice" - assertBool "removeLeft node2" $ getAttribute "name" b == Just "bob" - assertBool "removeLeft node3" $ getAttribute "name" n == Just "camille" - - -- removeRight failure - do assertBool "removeLeft failure" $ isNothing (removeRight camille) - - -- removeGoLeft success - do let Just del = removeGoLeft bob - let Just c = right del - assertBool "removeGoLeft 1" $ - getAttribute "name" (current del) == Just "alice" - assertBool "removeGoLeft 2" $ - getAttribute "name" (current c) == Just "camille" - - -- removeGoLeft failure - do assertBool "removeGoLeft failure" $ isNothing (removeGoLeft alice) - - -- removeGoRight success - do let Just del = removeGoRight bob - let Just a = left del - assertBool "removeGoRight 1" $ - getAttribute "name" (current del) == Just "camille" - assertBool "removeGoRight 2" $ - getAttribute "name" (current a) == Just "alice" - - -- removeGoLeft failure - do assertBool "removeGoRight failure" $ isNothing (removeGoRight camille) - - -- removeGoUp success - do let Just del = removeGoUp bob - let [a,c] = childNodes (current del) - assertBool "removeGoUp 1" $ getAttribute "name" a == Just "alice" - assertBool "removeGoUp 2" $ getAttribute "name" c == Just "camille" - - -- removeGoUp failure - do assertBool "removeGoUp failure" $ isNothing (removeGoUp r) diff --git a/test/suite/Text/XmlHtml/DocumentTests.hs b/test/suite/Text/XmlHtml/DocumentTests.hs deleted file mode 100644 --- a/test/suite/Text/XmlHtml/DocumentTests.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.XmlHtml.DocumentTests (documentTests) where - -import Data.Text () -- for string instance -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Node, Test) -import Text.XmlHtml -import Text.XmlHtml.TestCommon - - ------------------------------------------------------------------------------- --- Tests of manipulating the Node tree and Document -------------------------- ------------------------------------------------------------------------------- - -documentTests :: [Test] -documentTests = [ - -- Exercise the (/=) operators; (==) is done plenty of places. - testIt "compareExternalIDs " $ compareExternalIDs, - testIt "compareInternalSubs " $ compareInternalSubs, - testIt "compareDoctypes " $ compareDoctypes, - testIt "compareNodes " $ compareNodes, - testIt "compareDocuments " $ compareDocuments, - testIt "compareEncodings " $ compareEncodings, - - -- Silly tests just to exercise the Show instances on types. - testCase "exerciseShows " $ exerciseShows, - - -- Exercise the accessors for Document and Node - testCase "docNodeAccessors " $ docNodeAccessors, - - testIt "isTextNodeYes " $ isTextNode someTextNode, - testIt "isTextNodeNo " $ not $ isTextNode someComment, - testIt "isTextNodeNo2 " $ not $ isTextNode someElement, - testIt "isCommentYes " $ isComment someComment, - testIt "isCommentNo " $ not $ isComment someTextNode, - testIt "isCommentNo2 " $ not $ isComment someElement, - testIt "isElementYes " $ isElement someElement, - testIt "isElementNo " $ not $ isElement someTextNode, - testIt "isElementNo2 " $ not $ isElement someComment, - testIt "tagNameElement " $ tagName someElement == Just "baz", - testIt "tagNameText " $ tagName someTextNode == Nothing, - testIt "tagNameComment " $ tagName someComment == Nothing, - testIt "getAttributePresent " $ getAttribute "fiz" someElement - == Just "buzz", - testIt "getAttributeMissing " $ getAttribute "baz" someElement - == Nothing, - testIt "getAttributeWrongType " $ getAttribute "fix" someTextNode - == Nothing, - testIt "hasAttributePresent " $ hasAttribute "fiz" someElement, - testIt "hasAttributeMissing " $ not $ hasAttribute "baz" someElement, - testIt "hasAttributeWrongType " $ not $ hasAttribute "fix" someTextNode, - testIt "setAttributeNew " $ setAttributeNew, - testIt "setAttributeReplace " $ setAttributeReplace, - testIt "setAttributeWrongType " $ setAttributeWrongType, - testIt "nestedNodeText " $ nestedNodeText, - testIt "childNodesElem " $ childNodesElem, - testIt "childNodesOther " $ childNodesOther, - testIt "childElemsTest " $ childElemsTest, - testIt "childElemsTagTest " $ childElemsTagTest, - testIt "childElemTagExists " $ childElemTagExists, - testIt "childElemTagNotExists " $ childElemTagNotExists, - testIt "childElemTagOther " $ childElemTagOther, - testIt "descNodesElem " $ descNodesElem, - testIt "descNodesOther " $ descNodesOther, - testIt "descElemsTest " $ descElemsTest, - testIt "descElemsTagTest " $ descElemsTagTest, - testIt "descElemTagExists " $ descElemTagExists, - testIt "descElemTagDFS " $ descElemTagDFS, - testIt "descElemTagNotExists " $ descElemTagNotExists, - testIt "descElemTagOther " $ descElemTagOther - ] - - -compareExternalIDs :: Bool -compareExternalIDs = Public "foo" "bar" /= System "bar" - -compareInternalSubs :: Bool -compareInternalSubs = InternalText "" /= NoInternalSubset - -compareDoctypes :: Bool -compareDoctypes = DocType "html" NoExternalID NoInternalSubset - /= DocType "foo" NoExternalID NoInternalSubset - -compareNodes :: Bool -compareNodes = TextNode "" /= Comment "" - -compareDocuments :: Bool -compareDocuments = XmlDocument UTF8 Nothing [] /= HtmlDocument UTF8 Nothing [] - -compareEncodings :: Bool -compareEncodings = UTF8 /= UTF16BE - -exerciseShows :: Assertion -exerciseShows = do - assertBool "1" $ length (showList [NoExternalID] "") > 0 - assertBool "2" $ length (showList [NoInternalSubset] "") > 0 - assertBool "3" $ length (showList [DocType "foo" NoExternalID NoInternalSubset] "") > 0 - assertBool "4" $ length (showList [TextNode ""] "") > 0 - assertBool "5" $ length (showList [XmlDocument UTF8 Nothing []] "") > 0 - assertBool "6" $ length (showList [UTF8] "") > 0 - -docNodeAccessors :: Assertion -docNodeAccessors = do - let hdoc = HtmlDocument UTF8 Nothing [] - assertEqual "html enc" (docEncoding hdoc) UTF8 - assertEqual "html type" (docType hdoc) Nothing - assertEqual "html nodes" (docContent hdoc) [] - - let xdoc = XmlDocument UTF8 Nothing [] - assertEqual "xml enc" (docEncoding xdoc) UTF8 - assertEqual "xml type" (docType xdoc) Nothing - assertEqual "xml nodes" (docContent xdoc) [] - - let elm = Element "foo" [] [] - let txt = TextNode "" - let cmt = Comment "" - assertEqual "elm tag" (elementTag elm) "foo" - assertEqual "elm attr" (elementAttrs elm) [] - assertEqual "elm child" (elementChildren elm) [] - assertBool "txt tag" $ isBottom (elementTag txt) - assertBool "txt attr" $ isBottom (elementAttrs txt) - assertBool "txt child" $ isBottom (elementChildren txt) - assertBool "cmt tag" $ isBottom (elementTag cmt) - assertBool "cmt attr" $ isBottom (elementAttrs cmt) - assertBool "cmt child" $ isBottom (elementChildren cmt) - - -someTextNode :: Node -someTextNode = TextNode "foo" - -someComment :: Node -someComment = Comment "bar" - -someElement :: Node -someElement = Element "baz" [("fiz","buzz")] [TextNode "content"] - -someTree :: Node -someTree = Element "department" [("code", "A17")] [ - Element "employee" [("name", "bob")] [ - Comment "My best friend", - Element "address" [] [ - TextNode "123 My Road" - ] - ], - Element "employee" [("name", "alice")] [ - Element "address" [] [ - TextNode "124 My Road" - ], - Element "phone" [] [ - TextNode "555-1234" - ] - ] - ] - -setAttributeNew :: Bool -setAttributeNew = - let e = setAttribute "flo" "friz" someElement - in length (elementAttrs e) == 2 - && getAttribute "fiz" e == Just "buzz" - && getAttribute "flo" e == Just "friz" - -setAttributeReplace :: Bool -setAttributeReplace = - let e = setAttribute "fiz" "bat" someElement - in length (elementAttrs e) == 1 - && getAttribute "fiz" e == Just "bat" - -setAttributeWrongType :: Bool -setAttributeWrongType = - setAttribute "fuss" "plus" someTextNode == someTextNode - && setAttribute "fuss" "plus" someComment == someComment - -nestedNodeText :: Bool -nestedNodeText = nodeText someTree == "123 My Road124 My Road555-1234" - -childNodesElem :: Bool -childNodesElem = length (childNodes n) == 3 - where n = Element "foo" [] [ TextNode "bar", - Comment "baz", - Element "bat" [] [] ] - -childNodesOther :: Bool -childNodesOther = childNodes (TextNode "foo") == [] - && childNodes (Comment "bar") == [] - -childElemsTest :: Bool -childElemsTest = length (childElements n) == 1 - where n = Element "foo" [] [ TextNode "bar", - Comment "baz", - Element "bat" [] [] ] - -childElemsTagTest :: Bool -childElemsTagTest = length (childElementsTag "good" n) == 2 - where n = Element "parent" [] [ - Element "good" [] [], - TextNode "foo", - Comment "bar", - Element "bad" [] [], - Element "good" [] [], - Element "bad" [] [] - ] - -childElemTagExists :: Bool -childElemTagExists = childElementTag "b" n == Just (Element "b" [] []) - where n = Element "parent" [] [ - Element "a" [] [], - Element "b" [] [], - Element "c" [] [] - ] - -childElemTagNotExists :: Bool -childElemTagNotExists = childElementTag "b" n == Nothing - where n = Element "parent" [] [ - Element "a" [] [], - Element "c" [] [] - ] - -childElemTagOther :: Bool -childElemTagOther = childElementTag "b" n == Nothing - where n = TextNode "" - - -descNodesElem :: Bool -descNodesElem = length (descendantNodes n) == 3 - where n = Element "foo" [] [ TextNode "bar", - Element "bat" [] [ Comment "baz" ] ] - -descNodesOther :: Bool -descNodesOther = descendantNodes (TextNode "foo") == [] - && descendantNodes (Comment "bar") == [] - -descElemsTest :: Bool -descElemsTest = length (descendantElements n) == 1 - where n = Element "foo" [] [ TextNode "bar", - Element "bat" [] [ Comment "baz" ] ] - -descElemsTagTest :: Bool -descElemsTagTest = length (descendantElementsTag "good" n) == 2 - where n = Element "parent" [] [ - TextNode "foo", - Element "good" [] [], - Comment "bar", - Element "parent" [] [ Element "good" [] [] ], - Element "bad" [] [] - ] - -descElemTagExists :: Bool -descElemTagExists = descendantElementTag "b" n == Just (Element "b" [] []) - where n = Element "parent" [] [ - Element "a" [] [ Element "b" [] [] ], - Element "c" [] [] - ] - -descElemTagDFS :: Bool -descElemTagDFS = descendantElementTag "b" n == Just (Element "b" [] []) - where n = Element "parent" [] [ - Element "a" [] [ Element "b" [] [] ], - Element "b" [("wrong", "")] [], - Element "c" [] [] - ] - -descElemTagNotExists :: Bool -descElemTagNotExists = descendantElementTag "b" n == Nothing - where n = Element "parent" [] [ - Element "a" [] [], - Element "c" [] [ Element "d" [] [] ] - ] - -descElemTagOther :: Bool -descElemTagOther = descendantElementTag "b" n == Nothing - where n = TextNode "" - diff --git a/test/suite/Text/XmlHtml/OASISTest.hs b/test/suite/Text/XmlHtml/OASISTest.hs deleted file mode 100644 --- a/test/suite/Text/XmlHtml/OASISTest.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.XmlHtml.OASISTest (testsOASIS) where - -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Monad -import qualified Data.ByteString as B -import Data.Maybe -import qualified Data.Text as T -import System.Directory -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, Node) -import Text.XmlHtml - ------------------------------------------------------------------------------- --- | Runs the OASIS XML conformance test suite. The test cases sit in --- directories inside of @test/resources@. This test reads them, parses them, --- and ensures that they behave as expected: --- --- * If there is a file in the same directory named /filename/@.correct@ --- or /filename/@.incorrect@, the parsing is expected to either succeed --- or fail, as indicated. Otherwise, the remaining cases apply. --- --- * For those tests marked @not-wf@, the test expects an error message. --- --- * For tests marked @valid@ or @invalid@ (there is no distinction since --- @xmlhtml@ is not a validating parser), the test expects a successful --- parse, but does not verify the parse result. --- --- For tests that should succeed as XML but not HTML, or vice versa, files --- can be named /filename/@.xml.correct@, and so on (all 4 combinations). - -testsOASIS :: [Test] -testsOASIS = [ - testCase "xmlhtml/ibm-not-wf " $ oasisP "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/ibm-invalid " $ oasisP "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/ibm-valid " $ oasisP "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/oasis " $ oasisP "oasis/oasis.xml", - testCase "xmlhtml/r-ibm-not-wf " $ oasisR "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/r-ibm-invalid " $ oasisR "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/r-ibm-valid " $ oasisR "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/r-oasis " $ oasisR "oasis/oasis.xml", - testCase "xmlhtml/h-ibm-not-wf " $ oasisHP "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/h-ibm-invalid " $ oasisHP "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/h-ibm-valid " $ oasisHP "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/h-oasis " $ oasisHP "oasis/oasis.xml", - testCase "xmlhtml/hr-ibm-not-wf " $ oasisHR "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/hr-ibm-invalid " $ oasisHR "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/hr-ibm-valid " $ oasisHR "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/hr-oasis " $ oasisHR "oasis/oasis.xml" - ] - - -oasisP :: String -> Assertion -oasisP name = do - tests <- getOASIS ".xml" name - forM_ tests $ \(fn, ty) -> case ty of - True -> oasisWF fn - False -> oasisNotWF fn - - -oasisR :: String -> Assertion -oasisR name = do - tests <- getOASIS ".xml" name - forM_ tests $ \(fn, ty) -> case ty of - True -> oasisRerender fn - False -> return () - - -oasisHP :: String -> Assertion -oasisHP name = do - tests <- getOASIS ".html" name - forM_ tests $ \(fn, ty) -> case ty of - True -> hOasisWF fn - False -> hOasisNotWF fn - - -oasisHR :: String -> Assertion -oasisHR name = do - tests <- getOASIS ".html" name - forM_ tests $ \(fn, ty) -> case ty of - True -> hOasisRerender fn - False -> return () - - -getOASIS :: String -> String -> IO [(String, Bool)] -getOASIS sub name = do - testListSrc <- B.readFile ("resources/" ++ name) - let Right (XmlDocument _ _ ns) = parseXML name testListSrc - let Just c = listToMaybe (filter isElement ns) - oasisTestCases sub name c - - -oasisTestCases :: String -> String -> Node -> IO [(String, Bool)] -oasisTestCases sub name n = do - fmap concat $ forM (childElements n) $ \t -> case tagName t of - Just "TESTCASES" -> oasisTestCases sub name t - Just "TEST" -> oasisTest sub name t - _ -> error (show t) - - -oasisTest :: String -> String -> Node -> IO [(String, Bool)] -oasisTest sub name t = do - let fn = file $ fromJust $ getAttribute "URI" t - fe <- doesFileExist fn - ce <- (||) <$> doesFileExist (fn ++ ".correct") - <*> doesFileExist (fn ++ sub ++ ".correct") - ie <- (||) <$> doesFileExist (fn ++ ".incorrect") - <*> doesFileExist (fn ++ sub ++ ".incorrect") - let ty = getAttribute "TYPE" t - if fe then case () of - () | ce -> return [(fn, True)] - | ie -> return [(fn, False)] - | ty == Just "not-wf" -> return [(fn, False)] - | ty == Just "invalid" -> return [(fn, True)] - | ty == Just "valid" -> return [(fn, True)] - | otherwise -> return [(fn, True)] - else return [] - where - file f = "resources/" ++ toLastSlash name ++ T.unpack f - toLastSlash s = snd (go s) - where go [] = (False, []) - go (c:cs) = let (found, ccs) = go cs - in if found then (True, c:ccs) - else if c == '/' then (True, "/") - else (False, c:cs) - - -oasisNotWF :: String -> Assertion -oasisNotWF name = do - src <- B.readFile name - assertBool ("not-wf parse " ++ name) $ isLeft (parseXML name src) - where - isLeft (Left _) = True - isLeft _ = False - - -oasisWF :: String -> Assertion -oasisWF name = do - src <- B.readFile name - assertBool ("wf parse " ++ name) $ isRight (parseXML name src) - where - isRight (Right _) = True - isRight _ = False - - -oasisRerender :: String -> Assertion -oasisRerender name = do - src <- B.readFile name - let Right d = parseXML "" src - let src2 = toByteString (render d) - let Right d2 = parseXML "" src2 - assertEqual ("rerender " ++ name) d d2 - - -hOasisNotWF :: String -> Assertion -hOasisNotWF name = do - src <- B.readFile name - assertBool ("not-wf parse " ++ name) $ isLeft (parseHTML name src) - where - isLeft (Left _) = True - isLeft _ = False - - -hOasisWF :: String -> Assertion -hOasisWF name = do - src <- B.readFile name - assertBool ("wf parse " ++ name) $ isRight (parseHTML name src) - where - isRight (Right _) = True - isRight _ = False - - -hOasisRerender :: String -> Assertion -hOasisRerender name = do - src <- B.readFile name - let Right d = parseHTML "" src - let src2 = toByteString (render d) - let Right d2 = parseHTML "" src2 - assertEqual ("rerender " ++ name) d d2 - diff --git a/test/suite/Text/XmlHtml/TestCommon.hs b/test/suite/Text/XmlHtml/TestCommon.hs deleted file mode 100644 --- a/test/suite/Text/XmlHtml/TestCommon.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Text.XmlHtml.TestCommon where - -import Control.Exception as E -import System.IO.Unsafe -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, Node) - ------------------------------------------------------------------------------- --- | Tests a simple Bool property. -testIt :: TestName -> Bool -> Test -testIt name b = testCase name $ assertBool name b - ------------------------------------------------------------------------------- --- Code adapted from ChasingBottoms. --- --- Adding an actual dependency isn't possible because Cabal refuses to build --- the package due to version conflicts. --- --- isBottom is impossible to write, but very useful! So we defy the --- impossible, and write it anyway. -isBottom :: a -> Bool -isBottom a = unsafePerformIO $ - (E.evaluate a >> return False) `E.catches` [ - E.Handler $ \ (_ :: PatternMatchFail) -> return True, - E.Handler $ \ (_ :: ErrorCall) -> return True, - E.Handler $ \ (_ :: NoMethodError) -> return True, - E.Handler $ \ (_ :: RecConError) -> return True, - E.Handler $ \ (_ :: RecUpdError) -> return True, - E.Handler $ \ (_ :: RecSelError) -> return True - ] - ------------------------------------------------------------------------------- -isLeft :: Either a b -> Bool -isLeft = either (const True) (const False) - diff --git a/test/suite/Text/XmlHtml/Tests.hs b/test/suite/Text/XmlHtml/Tests.hs deleted file mode 100644 --- a/test/suite/Text/XmlHtml/Tests.hs +++ /dev/null @@ -1,963 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Text.XmlHtml.Tests (tests) where - -import Blaze.ByteString.Builder -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Monoid -import Data.String -import Data.Text () -- for string instance -import qualified Data.Text.Encoding as T -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, Node) -import Text.Blaze -import Text.Blaze.Html -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import qualified Text.Blaze.Internal as H -import Text.Blaze.Renderer.XmlHtml -import Text.XmlHtml -import Text.XmlHtml.CursorTests -import Text.XmlHtml.DocumentTests -import Text.XmlHtml.TestCommon -import Text.XmlHtml.OASISTest - - ------------------------------------------------------------------------------- --- The master list of tests to run. ------------------------------------------ ------------------------------------------------------------------------------- - -tests :: [Test] -tests = xmlParsingTests - ++ htmlXMLParsingTests - ++ htmlParsingQuirkTests - ++ xmlRenderingTests - ++ htmlXMLRenderingTests - ++ htmlRenderingQuirkTests - ++ documentTests - ++ cursorTests - ++ blazeRenderTests - ++ testsOASIS - - ------------------------------------------------------------------------------- --- XML Parsing Tests --------------------------------------------------------- ------------------------------------------------------------------------------- - -xmlParsingTests :: [Test] -xmlParsingTests = [ - testCase "byteOrderMark " byteOrderMark, - testIt "emptyDocument " emptyDocument, - testIt "publicDocType " publicDocType, - testIt "systemDocType " systemDocType, - testIt "emptyDocType " emptyDocType, - testCase "dtdInternalScan " dtdInternalScan, - testIt "textOnly " textOnly, - testIt "textWithRefs " textWithRefs, - testIt "untermRef " untermRef, - testIt "textWithCDATA " textWithCDATA, - testIt "cdataOnly " cdataOnly, - testIt "commentOnly " commentOnly, - testIt "emptyElement " emptyElement, - testIt "emptyElement2 " emptyElement2, - testIt "elemWithText " elemWithText, - testIt "xmlDeclXML " xmlDeclXML, - testIt "procInst " procInst, - testIt "badDoctype1 " badDoctype1, - testIt "badDoctype2 " badDoctype2, - testIt "badDoctype3 " badDoctype3, - testIt "badDoctype4 " badDoctype4, - testIt "badDoctype5 " badDoctype5, - testCase "tagNames " tagNames - ] - -byteOrderMark :: Assertion -byteOrderMark = do - assertEqual "BOM UTF16BE" (Right $ XmlDocument UTF16BE Nothing []) - (parseXML "" $ T.encodeUtf16BE "\xFEFF") - assertEqual "BOM UTF16LE" (Right $ XmlDocument UTF16LE Nothing []) - (parseXML "" $ T.encodeUtf16LE "\xFEFF") - assertEqual "BOM UTF8" (Right $ XmlDocument UTF8 Nothing []) - (parseXML "" $ T.encodeUtf8 "\xFEFF") - assertEqual "BOM None" (Right $ XmlDocument UTF8 Nothing []) - (parseXML "" $ T.encodeUtf8 "") - -emptyDocument :: Bool -emptyDocument = parseXML "" "" - == Right (XmlDocument UTF8 Nothing []) - -publicDocType :: Bool -publicDocType = parseXML "" "" - == Right (XmlDocument UTF8 (Just (DocType "tag" (Public "foo" "bar") NoInternalSubset)) []) - -systemDocType :: Bool -systemDocType = parseXML "" "" - == Right (XmlDocument UTF8 (Just (DocType "tag" (System "foo") NoInternalSubset)) []) - -emptyDocType :: Bool -emptyDocType = parseXML "" "" - == Right (XmlDocument UTF8 (Just (DocType "tag" NoExternalID NoInternalSubset)) []) - -dtdInternalScan :: Assertion -dtdInternalScan = do - assertEqual "empty" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[]" ))) [])) - assertBool "bad brackets" (isLeft $ parseXML "" "") - assertEqual "quoted" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[\"]\"]" ))) [])) - assertBool "bad quote" (isLeft $ parseXML "" "") - assertEqual "nested brackets" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[[[]]]" ))) [])) - assertEqual "part comment 1" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[<]" ))) [])) - assertEqual "part comment 2" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[[<]]" ))) [])) - assertEqual "part comment 3" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[<[]]" ))) [])) - assertEqual "part comment 4" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[[") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[]>") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[]" ))) [])) - assertEqual "docint 1" (parseXML "" "]>") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[<''<\"\"]" ))) [])) - assertEqual "docint2" (parseXML "" "") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[") - (Right (XmlDocument UTF8 (Just (DocType "a" NoExternalID (InternalText - "[]>") - -textOnly :: Bool -textOnly = parseXML "" "sldhfsklj''a's s" - == Right (XmlDocument UTF8 Nothing [TextNode "sldhfsklj''a's s"]) - -textWithRefs :: Bool -textWithRefs = parseXML "" "This is Bob's sled" - == Right (XmlDocument UTF8 Nothing [TextNode "This is Bob's sled"]) - -untermRef :: Bool -untermRef = isLeft (parseXML "" "j") - -textWithCDATA :: Bool -textWithCDATA = parseXML "" "Testing c]data]]>" - == Right (XmlDocument UTF8 Nothing [TextNode "Testing with c]data"]) - -cdataOnly :: Bool -cdataOnly = parseXML "" "" - == Right (XmlDocument UTF8 Nothing [TextNode " Testing a \"comment -->" - == Right (XmlDocument UTF8 Nothing [Comment " this a \"comment "]) - -emptyElement :: Bool -emptyElement = parseXML "" "" - == Right (XmlDocument UTF8 Nothing [Element "myElement" [] []]) - -emptyElement2 :: Bool -emptyElement2 = parseXML "" "" - == Right (XmlDocument UTF8 Nothing [Element "myElement" [] []]) - -elemWithText :: Bool -elemWithText = parseXML "" "text" - == Right (XmlDocument UTF8 Nothing [Element "myElement" [] [TextNode "text"]]) - -xmlDeclXML :: Bool -xmlDeclXML = parseXML "" "" - == Right (XmlDocument UTF8 Nothing []) - -procInst :: Bool -procInst = parseXML "" " parsed!?>" - == Right (XmlDocument UTF8 Nothing []) - -badDoctype1 :: Bool -badDoctype1 = isLeft $ parseXML "" "" - -badDoctype2 :: Bool -badDoctype2 = isLeft $ parseXML "" "" - -badDoctype3 :: Bool -badDoctype3 = isLeft $ parseXML "" "" - -badDoctype4 :: Bool -badDoctype4 = isLeft $ parseXML "" "" - -badDoctype5 :: Bool -badDoctype5 = isLeft $ parseXML "" ("") - -tagNames :: Assertion -tagNames = do - assertBool "tag name 0" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "") - assertBool "tag name 1" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\xc0\&foo />") - assertBool "tag name 2" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\xd8\&foo />") - assertBool "tag name 3" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\xf8\&foo />") - assertBool "tag name 4" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x370\&foo />") - assertBool "tag name 5" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x37f\&foo />") - assertBool "tag name 6" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x200c\&foo />") - assertBool "tag name 7" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x2070\&foo />") - assertBool "tag name 8" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x2c00\&foo />") - assertBool "tag name 9" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x3001\&foo />") - assertBool "tag name 10" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\xf900\&foo />") - assertBool "tag name 11" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\xfdf0\&foo />") - assertBool "tag name 12" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "<\x10000\&foo />") - assertBool "tag name 13" $ id $ - isLeft $ parseXML "" (T.encodeUtf8 "<\xd7\&foo />") - assertBool "tag name 14" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "") - assertBool "tag name 15" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "") - assertBool "tag name 16" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "") - assertBool "tag name 17" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "") - assertBool "tag name 18" $ not $ - isLeft $ parseXML "" (T.encodeUtf8 "") - assertBool "tag name 19" $ id $ - isLeft $ parseXML "" (T.encodeUtf8 "") - - ------------------------------------------------------------------------------- --- HTML Repetitions of XML Parsing Tests ------------------------------------- ------------------------------------------------------------------------------- - -htmlXMLParsingTests :: [Test] -htmlXMLParsingTests = [ - testIt "emptyDocumentHTML " emptyDocumentHTML, - testIt "publicDocTypeHTML " publicDocTypeHTML, - testIt "systemDocTypeHTML " systemDocTypeHTML, - testIt "emptyDocTypeHTML " emptyDocTypeHTML, - testIt "textOnlyHTML " textOnlyHTML, - testIt "textWithRefsHTML " textWithRefsHTML, - testIt "textWithCDataHTML " textWithCDataHTML, - testIt "cdataOnlyHTML " cdataOnlyHTML, - testIt "commentOnlyHTML " commentOnlyHTML, - testIt "emptyElementHTML " emptyElementHTML, - testIt "emptyElement2HTML " emptyElement2HTML, - testIt "elemWithTextHTML " elemWithTextHTML, - testIt "xmlDeclHTML " xmlDeclHTML, - testIt "procInstHTML " procInstHTML, - testIt "badDoctype1HTML " badDoctype1HTML, - testIt "badDoctype2HTML " badDoctype2HTML, - testIt "badDoctype3HTML " badDoctype3HTML, - testIt "badDoctype4HTML " badDoctype4HTML, - testIt "badDoctype5HTML " badDoctype5HTML - ] - -emptyDocumentHTML :: Bool -emptyDocumentHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing []) - -publicDocTypeHTML :: Bool -publicDocTypeHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 (Just (DocType "tag" (Public "foo" "bar") NoInternalSubset)) []) - -systemDocTypeHTML :: Bool -systemDocTypeHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 (Just (DocType "tag" (System "foo") NoInternalSubset)) []) - -emptyDocTypeHTML :: Bool -emptyDocTypeHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 (Just (DocType "tag" NoExternalID NoInternalSubset)) []) - -textOnlyHTML :: Bool -textOnlyHTML = parseHTML "" "sldhfsklj''a's s" - == Right (HtmlDocument UTF8 Nothing [TextNode "sldhfsklj''a's s"]) - -textWithRefsHTML :: Bool -textWithRefsHTML = parseHTML "" "This is Bob's sled" - == Right (HtmlDocument UTF8 Nothing [TextNode "This is Bob's sled"]) - -textWithCDataHTML :: Bool -textWithCDataHTML = parseHTML "" "Testing c]data]]>" - == Right (HtmlDocument UTF8 Nothing [TextNode "Testing with c]data"]) - -cdataOnlyHTML :: Bool -cdataOnlyHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [TextNode " Testing a \"comment -->" - == Right (HtmlDocument UTF8 Nothing [Comment " this a \"comment "]) - -emptyElementHTML :: Bool -emptyElementHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "myElement" [] []]) - -emptyElement2HTML :: Bool -emptyElement2HTML = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "myElement" [] []]) - -elemWithTextHTML :: Bool -elemWithTextHTML = parseHTML "" "text" - == Right (HtmlDocument UTF8 Nothing [Element "myElement" [] [TextNode "text"]]) - -xmlDeclHTML :: Bool -xmlDeclHTML = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing []) - -procInstHTML :: Bool -procInstHTML = parseHTML "" " parsed!?>" - == Right (HtmlDocument UTF8 Nothing []) - -badDoctype1HTML :: Bool -badDoctype1HTML = isLeft $ parseHTML "" "" - -badDoctype2HTML :: Bool -badDoctype2HTML = isLeft $ parseHTML "" "" - -badDoctype3HTML :: Bool -badDoctype3HTML = isLeft $ parseHTML "" "" - -badDoctype4HTML :: Bool -badDoctype4HTML = isLeft $ parseHTML "" "" - -badDoctype5HTML :: Bool -badDoctype5HTML = isLeft $ parseHTML "" ("") - - ------------------------------------------------------------------------------- --- HTML Quirks Parsing Tests ------------------------------------------------- ------------------------------------------------------------------------------- - -htmlParsingQuirkTests :: [Test] -htmlParsingQuirkTests = [ - testIt "voidElem " voidElem, - testIt "caseInsDoctype1 " caseInsDoctype1, - testIt "caseInsDoctype2 " caseInsDoctype2, - testIt "voidEmptyElem " voidEmptyElem, - testIt "rawTextElem " rawTextElem, - testIt "endTagCase " endTagCase, - testIt "hexEntityCap " hexEntityCap, - testIt "laxAttrName " laxAttrName, - testCase "badAttrName " badAttrName, - testIt "emptyAttr " emptyAttr, - testIt "emptyAttr2 " emptyAttr2, - testIt "unquotedAttr " unquotedAttr, - testIt "laxAttrVal " laxAttrVal, - testIt "ampersandInText " ampersandInText, - testIt "omitOptionalEnds " omitOptionalEnds, - testIt "omitEndHEAD " omitEndHEAD, - testIt "omitEndLI " omitEndLI, - testIt "omitEndDT " omitEndDT, - testIt "omitEndDD " omitEndDD, - testIt "omitEndP " omitEndP, - testIt "omitEndRT " omitEndRT, - testIt "omitEndRP " omitEndRP, - testIt "omitEndOPTGRP " omitEndOPTGRP, - testIt "omitEndOPTION " omitEndOPTION, - testIt "omitEndCOLGRP " omitEndCOLGRP, - testIt "omitEndTHEAD " omitEndTHEAD, - testIt "omitEndTBODY " omitEndTBODY, - testIt "omitEndTFOOT " omitEndTFOOT, - testIt "omitEndTR " omitEndTR, - testIt "omitEndTD " omitEndTD, - testIt "omitEndTH " omitEndTH, - testIt "testNewRefs " testNewRefs, - testIt "errorImplicitClose " errorImplicitClose, - testIt "weirdScriptThing " weirdScriptThing - ] - -caseInsDoctype1 :: Bool -caseInsDoctype1 = parseHTML "" "" - == Right (HtmlDocument UTF8 (Just (DocType "html" (System "foo") NoInternalSubset)) []) - -caseInsDoctype2 :: Bool -caseInsDoctype2 = parseHTML "" "" - == Right (HtmlDocument UTF8 (Just (DocType "html" (Public "foo" "bar") NoInternalSubset)) []) - -voidElem :: Bool -voidElem = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "img" [] []]) - -voidEmptyElem :: Bool -voidEmptyElem = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "img" [] []]) - -rawTextElem :: Bool -rawTextElem = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "script" [("type", "text/javascript")] [ - TextNode "Thistest&"] - ]) - -endTagCase :: Bool -endTagCase = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "testing" [] []]) - -hexEntityCap :: Bool -hexEntityCap = parseHTML "" "j" - == Right (HtmlDocument UTF8 Nothing [TextNode "\x6a"]) - -laxAttrName :: Bool -laxAttrName = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "test" [("val") - assertBool "attr name 1" $ - isLeft $ parseHTML "" (T.encodeUtf8 "") - assertBool "attr name 2" $ - isLeft $ parseHTML "" (T.encodeUtf8 "") - assertBool "attr name 3" $ - isLeft $ parseHTML "" (T.encodeUtf8 "") - assertBool "attr name 4" $ - isLeft $ parseHTML "" (T.encodeUtf8 "") - -emptyAttr :: Bool -emptyAttr = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "test" [("attr", "")] []]) - -emptyAttr2 :: Bool -emptyAttr2 = parseHTML "" "
    " - == Right (HtmlDocument UTF8 Nothing [Element "div" [("itemscope", ""), ("itemtype", "type")] []]) - -unquotedAttr :: Bool -unquotedAttr = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "test" [("attr", "you&me")] []]) - -laxAttrVal :: Bool -laxAttrVal = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "test" [("attr", "a & d < b & c")] []]) - -ampersandInText :: Bool -ampersandInText = parseHTML "" "j" - == Right (HtmlDocument UTF8 Nothing [TextNode "j"]) - -omitOptionalEnds :: Bool -omitOptionalEnds = parseHTML "" "

    " - == Right (HtmlDocument UTF8 Nothing [Element "html" [] [ - Element "body" [] [ Element "p" [] []]]]) - -omitEndHEAD :: Bool -omitEndHEAD = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "head" [] [], Element "body" [] []]) - -omitEndLI :: Bool -omitEndLI = parseHTML "" "

  • " - == Right (HtmlDocument UTF8 Nothing [Element "li" [] [], Element "li" [] []]) - -omitEndDT :: Bool -omitEndDT = parseHTML "" "
    " - == Right (HtmlDocument UTF8 Nothing [Element "dt" [] [], Element "dd" [] []]) - -omitEndDD :: Bool -omitEndDD = parseHTML "" "
    " - == Right (HtmlDocument UTF8 Nothing [Element "dd" [] [], Element "dt" [] []]) - -omitEndP :: Bool -omitEndP = parseHTML "" "

    " - == Right (HtmlDocument UTF8 Nothing [Element "p" [] [], Element "h1" [] []]) - -omitEndRT :: Bool -omitEndRT = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "rt" [] [], Element "rp" [] []]) - -omitEndRP :: Bool -omitEndRP = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "rp" [] [], Element "rt" [] []]) - -omitEndOPTGRP :: Bool -omitEndOPTGRP = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "optgroup" [] [], Element "optgroup" [] []]) - -omitEndOPTION :: Bool -omitEndOPTION = parseHTML "" "');" - ] - ] - ]) - ------------------------------------------------------------------------------- --- XML Rendering Tests ------------------------------------------------------- ------------------------------------------------------------------------------- - -xmlRenderingTests :: [Test] -xmlRenderingTests = [ - testIt "renderByteOrderMark " renderByteOrderMark, - testIt "renderByteOrderMarkLE " renderByteOrderMarkLE, - testIt "singleQuoteInSysID " singleQuoteInSysID, - testIt "doubleQuoteInSysID " doubleQuoteInSysID, - testIt "bothQuotesInSysID " bothQuotesInSysID, - testIt "doubleQuoteInPubID " doubleQuoteInPubID, - testIt "doubleDashInComment " doubleDashInComment, - testIt "trailingDashInComment " trailingDashInComment, - testIt "renderEmptyText " renderEmptyText, - testIt "singleQuoteInAttr " singleQuoteInAttr, - testIt "doubleQuoteInAttr " doubleQuoteInAttr, - testIt "bothQuotesInAttr " bothQuotesInAttr - ] - -renderByteOrderMark :: Bool -renderByteOrderMark = - toByteString (render (XmlDocument UTF16BE Nothing [])) - == T.encodeUtf16BE "\xFEFF\n" - -renderByteOrderMarkLE :: Bool -renderByteOrderMarkLE = - toByteString (render (XmlDocument UTF16LE Nothing [])) - == T.encodeUtf16LE "\xFEFF\n" - --- (Appears at the beginning of all XML output) -utf8Decl :: ByteString -utf8Decl = T.encodeUtf8 "\n" - -singleQuoteInSysID :: Bool -singleQuoteInSysID = - toByteString (render (XmlDocument UTF8 - (Just (DocType "html" (System "test\'ing") NoInternalSubset)) - [])) - == utf8Decl `B.append` "\n" - -doubleQuoteInSysID :: Bool -doubleQuoteInSysID = - toByteString (render (XmlDocument UTF8 - (Just (DocType "html" (System "test\"ing") NoInternalSubset)) - [])) - == utf8Decl `B.append` "\n" - -bothQuotesInSysID :: Bool -bothQuotesInSysID = isBottom $ - toByteString (render (XmlDocument UTF8 - (Just (DocType "html" (System "test\"\'ing") NoInternalSubset)) - [])) - -doubleQuoteInPubID :: Bool -doubleQuoteInPubID = isBottom $ - toByteString (render (XmlDocument UTF8 - (Just (DocType "html" (Public "test\"ing" "foo") NoInternalSubset)) - [])) - -doubleDashInComment :: Bool -doubleDashInComment = isBottom $ - toByteString (render (XmlDocument UTF8 Nothing [ - Comment "test--ing" - ])) - -trailingDashInComment :: Bool -trailingDashInComment = isBottom $ - toByteString (render (XmlDocument UTF8 Nothing [ - Comment "testing-" - ])) - -renderEmptyText :: Bool -renderEmptyText = - toByteString (render (XmlDocument UTF8 Nothing [ - TextNode "" - ])) - == utf8Decl - -singleQuoteInAttr :: Bool -singleQuoteInAttr = - toByteString (render (XmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'ing")] [] - ])) - == utf8Decl `B.append` "" - -doubleQuoteInAttr :: Bool -doubleQuoteInAttr = - toByteString (render (XmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\"ing")] [] - ])) - == utf8Decl `B.append` "" - -bothQuotesInAttr :: Bool -bothQuotesInAttr = - toByteString (render (XmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'\"ing")] [] - ])) - == utf8Decl `B.append` "" - - ------------------------------------------------------------------------------- --- HTML Repeats of XML Rendering Tests --------------------------------------- ------------------------------------------------------------------------------- - -htmlXMLRenderingTests :: [Test] -htmlXMLRenderingTests = [ - testIt "hRenderByteOrderMark " hRenderByteOrderMark, - testIt "hSingleQuoteInSysID " hSingleQuoteInSysID, - testIt "hDoubleQuoteInSysID " hDoubleQuoteInSysID, - testIt "hBothQuotesInSysID " hBothQuotesInSysID, - testIt "hDoubleQuoteInPubID " hDoubleQuoteInPubID, - testIt "hDoubleDashInComment " hDoubleDashInComment, - testIt "hTrailingDashInComment " hTrailingDashInComment, - testIt "hRenderEmptyText " hRenderEmptyText, - testIt "hSingleQuoteInAttr " hSingleQuoteInAttr, - testIt "hDoubleQuoteInAttr " hDoubleQuoteInAttr, - testIt "hBothQuotesInAttr " hBothQuotesInAttr - ] - -hRenderByteOrderMark :: Bool -hRenderByteOrderMark = - toByteString (render (HtmlDocument UTF16BE Nothing [])) - == "\xFE\xFF" - -hSingleQuoteInSysID :: Bool -hSingleQuoteInSysID = - toByteString (render (HtmlDocument UTF8 - (Just (DocType "html" (System "test\'ing") NoInternalSubset)) - [])) - == "\n" - -hDoubleQuoteInSysID :: Bool -hDoubleQuoteInSysID = - toByteString (render (HtmlDocument UTF8 - (Just (DocType "html" (System "test\"ing") NoInternalSubset)) - [])) - == "\n" - -hBothQuotesInSysID :: Bool -hBothQuotesInSysID = isBottom $ - toByteString (render (HtmlDocument UTF8 - (Just (DocType "html" (System "test\"\'ing") NoInternalSubset)) - [])) - -hDoubleQuoteInPubID :: Bool -hDoubleQuoteInPubID = isBottom $ - toByteString (render (HtmlDocument UTF8 - (Just (DocType "html" (Public "test\"ing" "foo") NoInternalSubset)) - [])) - -hDoubleDashInComment :: Bool -hDoubleDashInComment = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Comment "test--ing" - ])) - -hTrailingDashInComment :: Bool -hTrailingDashInComment = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Comment "testing-" - ])) - -hRenderEmptyText :: Bool -hRenderEmptyText = - toByteString (render (HtmlDocument UTF8 Nothing [ - TextNode "" - ])) - == "" - -hSingleQuoteInAttr :: Bool -hSingleQuoteInAttr = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'ing")] [] - ])) - == "" - -hDoubleQuoteInAttr :: Bool -hDoubleQuoteInAttr = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\"ing")] [] - ])) - == "" - -hBothQuotesInAttr :: Bool -hBothQuotesInAttr = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'\"ing")] [] - ])) - == "" - - ------------------------------------------------------------------------------- --- HTML Quirks Rendering Tests ----------------------------------------------- ------------------------------------------------------------------------------- - -htmlRenderingQuirkTests :: [Test] -htmlRenderingQuirkTests = [ - testIt "renderHTMLVoid " renderHTMLVoid, - testIt "renderHTMLVoid2 " renderHTMLVoid2, - testIt "renderHTMLRaw " renderHTMLRaw, - testIt "renderHTMLRawMult " renderHTMLRawMult, - testIt "renderHTMLRaw2 " renderHTMLRaw2, - testIt "renderHTMLRaw3 " renderHTMLRaw3, - testIt "renderHTMLRaw4 " renderHTMLRaw4, - testIt "renderHTMLAmpAttr1 " renderHTMLAmpAttr1, - testIt "renderHTMLAmpAttr2 " renderHTMLAmpAttr2, - testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3, - testIt "renderHTMLQVoid " renderHTMLQVoid, - testIt "renderHTMLQVoid2 " renderHTMLQVoid2, - testIt "renderHTMLQRaw " renderHTMLQRaw, - testIt "renderHTMLQRawMult " renderHTMLQRawMult, - testIt "renderHTMLQRaw2 " renderHTMLQRaw2, - testIt "renderHTMLQRaw3 " renderHTMLQRaw3, - testIt "renderHTMLQRaw4 " renderHTMLQRaw4 - ] - -renderHTMLVoid :: Bool -renderHTMLVoid = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "img" [("src", "foo")] [] - ])) - == "" - -renderHTMLVoid2 :: Bool -renderHTMLVoid2 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "img" [] [TextNode "foo"] - ])) - -renderHTMLRaw :: Bool -renderHTMLRaw = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "script" [("type", "text/javascript")] [ - TextNode "/&+" - ] - ])) - == "" - -renderHTMLRawMult :: Bool -renderHTMLRawMult = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "script" [("type", "text/javascript")] [ - TextNode "foo", - TextNode "bar" - ] - ])) - == "" - -renderHTMLRaw2 :: Bool -renderHTMLRaw2 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "script" [("type", "text/javascript")] [ - TextNode "" - ] - ])) - -renderHTMLRaw3 :: Bool -renderHTMLRaw3 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "script" [("type", "text/javascript")] [ - Comment "foo" - ] - ])) - -renderHTMLRaw4 :: Bool -renderHTMLRaw4 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "script" [("type", "text/javascript")] [ - TextNode "" - ] - ])) - -renderHTMLAmpAttr1 :: Bool -renderHTMLAmpAttr1 = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "body" [("foo", "a & b")] [] ])) - == "" - -renderHTMLAmpAttr2 :: Bool -renderHTMLAmpAttr2 = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "body" [("foo", "a & b")] [] ])) - == "" - -renderHTMLAmpAttr3 :: Bool -renderHTMLAmpAttr3 = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "body" [("foo", "a e b")] [] ])) - == "" - -renderHTMLQVoid :: Bool -renderHTMLQVoid = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:img" [("src", "foo")] [] - ])) - == "" - -renderHTMLQVoid2 :: Bool -renderHTMLQVoid2 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:img" [] [TextNode "foo"] - ])) - -renderHTMLQRaw :: Bool -renderHTMLQRaw = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:script" [("type", "text/javascript")] [ - TextNode "/&+" - ] - ])) - == "/&+" - -renderHTMLQRawMult :: Bool -renderHTMLQRawMult = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:script" [("type", "text/javascript")] [ - TextNode "foo", - TextNode "bar" - ] - ])) - == "foobar" - -renderHTMLQRaw2 :: Bool -renderHTMLQRaw2 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:script" [("type", "text/javascript")] [ - TextNode "" - ] - ])) - -renderHTMLQRaw3 :: Bool -renderHTMLQRaw3 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:script" [("type", "text/javascript")] [ - Comment "foo" - ] - ])) - -renderHTMLQRaw4 :: Bool -renderHTMLQRaw4 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo:script" [("type", "text/javascript")] [ - TextNode "" - ] - ])) - - ------------------------------------------------------------------------------- --- Tests of rendering from the blaze-html package ---------------------------- ------------------------------------------------------------------------------- - -blazeRenderTests :: [Test] -blazeRenderTests = [ - testIt "blazeTestString " blazeTestString, - testIt "blazeTestText " blazeTestText, - testIt "blazeTestBS " blazeTestBS, - testIt "blazeTestPre " blazeTestPre, - testIt "blazeTestExternal " blazeTestExternal, - testIt "blazeTestCustom " blazeTestCustom, - testIt "blazeTestMulti " blazeTestMulti, - testIt "blazeTestEmpty " blazeTestEmpty - ] - -blazeTestIsString :: (IsString t1, IsString t) => - (t -> AttributeValue) -> (t1 -> Html) -> Bool -blazeTestIsString valFunc tagFunc = renderHtml html == result - where - html = H.div ! A.class_ (valFunc "foo") $ tagFunc "hello world" - result = HtmlDocument UTF8 Nothing [Element "div" [("class", "foo")] [TextNode "hello world"]] - -blazeTestString :: Bool -blazeTestString = blazeTestIsString H.stringValue H.string - -blazeTestText :: Bool -blazeTestText = blazeTestIsString H.textValue H.text - -blazeTestBS :: Bool -blazeTestBS = blazeTestIsString H.unsafeByteStringValue H.unsafeByteString - -blazeTestPre :: Bool -blazeTestPre = blazeTestIsString H.preEscapedStringValue H.preEscapedString - -blazeTestExternal :: Bool -blazeTestExternal = renderHtml html == result - where - html = do - H.script $ H.string "alert('hello world');" - result = HtmlDocument UTF8 Nothing [Element "script" [] [TextNode "alert('hello world');"]] - -blazeTestCustom :: Bool -blazeTestCustom = renderHtml html == result - where - html = do - H.select ! H.customAttribute "dojoType" (mappend "select " "this") $ "foo" - result = HtmlDocument UTF8 Nothing [Element "select" [("dojoType", "select this")] [TextNode "foo"]] - -blazeTestMulti :: Bool -blazeTestMulti = renderHtml (selectCustom `mappend` html) == result - where - html = do - H.link ! A.rel "stylesheet" - result = HtmlDocument UTF8 Nothing - [ Element "select" [("dojoType", "select")] [TextNode "foo ", TextNode "bar"] - , Element "link" [("rel", "stylesheet")] [] - ] - -blazeTestEmpty :: Bool -blazeTestEmpty = renderHtmlNodes mempty == [] - -selectCustom :: Html -selectCustom = H.select ! H.customAttribute "dojoType" "select" $ (mappend "foo " "bar") - - - diff --git a/test/xmlhtml-testsuite.cabal b/test/xmlhtml-testsuite.cabal deleted file mode 100644 --- a/test/xmlhtml-testsuite.cabal +++ /dev/null @@ -1,28 +0,0 @@ -name: xmlhtml-testsuite -version: 0.1.3 -build-type: Simple -cabal-version: >= 1.6 - -Executable testsuite - hs-source-dirs: ../src suite - main-is: TestSuite.hs - - build-depends: - HUnit == 1.2.*, - directory >= 1.0 && <1.3, - QuickCheck >= 2.3.0.2, - base == 4.*, - blaze-builder >= 0.2 && <0.4, - blaze-html >= 0.5 && <0.8, - blaze-markup >= 0.5 && <0.7, - bytestring >= 0.9 && <0.11, - containers >= 0.3 && <0.6, - parsec >= 3.1.2 && <3.2, - test-framework >= 0.8.0.3 && <0.9, - test-framework-hunit >= 0.3 && <0.4, - test-framework-quickcheck2 >= 0.3 && <0.4, - text >= 0.11 && <1.2, - unordered-containers >= 0.1.4 && <0.3 - - ghc-options: -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded - -fno-warn-unused-do-bind diff --git a/xmlhtml.cabal b/xmlhtml.cabal --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -1,5 +1,5 @@ Name: xmlhtml -Version: 0.2.3.4 +Version: 0.2.3.5 Synopsis: XML parser and renderer with HTML 5 quirks mode Description: Contains renderers and parsers for both XML and HTML 5 document fragments, which share data structures so that @@ -24,9 +24,11 @@ License-file: LICENSE Author: Chris Smith Maintainer: Chris Smith -Category: Text +homepage: https://github.com/snapframework/xmlhtml +Category: Text, XML Build-type: Simple -Cabal-version: >=1.6 +Cabal-version: >=1.8.0.4 +Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Extra-source-files: .ghci, @@ -34,15 +36,13 @@ extra/hscolour.css, extra/logo.gif, haddock.sh, - README, - test/runTestsAndCoverage.sh, - test/xmlhtml-testsuite.cabal, - test/suite/TestSuite.hs - test/suite/Text/XmlHtml/CursorTests.hs, - test/suite/Text/XmlHtml/DocumentTests.hs, - test/suite/Text/XmlHtml/OASISTest.hs, - test/suite/Text/XmlHtml/TestCommon.hs, - test/suite/Text/XmlHtml/Tests.hs, + README.md, + test/src/TestSuite.hs + test/src/Text/XmlHtml/CursorTests.hs, + test/src/Text/XmlHtml/DocumentTests.hs, + test/src/Text/XmlHtml/OASISTest.hs, + test/src/Text/XmlHtml/TestCommon.hs, + test/src/Text/XmlHtml/Tests.hs, test/resources/ibm/ibm_oasis_invalid.xml, test/resources/ibm/ibm_oasis_not-wf.xml, test/resources/ibm/ibm_oasis_readme.txt, @@ -820,9 +820,9 @@ Text.XmlHtml.HTML.Render Build-depends: base >= 4 && < 5, - blaze-builder >= 0.2 && < 0.4, - blaze-html >= 0.5 && < 0.8, - blaze-markup >= 0.5 && < 0.7, + blaze-builder >= 0.2 && < 0.5, + blaze-html >= 0.5 && < 0.9, + blaze-markup >= 0.5 && < 0.8, bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.6, parsec >= 3.1.2 && < 3.2, @@ -838,5 +838,29 @@ ScopedTypeVariables, ExistentialQuantification - Ghc-options: -Wall -fwarn-tabs -fno-warn-orphans - ghc-prof-options: -prof -auto-all + ghc-options: -Wall -fwarn-tabs -fno-warn-orphans + +Test-suite testsuite + hs-source-dirs: src test/src + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + + build-depends: + HUnit >= 1.2 && <1.4, + QuickCheck >= 2.3.0.2, + base, + blaze-builder, + blaze-html, + blaze-markup, + bytestring, + containers, + directory >= 1.0 && <1.3, + parsec, + test-framework >= 0.8.0.3 && <0.9, + test-framework-hunit >= 0.3 && <0.4, + test-framework-quickcheck2 >= 0.3 && <0.4, + text, + unordered-containers + + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind