Merge pull request #2 from EggBaconAndSpam/rewrite

Major rewrite / cleanup

package.yaml

@@ -1,17 +1,18 @@
 name:                structural-xml
-version:             0.1.0.0
-description:         Structural parsing and generation of XML data.
+version:             0.2.0.0
+description:         Structural XML parsing and unparsing.
 license:             BSD3
 license-file:        LICENSE
-copyright:           (c) 2022 Frederik Ramcke, Eir Försäkring AB
-author:              Federik Ramcke <[email protected]>
+copyright:           (c) 2023 Frederik Ramcke, Eir Försäkring AB
+author:              Frederik Ramcke <[email protected]>
 
 dependencies:
 - base >= 4.7 && < 5
 - containers
 - text
 - xml-conduit
 - mtl
+- bytestring
 
 default-extensions:
 - DeriveGeneric
@@ -27,6 +28,10 @@ default-extensions:
 - StandaloneDeriving
 - TypeApplications
 - RecordWildCards
+- StrictData
+- DuplicateRecordFields
+- FlexibleInstances
+- NamedFieldPuns
 
 ghc-options:
 - -Weverything

src/Data/XML.hs

@@ -1,38 +1,166 @@
+{-
+How to use this library
+  TODO!
+
+Decoding and encoding XML documents
+    decodeDocument, encodeDocument, decodeDocumentLT, encodeDocumentLT, decodeDocumentBS, encodeDocumentBS, decodeDocumentLBS, encodeDocumentLBS,
+
+Deriving via helpers for Read and Show
+ReadShowXmlDocument, ReadShowXmlElement
+
+Representing XML
+
+    XML document types
+    AnnotatedDocument, AnnotatedElement, AnnotatedNode, Document, Element, Node, unAnnotateDocument, emptyElement, isEmptyElement
+
+    helpers
+    renderName, stripAllWhitespaceContent, stripAllWhitespaceContent', stripAllNamespaces, stripAllNamespaces',
+
+    Conversion to and from xml-conduit types
+    fromXmlConduit, fromXmlConduitKeepWhitespaceContent, fromXmlConduitElement, toXmlConduit, toXmlConduitElement
+
+Parsing and Unparsing XML
+
+    newtype wrappers
+    ContentElement, OrEmpty
+
+    Unparsing
+
+        Classes
+        ToDocument, toRootElement, ToElement, ToContent, ToChoiceElement
+
+        Constructing elements
+        ConstructM, constructElement, appendContent, appendElement, appendElementOrEmpty, appendChoiceElement,addAttribute,
+
+    Parsing
+
+        Parser, ParserError, prettyParserError, prettyParserErrorWithCallStack
+
+        Classes
+        FromDocument, fromRootElement, FromElement, FromChoiceElement (..), FromContent, readContent
+
+        Parsing content and attributes
+        parseContentElement, parseContentElementPartially, parseContentElementKeepLeftovers,
+
+        Parsing Ordered elements (c.f. 'sequence')
+        -> Data.XML.Parse.Ordered
+
+        Parsing Unordered elements (c.f. 'sequence')
+        -> Data.XML.Parse.Unordered
+
+-}
 module Data.XML
