]> gitweb.michael.orlitzky.com - dead/lwn-epub.git/commitdiff
projects / dead / lwn-epub.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 6789361)
Add link-to-span preprocessing.
authorMichael Orlitzky <michael@orlitzky.com>
Tue, 26 Jun 2012 06:11:23 +0000 (02:11 -0400)
committerMichael Orlitzky <michael@orlitzky.com>
Tue, 26 Jun 2012 06:11:23 +0000 (02:11 -0400)
Add a test for the link preprocessing.

src/LWN/Page.hs patch | blob | history
test/TestSuite.hs patch | blob | history

diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs
index 4d61cfbc5a4f2ad089e852bd13a459f2280f1cbf..24997154eeb84951188d804b6336647c8477a61f 100644 (file)
--- 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 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,
 import Text.XML.HXT.Core (
   ArrowXml,
   IOSArrow,
@@ -20,9 +23,12 @@ import Text.XML.HXT.Core (
   getText,
   hasAttrValue,
   hasName,
   getText,
   hasAttrValue,
   hasName,
+  mkName,
   none,
   none,
+  processAttrl,
   processTopDown,
   runX,
   processTopDown,
   runX,
+  setElemName,
   xshow,
   when
   )
   xshow,
   when
   )
@@ -83,10 +89,21 @@ remove_images =
   processTopDown ((none) `when` is_image)
 
 
   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 =
 -- | 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)
 
 
 parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
@@ -222,7 +239,6 @@ is_image :: (ArrowXml a) => a XmlTree XmlTree
 is_image =
   hasName "img"
 
 is_image =
   hasName "img"
 
-
 remove_title :: (ArrowXml a) => a XmlTree XmlTree
 remove_title =
   processTopDown ((none) `when` is_title)
 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
      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 = "<body><a href=\"#\">Hello, world!</a></body>"
+    input_xml  = parseHtml input_html
+    expected_html = "<body><span>Hello, world!</span></body>"
+    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 76503a353e90b8aefa19fdcc96665cba6eb1b2d1..791408ed7c8a6f3003898669f9380cf9116734b6 100644 (file)
--- 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 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]
 import LWN.URI (uri_tests)
 
 main :: IO ()
 main = defaultMain tests
 
 tests :: [Test.Framework.Test]
-tests = [ uri_tests ]
+tests = [ page_tests,
+          uri_tests ]
(DEAD) Convert issues of LWN (lwn.net) to EPUB format.