diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,9 @@
# Revision history for xml-syntax
-## 0.1.0.0 -- YYYY-mm-dd
+## 0.1.0.1 -- 2024-01-31
-* First version. Released on an unsuspecting world.
+* Updated package metadata.
+
+## 0.1.0.0 -- 2021-10-11
+
+* First version.
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain
diff --git a/src/Xml.hs b/src/Xml.hs
--- a/src/Xml.hs
+++ b/src/Xml.hs
@@ -1,50 +1,52 @@
-{-# language BangPatterns #-}
-{-# language LambdaCase #-}
-{-# language MagicHash #-}
-{-# language NamedFieldPuns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NamedFieldPuns #-}
module Xml
- ( Node(..)
- , Content(..)
- , Attribute(..)
+ ( Node (..)
+ , Content (..)
+ , Attribute (..)
, decode
) where
-import Data.Word (Word8)
+import Data.Builder.ST (Builder)
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 Data.Primitive (SmallArray)
+import Data.Text.Short (ShortText)
+import Data.Word (Word8)
+import GHC.Exts (Char (C#), Char#)
-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.Rebindable as R
import qualified Data.Bytes.Parser.Unsafe as Unsafe
import qualified Data.Bytes.Parser.Utf8 as Utf8
+import qualified Data.Chunks as Chunks
+import qualified Data.Text.Short as TS
+import qualified Data.Text.Short.Unsafe as TS
data Node
= Text !ShortText
| Element {-# UNPACK #-} !Content
- deriving (Show,Eq)
+ deriving (Show, Eq)
data Content = Content
{ tag :: !ShortText
, attributes :: !(SmallArray Attribute)
, children :: !(SmallArray Node)
- } deriving (Show,Eq)
+ }
+ deriving (Show, Eq)
data Attribute = Attribute
{ name :: !ShortText
, value :: !ShortText
- } deriving (Show,Eq)
+ }
+ deriving (Show, Eq)
decode :: Bytes -> Maybe Node
decode !b = Parser.parseBytesMaybe elementNodeParser b
@@ -65,12 +67,12 @@
Latin.any () >>= \case
'>' -> do
nodes <- childrenParser tag
- pure (Element Content{tag,attributes,children=Chunks.concat nodes})
+ pure (Element Content {tag, attributes, children = Chunks.concat nodes})
'/' -> do
Latin.char () '>'
- pure (Element Content{tag,attributes,children=mempty})
+ pure (Element Content {tag, attributes, children = mempty})
_ -> Parser.fail ()
-
+
textNodeParser :: Parser () s Node
textNodeParser = do
raw <- Parser.takeWhile (\w -> w /= 0x3C)
@@ -80,33 +82,35 @@
-- This eats the closing tag as well.
childrenParser ::
- ShortText -- opening tag name, looking for a closing tag that matches
- -> Parser () s (Chunks Node)
+ 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)
+ 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 2
- node <- elementNodeParser
+ Unsafe.unconsume 1
+ node <- textNodeParser
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
@@ -147,7 +151,7 @@
Latin.char () '='
Parser.skipWhile isXmlSpace
!value <- parserAttributeValue
- pure Attribute{name,value}
+ pure Attribute {name, value}
-- TODO: This is woefully incomplete
parserAttributeValue :: Parser () s ShortText
@@ -166,14 +170,14 @@
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)
-
+ Utf8.any# () R.>>= \c ->
+ Unsafe.jump pos R.>>= \_ ->
+ R.pure (isNameStartChar c)
+
isNameStartChar :: Char# -> Bool
isNameStartChar c = case C# c of
':' -> True
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,89 +1,87 @@
-{-# language BangPatterns #-}
-{-# language MultiWayIf #-}
-{-# language NumDecimals #-}
-{-# language OverloadedLists #-}
-{-# language OverloadedStrings #-}
-{-# language ScopedTypeVariables #-}
-{-# language TypeApplications #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
import Xml
-import Test.Tasty (defaultMain,testGroup,TestTree)
-import Test.Tasty.HUnit ((@=?),testCase)
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.HUnit (testCase, (@=?))
-import qualified Data.Bytes as Bytes
+import qualified Data.Bytes.Text.Ascii as Ascii
main :: IO ()
main = defaultMain tests
decodeString :: String -> Maybe Node
-decodeString = Xml.decode . Bytes.fromAsciiString
+decodeString = Xml.decode . Ascii.fromString
tests :: TestTree
-tests = testGroup "xml"
- [ testCase "A" $
- Just
- ( Element Content
- { tag = "foo"
- , attributes = mempty
- , children = [Text "hello"]
- }
- )
- @=?
- decodeString "hello"
- , testCase "B" $
- Just
- ( Element Content
- { tag = "foo"
- , attributes = [Attribute "bar" "baz"]
- , children = [Text "hi"]
- }
- )
- @=?
- decodeString "hi"
- , testCase "C" $
- Just
- ( Element Content
- { tag = "foo"
- , attributes = [Attribute "bar" "baz"]
- , children = [Text "hi"]
- }
- )
- @=?
- decodeString "hi"
- , testCase "D" $
- Just
- ( Element Content
- { tag = "foo"
- , attributes = [Attribute "bar" "baz"]
- , children = mempty
- }
- )
- @=?
- decodeString ""
- , testCase "E" $
- Just
- ( Element Content
- { tag = "foo"
- , attributes = mempty
- , children = [Text "hello"]
- }
- )
- @=?
- decodeString "hello"
- , 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 "