xml-types-content (empty) → 0.0.1
raw patch · 5 files changed
+278/−0 lines, 5 filesdep +QuickCheckdep +basedep +hspec
Dependencies added: QuickCheck, base, hspec, lawful-conversions, rerebase, text, text-builder-dev, xml-conduit, xml-types, xml-types-content
Files
- LICENSE +22/−0
- src/hspec/Main.hs +1/−0
- src/hspec/XmlTypesContentSpec.hs +90/−0
- src/library/XmlTypesContent.hs +95/−0
- xml-types-content.cabal +70/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2024 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ src/hspec/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/hspec/XmlTypesContentSpec.hs view
@@ -0,0 +1,90 @@+module XmlTypesContentSpec (spec) where++import qualified Data.ByteString.Lazy+import qualified Data.Text as Text+import Data.XML.Types+import LawfulConversions+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Property+import qualified Text.XML+import qualified Text.XML.Stream.Parse+import qualified Text.XML.Unresolved+import qualified XmlTypesContent+import Prelude++spec :: Spec+spec = do+ describe "textNodes" do+ prop "Produces nodes that decode to the source" do+ -- For some reason xml-conduit remaps '\r' to '\n', so we simply work around that.+ text <- suchThat arbitrary (not . elem '\r' . Text.unpack)+ pure case extractTextContentFromXml (textXml text) of+ Right decodedText ->+ if decodedText == text+ then succeeded+ else failed {Test.QuickCheck.Property.reason}+ where+ reason =+ [ show text,+ "\n =/=\n",+ show decodedText,+ "\nXML:\n",+ to @_ @Text (from (textXml text))+ ]+ & mconcat+ Left parsingErr ->+ failed {Test.QuickCheck.Property.reason}+ where+ reason =+ [ "Failed to parse due to: ",+ parsingErr,+ "\n",+ "XML:\n",+ from (textXml text)+ ]+ & mconcat+ & to++textXml :: Text -> Data.ByteString.Lazy.ByteString+textXml = nodesXml . fmap NodeContent . XmlTypesContent.textContents++nodesXml :: [Data.XML.Types.Node] -> Data.ByteString.Lazy.ByteString+nodesXml =+ buildLbs . buildDocument . buildRootElement+ where+ buildRootElement elementNodes =+ Data.XML.Types.Element+ { elementName = "a",+ elementAttributes = [],+ elementNodes+ }+ buildDocument documentRoot =+ Data.XML.Types.Document+ { documentPrologue =+ Data.XML.Types.Prologue [] Nothing [],+ documentEpilogue =+ [],+ documentRoot+ }+ buildLbs =+ Text.XML.Unresolved.renderLBS Text.XML.Unresolved.def++extractTextContentFromXml :: Data.ByteString.Lazy.ByteString -> Either Text Text+extractTextContentFromXml = parseLbs >=> parseAst+ where+ parseLbs =+ first (fromString . displayException) . Text.XML.parseLBS settings+ where+ settings =+ Text.XML.def+ { Text.XML.Stream.Parse.psDecodeIllegalCharacters = Just . chr+ }+ parseAst =+ parseNodes . Text.XML.elementNodes . Text.XML.documentRoot+ where+ parseNodes = \case+ [Text.XML.NodeContent content] -> pure content+ [] -> pure ""+ _ -> Left "Invalid nodes"
+ src/library/XmlTypesContent.hs view
@@ -0,0 +1,95 @@+module XmlTypesContent+ ( textContents,+ )+where++import Data.Char+import Data.Function+import Data.Text (Text)+import qualified Data.Text as Text+import Data.XML.Types+import qualified TextBuilderDev+import Prelude++-- |+-- Convert 'Text' into 'Content' list, escaping undefined Unicode chars as described in https://www.w3.org/TR/xml11/#charsets.+textContents :: Text -> [Content]+textContents text =+ case Text.span charNeedsNoEscaping text of+ (prefix, remainder) ->+ if Text.null prefix+ then entityAndTail+ else ContentText prefix : entityAndTail+ where+ entityAndTail =+ case Text.uncons remainder of+ Nothing -> []+ Just (charToEscape, nextText) ->+ charEntityContent charToEscape : textContents nextText++charEntityContent :: Char -> Content+charEntityContent = ContentEntity . codepointEntityText . ord++codepointEntityText :: Int -> Text+codepointEntityText = \case+ 62 -> "gt"+ 60 -> "lt"+ 38 -> "amp"+ 34 -> "quot"+ 39 -> "apos"+ codepoint -> codepointDecimalEntityText codepoint++codepointDecimalEntityText :: Int -> Text+codepointDecimalEntityText codepoint =+ TextBuilderDev.fromTextBuilder ("#" <> TextBuilderDev.unsignedDecimal codepoint)++charNeedsNoEscaping :: Char -> Bool+charNeedsNoEscaping = codepointNeedsNoEscaping . ord++codepointNeedsNoEscaping :: Int -> Bool+codepointNeedsNoEscaping codepoint =+ isNotControl && isNotUndefined+ where+ isNotControl =+ not (elem codepoint controlCodepoints)+ isNotUndefined =+ undefinedUnicodeRanges+ & fmap (\(a, b) -> codepoint < a || b < codepoint)+ & and++controlCodepoints :: [Int]+controlCodepoints =+ [ 62, -- >+ 60, -- <+ 38, -- &+ 34, -- "+ 39 -- '+ ]++-- |+-- Source: https://www.w3.org/TR/xml11/#charsets.+undefinedUnicodeRanges :: [(Int, Int)]+undefinedUnicodeRanges =+ [ (0x1, 0x8),+ (0xB, 0xC),+ (0xE, 0x1F),+ (0x7F, 0x84),+ (0x86, 0x9F),+ (0xFDD0, 0xFDDF),+ (0x1FFFE, 0x1FFFF),+ (0x2FFFE, 0x2FFFF),+ (0x3FFFE, 0x3FFFF),+ (0x4FFFE, 0x4FFFF),+ (0x5FFFE, 0x5FFFF),+ (0x6FFFE, 0x6FFFF),+ (0x7FFFE, 0x7FFFF),+ (0x8FFFE, 0x8FFFF),+ (0x9FFFE, 0x9FFFF),+ (0xAFFFE, 0xAFFFF),+ (0xBFFFE, 0xBFFFF),+ (0xCFFFE, 0xCFFFF),+ (0xDFFFE, 0xDFFFF),+ (0xEFFFE, 0xEFFFF),+ (0xFFFFE, 0xFFFFF),+ (0x10FFFE, 0x10FFFF)+ ]
+ xml-types-content.cabal view
@@ -0,0 +1,70 @@+cabal-version: 3.0+name: xml-types-content+version: 0.0.1+synopsis: Utilities for dealing with Content-values of "xml-types"+description:+ The `Content` type in "xml-types" is tricky and naive usage of it can lead to bugs.+ You cannot simply construct `ContentText` from any textual value.+ You must encode certain character ranges via entities.+ This library does that for you by providing mappers from `Text` to `[Content]`.++homepage: https://github.com/nikita-volkov/xml-types-content+bug-reports: https://github.com/nikita-volkov/xml-types-content/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2024 Nikita Volkov+license: MIT+license-file: LICENSE++source-repository head+ type: git+ location: git://github.com/nikita-volkov/xml-types-content.git++common base+ default-language: Haskell2010+ default-extensions:+ BlockArguments+ DefaultSignatures+ FlexibleContexts+ FlexibleInstances+ LambdaCase+ MagicHash+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ UndecidableSuperClasses++library+ import: base+ hs-source-dirs: src/library+ exposed-modules:+ XmlTypesContent++ build-depends:+ base >=4.13 && <5,+ text >=1.2 && <3,+ text-builder-dev ^>=0.3.9,+ xml-types ^>=0.3.8,++test-suite hspec+ import: base+ type: exitcode-stdio-1.0+ hs-source-dirs: src/hspec+ main-is: Main.hs+ other-modules:+ XmlTypesContentSpec++ build-tool-depends:+ hspec-discover:hspec-discover >=2 && <3++ build-depends:+ QuickCheck >=2.13 && <3,+ hspec >=2.11 && <3,+ lawful-conversions ^>=0.1.5,+ rerebase >=1 && <2,+ xml-conduit ^>=1.9,+ xml-types ^>=0.3.8,+ xml-types-content,