packages feed

xmlbf-xeno 0.1.1 → 0.2

raw patch · 4 files changed

+65/−43 lines, 4 filesdep ~xmlbf

Dependency ranges changed: xmlbf

Files

ChangeLog.md view
@@ -1,3 +1,14 @@+# 0.2++* COMPILER ASSISTED BREAKING CHANGE. Renamed `element` to `fromXenoNode`.++* COMPILER ASSISTED BREAKING CHANGE. Renamed `nodes` to `fromRawXml`.++* Made compatible with `xmlbf-0.5`.++* Leading UTF-8 BOM safely dealt with in `fromRawXml`. See issue #20.++ # 0.1.1  * Made compatible with `xmlbf-0.3`.
lib/Xmlbf/Xeno.hs view
@@ -2,8 +2,8 @@ {-# LANGUAGE OverloadedStrings #-}  module Xmlbf.Xeno- ( element- , nodes+ ( fromXenoNode+ , fromRawXml  ) where  import qualified Data.Bifunctor as Bif@@ -23,18 +23,18 @@ -- Xeno support  -- | Convert a 'Xeno.Node' from "Xeno.DOM" into an 'Element' from "Xmlbf".-element+fromXenoNode   :: Xeno.Node -- ^ A 'Xeno.Node' from "Xeno.DOM".   -> Either String Xmlbf.Node -- ^ A 'Xmlbf.Node' from "Xmlbf".-element x = do+fromXenoNode x = do   n <- decodeUtf8 (Xeno.name x)   as <- for (Xeno.attributes x) $ \(k,v) -> do      (,) <$> decodeUtf8 k <*> unescapeXmlUtf8 v   cs <- for (Xeno.contents x) $ \case-     Xeno.Element n1 -> element n1-     Xeno.Text bs -> Xmlbf.text <$> unescapeXmlUtf8 bs-     Xeno.CData bs -> Xmlbf.text <$> decodeUtf8 bs-  Xmlbf.element n (HM.fromList as) cs+     Xeno.Element n1 -> fromXenoNode n1+     Xeno.Text bs -> Xmlbf.text' =<< unescapeXmlUtf8Lazy bs+     Xeno.CData bs -> Xmlbf.text' =<< decodeUtf8Lazy bs+  Xmlbf.element' n (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.@@ -45,12 +45,12 @@ -- The given XML can contain more zero or more text or element nodes. -- -- Surrounding whitespace is not stripped.-nodes+fromRawXml   :: B.ByteString                 -- ^ Raw XML fragment.   -> Either String [Xmlbf.Node]   -- ^ 'Xmlbf.Node's from "Xmlbf"-nodes = \bs -> case Xeno.parse ("<x>" <> bs <> "</x>") of+fromRawXml = \bs -> case Xeno.parse ("<x>" <> dropBomUtf8 bs <> "</x>") of   Left e -> Left ("Malformed XML: " ++ show e)-  Right n -> element n >>= \(Xmlbf.Element "x" _ cs) -> pure cs+  Right n -> fromXenoNode n >>= \(Xmlbf.Element "x" _ cs) -> pure cs  -------------------------------------------------------------------------------- --------------------------------------------------------------------------------@@ -60,12 +60,21 @@ {-# INLINE decodeUtf8 #-} decodeUtf8 bs = Bif.first show (T.decodeUtf8' bs) -unescapeXmlText :: T.Text -> T.Text-{-# INLINE unescapeXmlText #-}-unescapeXmlText = \t ->-  TL.toStrict (TB.toLazyText (HTMLEntities.Decoder.htmlEncodedText t))+decodeUtf8Lazy :: B.ByteString -> Either String TL.Text+{-# INLINE decodeUtf8Lazy #-}+decodeUtf8Lazy bs = fmap TL.fromStrict (decodeUtf8 bs)  unescapeXmlUtf8 :: B.ByteString -> Either String T.Text {-# INLINE unescapeXmlUtf8 #-}-unescapeXmlUtf8 bs = fmap unescapeXmlText (decodeUtf8 bs)+unescapeXmlUtf8 bs = fmap TL.toStrict (unescapeXmlUtf8Lazy bs) +unescapeXmlUtf8Lazy :: B.ByteString -> Either String TL.Text+{-# INLINE unescapeXmlUtf8Lazy #-}+unescapeXmlUtf8Lazy bs = do+   t <- decodeUtf8 bs+   pure (TB.toLazyText (HTMLEntities.Decoder.htmlEncodedText t))++dropBomUtf8 :: B.ByteString -> B.ByteString+{-# INLINE dropBomUtf8 #-}+dropBomUtf8 bs | B.isPrefixOf "\xEF\xBB\xBF" bs = B.drop 3 bs+               | otherwise = bs
test/Test.hs view
@@ -32,13 +32,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@@ -47,57 +40,66 @@    Tasty.testGroup "main"   [ HU.testCase "1" $ do-     Xx.nodes "" @?= Right []+     Xx.fromRawXml "" @?= Right []    , HU.testCase "2" $ do-     Xx.nodes " " @?= Right [X.text " "]+     Xx.fromRawXml " " @?= Right (X.text " ")    , HU.testCase "3" $ do-     Xx.nodes "<foo/>" @?= Right [el "foo" [] []]+     Xx.fromRawXml "<foo/>" @?= Right (X.element "foo" [] [])    , HU.testCase "4" $ do-     Xx.nodes "<foo></foo>" @?= Right [el "foo" [] []]+     Xx.fromRawXml "<foo></foo>" @?= Right (X.element "foo" [] [])    , HU.testCase "5" $ do-     Xx.nodes " <foo></foo>" @?= Right [X.text " ", el "foo" [] []]+     Xx.fromRawXml " <foo></foo>" @?= Right (X.text " " <> X.element "foo" [] [])    , HU.testCase "6" $ do-     Xx.nodes " <foo/>  " @?= Right [X.text " ", el "foo" [] [], "  "]+     Xx.fromRawXml " <foo/>  "+       @?= Right (X.text " " <> X.element "foo" [] [] <> X.text "  ")    , HU.testCase "7" $ do-     Xx.nodes "<foo a=\"\"/>" @?= Right [el "foo" [("a", "")] []]+     Xx.fromRawXml "<foo a=\"\"/>" @?= Right (X.element "foo" [("a", "")] [])    , HU.testCase "8" $ do-     Xx.nodes "<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.nodes "<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.nodes "<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.nodes "<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.nodes "<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-BAD" $ do-     -- This should return on either a 'Left', or a @'Right' [el "foo" [] []]@.-     -- The reason why it doesn't is because 'Xx.nodes' wraps @"<foo>"@ as+     -- This should return on either a 'Left', or a @'Right' [X.element "foo" [] []]@.+     -- The reason why it doesn't is because 'Xx.fromRawXml' wraps @"<foo>"@ as      -- @"<x><foo></x>"@ before parsing, which causes the @x@ element to be      -- successfully parsed, but not the inner @foo@. This is a problem in Xeno.-     Xx.nodes "<foo>" @?= Right []+     Xx.fromRawXml "<foo>" @?= Right []    , HU.testCase "14-BAD" $ do      -- Similar to test case 13-BAD. This is wrong, but it is what Xeno returns.-     Xx.nodes "<foo></bar>" @?= Right [el "foo" [] []]+     Xx.fromRawXml "<foo></bar>" @?= Right (X.element "foo" [] [])    , HU.testCase "15" $ do-     Xx.nodes "&lt;foo/&gt;" @?= Right ["<foo/>"]+     Xx.fromRawXml "&lt;foo/&gt;" @?= Right (X.text "<foo/>")    , HU.testCase "16" $ do-     Xx.nodes "&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/>"   ]
xmlbf-xeno.cabal view
@@ -1,5 +1,5 @@ name: xmlbf-xeno-version: 0.1.1+version: 0.2 synopsis: xeno backend support for the xmlbf library. homepage: https://gitlab.com/k0001/xmlbf license: Apache-2.0@@ -25,7 +25,7 @@     text,     unordered-containers,     xeno,-    xmlbf+    xmlbf >=0.5  test-suite test   default-language: Haskell2010