xml-syntax (empty) → 0.1.0.0
raw patch · 6 files changed
+352/−0 lines, 6 filesdep +array-builderdep +array-chunksdep +basesetup-changed
Dependencies added: array-builder, array-chunks, base, bytebuild, byteslice, bytesmith, bytestring, primitive, tasty, tasty-hunit, text-short, xml-syntax
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Xml.hs +183/−0
- test/Main.hs +89/−0
- xml-syntax.cabal +43/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for xml-syntax++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrew Martin nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Xml.hs view
@@ -0,0 +1,183 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}++module Xml+ ( Node(..)+ , Content(..)+ , Attribute(..)+ , decode+ ) where++import Data.Word (Word8)+import Data.Bytes (Bytes)+import Data.Text.Short (ShortText)+import Data.Primitive (SmallArray)+import Data.Bytes.Parser (Parser)+import GHC.Exts (Char(C#),Char#)+import Data.Chunks (Chunks)+import Data.Builder.ST (Builder)++import qualified Data.Chunks as Chunks+import qualified Data.Text.Short as TS+import qualified Data.Text.Short.Unsafe as TS+import qualified Data.Builder.ST as Builder+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Parser as Parser+import qualified Data.Bytes.Parser.Rebindable as R+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Bytes.Parser.Unsafe as Unsafe+import qualified Data.Bytes.Parser.Utf8 as Utf8++data Node+ = Text !ShortText+ | Element {-# UNPACK #-} !Content+ deriving (Show,Eq)++data Content = Content+ { tag :: !ShortText+ , attributes :: !(SmallArray Attribute)+ , children :: !(SmallArray Node)+ } deriving (Show,Eq)++data Attribute = Attribute+ { name :: !ShortText+ , value :: !ShortText+ } deriving (Show,Eq)++decode :: Bytes -> Maybe Node+decode !b = Parser.parseBytesMaybe elementNodeParser b++elementNodeParser :: Parser () s Node+elementNodeParser = do+ Latin.char () '<'+ btag <- Parser.takeWhile (\w -> not (isXmlSpace w) && w /= 0x3E && w /= 0x2F)+ case Bytes.length btag of+ 0 -> Parser.fail ()+ _ -> pure ()+ tag <- case TS.fromShortByteString (Bytes.toShortByteStringClone btag) of+ Nothing -> Parser.fail ()+ Just ttag -> pure ttag+ -- Note that parserAttributes consumes leading and trailing whitespace.+ attrs <- parserAttributes =<< Parser.effect Builder.new+ let !attributes = Chunks.concat attrs+ Latin.any () >>= \case+ '>' -> do+ nodes <- childrenParser tag+ pure (Element Content{tag,attributes,children=Chunks.concat nodes})+ '/' -> do+ Latin.char () '>'+ pure (Element Content{tag,attributes,children=mempty})+ _ -> Parser.fail ()+ +textNodeParser :: Parser () s Node+textNodeParser = do+ raw <- Parser.takeWhile (\w -> w /= 0x3C)+ case Bytes.any (\w -> w > 0x7F || w == 0x26) raw of+ True -> Parser.fail () -- TODO: escape or check UTF-8 encoding here instead+ False -> pure (Text (TS.fromShortByteStringUnsafe (Bytes.toShortByteStringClone raw)))++-- This eats the closing tag as well.+childrenParser ::+ ShortText -- opening tag name, looking for a closing tag that matches+ -> Parser () s (Chunks Node)+childrenParser !tag = do+ b0 <- Parser.effect Builder.new+ childrenParserLoop tag b0++childrenParserLoop ::+ ShortText -- opening tag name, looking for a closing tag that matches+ -> Builder s Node+ -> Parser () s (Chunks Node)+childrenParserLoop !tag !b0 = Latin.any () >>= \case+ '<' -> Latin.any () >>= \case+ '/' -> do+ Utf8.shortText () tag+ Parser.skipWhile isXmlSpace+ Latin.char () '>'+ Parser.effect (Builder.freeze b0)+ _ -> do+ Unsafe.unconsume 2+ node <- elementNodeParser+ b1 <- Parser.effect (Builder.push node b0)+ childrenParserLoop tag b1+ _ -> do+ Unsafe.unconsume 1+ node <- textNodeParser+ b1 <- Parser.effect (Builder.push node b0)+ childrenParserLoop tag b1++isXmlSpace :: Word8 -> Bool+isXmlSpace = \case+ 0x20 -> True+ 0x09 -> True+ 0x0D -> True+ 0x0A -> True+ _ -> False++parserAttributes :: Builder s Attribute -> Parser () s (Chunks Attribute)+parserAttributes !b0 = do+ Parser.skipWhile isXmlSpace+ peekIsNameStartChar >>= \case+ True -> do+ attr <- parserAttribute+ b1 <- Parser.effect (Builder.push attr b0)+ parserAttributes b1+ False -> do+ Parser.skipWhile isXmlSpace+ Parser.effect (Builder.freeze b0)++-- From the spec, we have:+-- Attribute ::= Name Eq AttValue+-- Eq ::= S? '=' S?+-- Name ::= NameStartChar (NameChar)*+--+-- Precondition A: The first character is a NameStartChar. This parser+-- does not check this.+parserAttribute :: Parser () s Attribute+parserAttribute = do+ bname <- Parser.takeWhile (\w -> not (isXmlSpace w) && w /= 0x3D)+ -- We may assume that length of bname is at least one because of+ -- precondition A.+ !name <- case TS.fromShortByteString (Bytes.toShortByteStringClone bname) of+ Nothing -> Parser.fail ()+ Just tname -> pure tname+ Parser.skipWhile isXmlSpace+ Latin.char () '='+ Parser.skipWhile isXmlSpace+ !value <- parserAttributeValue+ pure Attribute{name,value}++-- TODO: This is woefully incomplete+parserAttributeValue :: Parser () s ShortText+parserAttributeValue = do+ Latin.any () >>= \case+ '"' -> do+ bval <- Parser.takeWhile (\w -> w /= 0x22)+ Latin.char () '"'+ case TS.fromShortByteString (Bytes.toShortByteStringClone bval) of+ Nothing -> Parser.fail ()+ Just tval -> pure tval+ '\'' -> do+ bval <- Parser.takeWhile (\w -> w /= 0x27)+ Latin.char () '\''+ case TS.fromShortByteString (Bytes.toShortByteStringClone bval) of+ Nothing -> Parser.fail ()+ Just tval -> pure tval+ _ -> Parser.fail ()+ +peekIsNameStartChar :: Parser () s Bool+peekIsNameStartChar =+ Unsafe.cursor R.>>= \pos ->+ Utf8.any# () R.>>= \c -> + Unsafe.jump pos R.>>= \_ ->+ R.pure (isNameStartChar c)+ +isNameStartChar :: Char# -> Bool+isNameStartChar c = case C# c of+ ':' -> True+ '_' -> True+ _ | C# c >= 'A' && C# c <= 'Z' -> True+ _ | C# c >= 'a' && C# c <= 'z' -> True+ _ -> False
+ test/Main.hs view
@@ -0,0 +1,89 @@+{-# language BangPatterns #-}+{-# language MultiWayIf #-}+{-# language NumDecimals #-}+{-# language OverloadedLists #-}+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++import Xml++import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.Tasty.HUnit ((@=?),testCase)++import qualified Data.Bytes as Bytes++main :: IO ()+main = defaultMain tests++decodeString :: String -> Maybe Node+decodeString = Xml.decode . Bytes.fromAsciiString++tests :: TestTree+tests = testGroup "xml"+ [ testCase "A" $+ Just+ ( Element Content+ { tag = "foo"+ , attributes = mempty+ , children = [Text "hello"]+ }+ )+ @=?+ decodeString "<foo>hello</foo>"+ , testCase "B" $+ Just+ ( Element Content+ { tag = "foo"+ , attributes = [Attribute "bar" "baz"]+ , children = [Text "hi"]+ }+ )+ @=?+ decodeString "<foo bar='baz'>hi</foo>"+ , testCase "C" $+ Just+ ( Element Content+ { tag = "foo"+ , attributes = [Attribute "bar" "baz"]+ , children = [Text "hi"]+ }+ )+ @=?+ decodeString "<foo bar=\"baz\">hi</foo>"+ , testCase "D" $+ Just+ ( Element Content+ { tag = "foo"+ , attributes = [Attribute "bar" "baz"]+ , children = mempty+ }+ )+ @=?+ decodeString "<foo bar=\"baz\"/>"+ , testCase "E" $+ Just+ ( Element Content+ { tag = "foo"+ , attributes = mempty+ , children = [Text "hello"]+ }+ )+ @=?+ decodeString "<foo >hello</foo>"+ , testCase "F" $+ Just+ ( Element Content+ { tag = "foo"+ , attributes = [Attribute "bar" "baz"]+ , children =+ [ Text " "+ , Element Content{tag="hey",attributes=mempty,children=mempty}+ , Text " "+ , Element Content{tag="hi",attributes=mempty,children=mempty}+ ]+ }+ )+ @=?+ decodeString "<foo bar=\"baz\"> <hey/> <hi></hi></foo>"+ ]
+ xml-syntax.cabal view
@@ -0,0 +1,43 @@+cabal-version: 2.4+name: xml-syntax+synopsis: Parse XML from bytes+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2020 Andrew Martin+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md++library+ exposed-modules: Xml+ build-depends:+ , array-builder >=0.1 && <0.2+ , array-chunks >=0.1.1 && <0.2+ , base >=4.12 && <5+ , bytebuild >=0.3.4 && <0.4+ , byteslice >=0.2.6 && <0.3+ , bytesmith >=0.3.8 && <0.4+ , bytestring >=0.10.8 && <0.11+ , primitive >=0.7 && <0.8+ , text-short >=0.1.3 && <0.2+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -O2++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -Wall -O2+ build-depends:+ , base >=4.11.1 && <5+ , byteslice+ , bytestring+ , primitive+ , tasty+ , tasty-hunit+ , xml-syntax