From d79424c546d96dcd3955fdc6cb43eb529566be1e Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Tue, 26 Jun 2012 02:11:23 -0400 Subject: [PATCH] Add link-to-span preprocessing. Add a test for the link preprocessing. --- src/LWN/Page.hs | 46 ++++++++++++++++++++++++++++++++++++++++++++-- test/TestSuite.hs | 4 +++- 2 files changed, 47 insertions(+), 3 deletions(-) diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs index 4d61cfb..2499715 100644 --- a/src/LWN/Page.hs +++ b/src/LWN/Page.hs @@ -8,6 +8,9 @@ import qualified Data.ByteString.Lazy as B (ByteString, hPut) import Data.String.Utils (split, strip) import Data.Maybe (catMaybes, fromJust, isNothing) import Data.Tree.NTree.TypeDefs (NTree) +import Test.HUnit (Assertion, assertEqual) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) import Text.XML.HXT.Core ( ArrowXml, IOSArrow, @@ -20,9 +23,12 @@ import Text.XML.HXT.Core ( getText, hasAttrValue, hasName, + mkName, none, + processAttrl, processTopDown, runX, + setElemName, xshow, when ) @@ -83,10 +89,21 @@ remove_images = processTopDown ((none) `when` is_image) +is_link :: (ArrowXml a) => a XmlTree XmlTree +is_link = + hasName "a" + +replace_links_with_spans :: (ArrowXml a) => a XmlTree XmlTree +replace_links_with_spans = + processTopDown $ (make_span >>> remove_attrs) `when` is_link + where + make_span = setElemName $ mkName "span" + remove_attrs = processAttrl none + -- | Preprocessing common to both page types. preprocess :: IOSArrow XmlTree (NTree XNode) -> IOSArrow XmlTree (NTree XNode) preprocess xml = - xml >>>remove_images + xml >>> remove_images >>> replace_links_with_spans parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page) @@ -222,7 +239,6 @@ is_image :: (ArrowXml a) => a XmlTree XmlTree is_image = hasName "img" - remove_title :: (ArrowXml a) => a XmlTree XmlTree remove_title = processTopDown ((none) `when` is_title) @@ -327,3 +343,29 @@ xhtml_to_epub epmd = my_writer_options = defaultWriterOptions { writerEPUBMetadata = epmd } write_epub = writeEPUB Nothing [] my_writer_options read_html = readHtml defaultParserState + + + + +test_preprocess_links :: Assertion +test_preprocess_links = do + actual_xml' <- runX $ (preprocess input_xml) >>> css "body" + let actual_xml = actual_xml' !! 0 + + expected_xml' <- runX $ expected_xml'' >>> css "body" + let expected_xml = expected_xml' !! 0 + + assertEqual + "Links are replaced with spans" + expected_xml + actual_xml + where + input_html = "Hello, world!" + input_xml = parseHtml input_html + expected_html = "Hello, world!" + expected_xml'' = parseHtml expected_html + +page_tests :: Test +page_tests = + testGroup "Page Tests" [ + testCase "Links are replaced with spans" test_preprocess_links ] diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 76503a3..791408e 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -15,10 +15,12 @@ import Test.Framework.Runners.Options import Test.Framework.Providers.API (TestName) import Test.HUnit +import LWN.Page (page_tests) import LWN.URI (uri_tests) main :: IO () main = defaultMain tests tests :: [Test.Framework.Test] -tests = [ uri_tests ] +tests = [ page_tests, + uri_tests ] -- 2.43.2