-  ( module Data.XML.Types,
-    module Data.XML.Serialisation,
-    module Data.XML.Deserialisation,
-    module Data.XML.Helpers.QuotedXML,
-    module Data.XML.Helpers.ContentElement,
-    parseDocument,
-    parseDocument',
-    unsafeParseDocument,
-    unparseDocument,
+  ( -- * Re-exports. TODO: Explicit re-exports!
+    module Data.XML.Types,
+    module Data.XML.Parse.Types,
+    module Data.XML.Parse.Location,
+    module Data.XML.Unparse,
+
+    -- * Decoding and encoding XML documents
+    decodeDocument,
+    encodeDocument,
+    decodeDocumentLT,
+    encodeDocumentLT,
+    decodeDocumentBS,
+    encodeDocumentBS,
+    decodeDocumentLBS,
+    encodeDocumentLBS,
+
+    -- * @deriving via@ helpers for @Read@ and @Show@ instances
+    ReadShowXmlDocument (..),
+    ReadShowXmlElement (..),
   )
 where
 
+import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy as ByteString.Lazy
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Data.Text.Lazy as Text (fromStrict, toStrict)
-import Data.XML.Deserialisation
-import Data.XML.Helpers.ContentElement
-import Data.XML.Helpers.QuotedXML
-import Data.XML.Serialisation
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy as Text.Lazy
+import Data.XML.Parse.Location
+import Data.XML.Parse.Types
 import Data.XML.Types
-import qualified Text.XML as XC
+import Data.XML.Unparse
+import GHC.Stack
+import Text.XML (def, parseLBS, parseText, renderLBS, renderText, rsPretty, rsXMLDeclaration)
+
+decodeDocument :: (HasCallStack, FromDocument a) => Text -> Either String a
+decodeDocument raw = case parseText def (Text.Lazy.fromStrict raw) of
+  Left err -> Left $ show err
+  Right conduitDoc ->
+    first prettyParserError . fromDocument . annotateDocument $
+      fromXmlConduit conduitDoc
+
+decodeDocumentLT :: (HasCallStack, FromDocument a) => LT.Text -> Either String a
+decodeDocumentLT raw = case parseText def raw of
+  Left err -> Left $ show err
+  Right conduitDoc ->
+    first prettyParserError . fromDocument . annotateDocument $
+      fromXmlConduit conduitDoc
+
+decodeDocumentBS :: (HasCallStack, FromDocument a) => ByteString -> Either String a
+decodeDocumentBS raw = case parseLBS def (ByteString.Lazy.fromStrict raw) of
+  Left err -> Left $ show err
+  Right conduitDoc ->
+    first prettyParserError . fromDocument . annotateDocument $
+      fromXmlConduit conduitDoc
+
+decodeDocumentLBS :: (HasCallStack, FromDocument a) => BL.ByteString -> Either String a
+decodeDocumentLBS raw = case parseLBS def raw of
+  Left err -> Left $ show err
+  Right conduitDoc ->
+    first prettyParserError . fromDocument . annotateDocument $
+      fromXmlConduit conduitDoc
+
+encodeDocument :: ToDocument a => a -> Text
+encodeDocument =
+  Text.Lazy.toStrict
+    . renderText (def {rsPretty = True})
+    . toXmlConduit
+    . toDocument
+
+encodeDocumentLT :: ToDocument a => a -> LT.Text
+encodeDocumentLT =
+  renderText (def {rsPretty = True})
+    . toXmlConduit
+    . toDocument
+
+encodeDocumentBS :: ToDocument a => a -> ByteString
+encodeDocumentBS =
+  ByteString.Lazy.toStrict
+    . renderLBS (def {rsPretty = True})
+    . toXmlConduit
+    . toDocument
+
+encodeDocumentLBS :: ToDocument a => a -> BL.ByteString
+encodeDocumentLBS =
+  renderLBS (def {rsPretty = True})
+    . toXmlConduit
+    . toDocument
+
+newtype ReadShowXmlDocument a = ReadShowXmlDocument a
+
+instance ToDocument a => Show (ReadShowXmlDocument a) where
+  show (ReadShowXmlDocument a) =
+    Text.Lazy.unpack . renderText (def {rsPretty = True}) . toXmlConduit $ toDocument a
+
+instance FromDocument a => Read (ReadShowXmlDocument a) where
+  readsPrec _ str = case decodeDocument (Text.pack str) of
+    Right a -> [(ReadShowXmlDocument a, "")]
+    Left err -> error err
 
-parseDocument :: FromDocument a => Text -> Either ParserError a
-parseDocument xml = do
-  conduitDoc <-
-    either (throwParserError . Text.pack . show) pure $
-      XC.parseText XC.def (Text.fromStrict xml)
-  fromDocument (fromXmlConduit conduitDoc)
+newtype ReadShowXmlElement a = ReadShowXmlElement a
 
-parseDocument' :: FromDocument a => Text -> Maybe a
-parseDocument' = either (const Nothing) Just . parseDocument
+instance FromElement a => FromDocument (ReadShowXmlElement a) where
+  fromDocument Document {root} = ReadShowXmlElement <$> fromElement root
 
-unsafeParseDocument :: FromDocument a => Text -> a
-unsafeParseDocument = either undefined id . parseDocument
+deriving via ReadShowXmlDocument (ReadShowXmlElement a) instance FromElement a => Read (ReadShowXmlElement a)
 
-unparseDocument :: ToDocument a => a -> Text
-unparseDocument = Text.toStrict . XC.renderText XC.def . toXmlConduit . toDocument
+instance ToElement a => Show (ReadShowXmlElement a) where
+  show (ReadShowXmlElement a) =
+    Text.Lazy.unpack . renderText (def {rsPretty = True, rsXMLDeclaration = False}) $
+      toXmlConduit
+        Document {root = toElement a, rootName = "root_element", info = ()}