xmlbf-xmlhtml 0.1.1 → 0.2

raw patch · 4 files changed

+65/−59 lines, 4 filesdep ~xmlbfPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: xmlbf

API changes (from Hackage documentation)

Files

• ChangeLog.md +16/−0
• lib/Xmlbf/XmlHtml.hs +22/−34
• test/Test.hs +25/−23
• xmlbf-xmlhtml.cabal +2/−2

@@ -1,3 +1,19 @@+# 0.2++* COMPILER ASSISTED BREAKING CHANGE. `element` renamed to+  `fromXmlHtmlNode`.++* COMPILER ASSISTED BREAKING CHANGE. `element'` removed.++* COMPILER ASSISTED BREAKING CHANGE. `nodesXml` renamed to+  `fromRawXml`.++* COMPILER ASSISTED BREAKING CHANGE. `nodesHtml` renamed to+  `fromRawHtml`.++* Made compatible with `xmlbf-0.5`.++ # 0.1.1  * Made compatible with `xmlbf-0.3`.

@@ -1,16 +1,14 @@ {-# LANGUAGE LambdaCase #-}  module Xmlbf.XmlHtml- ( element- , element'- , nodesXml- , nodesHtml+ ( fromXmlHtmlNode+ , fromRawXml+ , fromRawHtml  ) where -import Control.Monad ((>=>)) import qualified Data.ByteString as B import qualified Data.HashMap.Strict as HM-import Data.Maybe (catMaybes)+import qualified Data.Text.Lazy as TL import qualified Text.XmlHtml as XmlHtml import qualified Xmlbf @@ -19,28 +17,18 @@  -- | Convert a 'XmlHtml.Node' from "Text.XmlHtml" into an 'Node' from "Xmlbf", -- if possible.-element-  :: XmlHtml.Node -- ^ A 'XmlHtml.Node' from "Text.XmlHtml".-  -> Either String Xmlbf.Node -- ^ A 'Xmlbf.Node' from "Xmlbf".-element = element' >=> \case-  Just x -> Right x-  Nothing -> Left "Comments not supported"---- | Like 'element', but returns 'Nothing' in case the given node is--- a 'XmlHtml.Comment'. Children 'XmlHtml.Comment's are discarded from the--- result.-element'+fromXmlHtmlNode   :: XmlHtml.Node -- ^ A 'XmlHtml.Node' from "Text.XmlHtml".-  -> Either String (Maybe Xmlbf.Node)-element' = \case-  XmlHtml.Comment _ -> Right Nothing-  XmlHtml.TextNode t -> Right (Just (Xmlbf.text t))+  -> Either String Xmlbf.Node -- ^ A 'Xmlbf.Node' from "Xmlbf", if possible.+fromXmlHtmlNode = \case+  XmlHtml.Comment _ -> Left "Comments not supported"+  XmlHtml.TextNode t -> Xmlbf.text' (TL.fromStrict t)   XmlHtml.Element t as cs -> do-     cs' <- catMaybes <$> traverse element' cs-     Just <$> Xmlbf.element t (HM.fromList as) cs'+    cs' <- traverse fromXmlHtmlNode cs+    Xmlbf.element' t (HM.fromList as) cs' --- | Parses a given UTF8-encoded raw XML fragment into @a@, using the @xeno@--- Haskell library, so all of @xeno@'s parsing quirks apply.+-- | Parses a given UTF8-encoded raw XML fragment into @a@, using the @xmlhtml@+-- Haskell library, so all of @xmlhtml@'s parsing quirks apply. -- -- You can provide the output of this function as input to "Xmlbf"'s -- 'Xmlbf.runParser'.@@ -50,18 +38,18 @@ -- Comments are discarded from the resulting nodes and their children. -- -- Surrounding whitespace is not stripped.-nodesXml+fromRawXml   :: B.ByteString                 -- ^ Raw XML fragment.   -> Either String [Xmlbf.Node]   -- ^ 'Xmlbf.Node's from "Xmlbf"-nodesXml = \bs -> case XmlHtml.parseXML "xmlbf-xmlhtml-input.xml" bs of-  Left e -> Left ("Malformed XML: " ++ show e)-  Right d -> catMaybes <$> traverse element' (XmlHtml.docContent d)+fromRawXml = \bs -> case XmlHtml.parseXML "xmlbf-xmlhtml-input.xml" bs of+  Left e -> Left ("Malformed XML: " ++ e)+  Right d -> traverse fromXmlHtmlNode (XmlHtml.docContent d) --- | Like 'nodesXml', but parses using @xmlhtml@'s quirks HTML mode.-nodesHtml+-- | Like 'fromRawXml', but parses using @xmlhtml@'s quirks HTML mode.+fromRawHtml   :: B.ByteString                 -- ^ Raw HTML fragment.   -> Either String [Xmlbf.Node]   -- ^ 'Xmlbf.Node's from "Xmlbf"-nodesHtml = \bs -> case XmlHtml.parseHTML "xmlbf-xmlhtml-input.html" bs of-  Left e -> Left ("Malformed HTML: " ++ show e)-  Right d -> catMaybes <$> traverse element' (XmlHtml.docContent d)+fromRawHtml = \bs -> case XmlHtml.parseHTML "xmlbf-xmlhtml-input.html" bs of+  Left e -> Left ("Malformed HTML: " ++ e)+  Right d -> traverse fromXmlHtmlNode (XmlHtml.docContent d) 

@@ -33,13 +33,6 @@  -------------------------------------------------------------------------------- --- | Like 'X.element' but it crashes if the result is a 'Left'.-el :: T.Text -> [(T.Text, T.Text)] -> [X.Node] -> X.Node-el t as cs = case X.element t (HM.fromList as) cs of-  Right x -> x-  Left s -> error ("el: Left " ++ show s ++ "\"")-- tt_main :: Tasty.TestTree tt_main =   -- All of the testcases suffixed "-BAD" below are actually undesired results@@ -48,60 +41,69 @@    Tasty.testGroup "main"   [ HU.testCase "1" $ do-     Xx.nodesXml "" @?= Right []+     Xx.fromRawXml "" @?= Right []    , HU.testCase "2-BAD" $ do      -- Leading whitespace droped :(      -- See https://github.com/snapframework/xmlhtml/issues/35-     Xx.nodesXml " " @?= Right []+     Xx.fromRawXml " " @?= Right []    , HU.testCase "3" $ do-     Xx.nodesXml "<foo/>" @?= Right [el "foo" [] []]+     Xx.fromRawXml "<foo/>" @?= Right (X.element "foo" [] [])    , HU.testCase "4" $ do-     Xx.nodesXml "<foo></foo>" @?= Right [el "foo" [] []]+     Xx.fromRawXml "<foo></foo>" @?= Right (X.element "foo" [] [])    , HU.testCase "5-BAD" $ do      -- Leading whitespace droped :(      -- See https://github.com/snapframework/xmlhtml/issues/35-     Xx.nodesXml " <foo></foo>" @?= Right [el "foo" [] []]+     Xx.fromRawXml " <foo></foo>" @?= Right (X.element "foo" [] [])    , HU.testCase "6-BAD" $ do      -- Leading whitespace droped :(      -- See https://github.com/snapframework/xmlhtml/issues/35-     Xx.nodesXml " <foo/>  " @?= Right [el "foo" [] [], "  "]+     Xx.fromRawXml " <foo/>  " @?= Right (X.element "foo" [] [] <> X.text "  ")    , HU.testCase "7" $ do-     Xx.nodesXml "<foo a=\"\"/>" @?= Right [el "foo" [("a", "")] []]+     Xx.fromRawXml "<foo a=\"\"/>" @?= Right (X.element "foo" [("a", "")] [])    , HU.testCase "8" $ do-     Xx.nodesXml "<foo a=\"b\"></foo>" @?= Right [el "foo" [("a", "b")] []]+     Xx.fromRawXml "<foo a=\"b\"></foo>"+       @?= Right (X.element "foo" [("a", "b")] [])    , HU.testCase "9" $ do-     Xx.nodesXml "<foo a=\"b\" c=\"\"/>" @?= Right [el "foo" [("a", "b"), ("c", "")] []]+     Xx.fromRawXml "<foo a=\"b\" c=\"\"/>"+       @?= Right (X.element "foo" [("a", "b"), ("c", "")] [])    , HU.testCase "10" $ do-     Xx.nodesXml "<foo a=\"b\" c=\"d\"/>" @?= Right [el "foo" [("a", "b"), ("c", "d")] []]+     Xx.fromRawXml "<foo a=\"b\" c=\"d\"/>"+       @?= Right (X.element "foo" [("a", "b"), ("c", "d")] [])    , HU.testCase "11" $ do-     Xx.nodesXml "<foo a=\"b\">bar</foo>" @?= Right [el "foo" [("a", "b")] ["bar"]]+     Xx.fromRawXml "<foo a=\"b\">bar</foo>"+       @?= Right (X.element "foo" [("a", "b")] (X.text "bar"))    , HU.testCase "12" $ do-     Xx.nodesXml "<foo a=\"b\"><bar/></foo>" @?= Right [el "foo" [("a", "b")] [el "bar" [] []]]+     Xx.fromRawXml "<foo a=\"b\"><bar/></foo>"+       @?= Right (X.element "foo" [("a", "b")] (X.element "bar" [] []))    , HU.testCase "13" $ do      HU.assertBool "should not parse"-        (isLeft (Xx.nodesXml "<foo>"))+        (isLeft (Xx.fromRawXml "<foo>"))    , HU.testCase "14" $ do      HU.assertBool "should not parse"-        (isLeft (Xx.nodesXml "<foo></bar>"))+        (isLeft (Xx.fromRawXml "<foo></bar>"))    , HU.testCase "15" $ do-     Xx.nodesXml "&lt;foo/&gt;" @?= Right ["<foo/>"]+     Xx.fromRawXml "&lt;foo/&gt;" @?= Right (X.text "<foo/>")    , HU.testCase "16" $ do-     Xx.nodesXml "&amp;lt;" @?= Right ["&lt;"]+     Xx.fromRawXml "&amp;lt;" @?= Right (X.text "&lt;")++  , HU.testCase "17" $ do+     -- Test BOM presence+     Xx.fromRawXml "\xEF\xBB\xBF<foo/>" @?= Xx.fromRawXml "<foo/>"   ]  

@@ -1,5 +1,5 @@ name: xmlbf-xmlhtml-version: 0.1.1+version: 0.2 synopsis: xmlhtml backend support for the xmlbf library. homepage: https://gitlab.com/k0001/xmlbf license: Apache-2.0@@ -24,7 +24,7 @@     html-entities,     text,     unordered-containers,-    xmlbf,+    xmlbf >=0.5,     xmlhtml  test-suite test