diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# 0.1 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# xmlbf + +_XML back and forth!_ + +`xmlbf` provides `FromXML` and `ToXML` instances intended to be used as the +familiar `FromJSON` and `ToJSON` from the `aeson` package. + +Build by running `nix-build` in the top-level directory. Alternatively, running +`nix-shell` in the top-level directory puts you in a shell where all of the +dependencies of this project are available. There you can use `cabal` and/or +`./Setup.hs` as usual. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env nix-shell +#! nix-shell ./default.nix -i runghc +import Distribution.Simple +main = defaultMain diff --git a/lib/Xmlbf.hs b/lib/Xmlbf.hs new file mode 100644 --- /dev/null +++ b/lib/Xmlbf.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +{-# LANGUAGE ScopedTypeVariables #-} + +-- | XML back and forth! +-- +-- @xmlbf@ doesn't do any parsing of raw XML on its own. Instead, one should +-- rely on libraries like @xmlbf-xeno@ or @xmlbf-xmlhtml@ for this. +-- +-- @xmlbf@ provides a 'FromXml' class intended to be used as the familiar +-- 'Data.Aeson.FromJSON' from the @aeson@ package. This relies on the +-- 'Parser' type and the related tools. +-- +-- @xmlbf@ provides a 'ToXml' class intended to be used as the familiar +-- 'Data.Aeson.toJSON' from the @aeson@ package. This relies on the +-- 'Node' and 'Element'' types. +-- +-- @xmlb@ provides tools like 'df' and 'dfM' for finding a fixpoint +-- of a XML structure. +module Xmlbf + ( -- * Parsing + FromXml(fromXml) + , Parser + , runParser + , pElement + , pAttr + , pAttrs + , pText + , pRead + , pEndOfInput + + -- * Rendering + , ToXml(toXml) + , encode + + , Node(Text, Element) + , element + + -- * Fixpoints + , df + , dfM + ) where + +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Prim as BBP +import Data.Foldable (for_, toList) +import Data.Functor.Identity (Identity(Identity), runIdentity) +import qualified Data.HashMap.Strict as HM +import Data.Monoid ((<>)) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.String (IsString(fromString)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Typeable (Typeable, typeRep, tyConName, typeRepTyCon) +import Data.Word (Word8) +import Control.Applicative (Alternative(empty, (<|>))) +import Control.Monad (MonadPlus(mplus, mzero), join, guard) +import Control.Monad.Fail (MonadFail(fail)) +import qualified Text.Read + +-------------------------------------------------------------------------------- + +-- | Either a text or an element node in an XML fragment. Construct with either +-- 'Text' or 'element', respectively. +data Node + = Element' !T.Text !(HM.HashMap T.Text T.Text) ![Node] + | Text !T.Text + deriving (Eq, Show) + +pattern Element :: T.Text -> (HM.HashMap T.Text T.Text) -> [Node] -> Node +pattern Element t as cs <- Element' t as cs + +-- | Constructs a 'Text'. +instance IsString Node where + fromString = Text . T.pack + {-# INLINABLE fromString #-} + +-- | Concats 'Text's together. +normalize :: [Node] -> [Node] +{-# INLINE normalize #-} +normalize = \case + Text a : Text b : ns -> normalize (Text (a <> b) : ns) + (n : ns) -> n : normalize ns + [] -> [] + +element + :: T.Text + -- ^ Element' name. + -> HM.HashMap T.Text T.Text + -- ^ Attributes. + -> [Node] + -- ^ Children. + -> Either String Node + -- ^ Returns 'Left' if the element name, or atribute names, or attribute + -- values are invalid. + -- + -- TODO: We just check for emptyness currently. +element t0 hm0 ns0 = do + guarde (t0 == T.strip t0) $ + "Element' name has surrounding whitespace: " ++ show t0 + guarde (not (T.null t0)) ("Element' name is blank: " ++ show t0) + for_ (HM.keys hm0) $ \k -> do + guarde (k == T.strip k) $ + "Attribute name has surrounding whitespace: " ++ show k + guarde (not (T.null k)) ("Attribute name is blank: " ++ show k) + Right (Element' t0 hm0 (normalize ns0)) + +guarde :: Bool -> String -> Either String () +{-# INLINE guarde #-} +guarde True _ = Right () +guarde False s = Left s + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Parsing + +class FromXml a where + -- | Parses an XML fragment into a value of type @a@. + -- + -- If a 'ToXml' instance for @a@ exists, then: + -- + -- @ + -- 'runParser' 'fromXml' ('toXml' a) == 'Right' a + -- @ + fromXml :: Parser a + +-- | XML parser monad. To be run with 'runParser'. +-- +-- You can build a 'Parser' using 'element', 'pAttr', 'pAttrs', 'pText', 'pRead', +-- or any of the 'Applicative', 'Alternative' or 'Monad' combinators. +newtype Parser a = Parser { unParser :: S -> Either String (a, S) } + deriving (Functor) + +-- | Run a parser on an XML fragment. If the parser fails, then a 'String' with +-- an error message is returned. +runParser :: Parser a -> [Node] -> Either String a +runParser p0 = fmap fst . unParser p0 . STop . normalize + +data S + = STop ![Node] + -- ^ Parsing the top-level nodes. + | SReg !T.Text !(HM.HashMap T.Text T.Text) ![Node] + -- ^ Parsing a particular root element. + +instance Applicative Parser where + {-# INLINE pure #-} + pure = \a -> Parser (\s -> Right (a, s)) + {-# INLINE (<*>) #-} + Parser gf <*> Parser ga = Parser $ \s0 -> do + (f, s1) <- gf s0 + (a, s2) <- ga s1 + pure (f a, s2) + +instance Monad Parser where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + Parser ga >>= k = Parser $ \s0 -> do + (a, s1) <- ga s0 + unParser (k a) s1 + fail e = Parser (\_ -> Left e) + +instance MonadFail Parser where + fail e = Parser (\_ -> Left e) + +-- | Backtracks. +instance Alternative Parser where + {-# INLINE empty #-} + empty = Parser (\_ -> Left "empty") + {-# INLINE (<|>) #-} + Parser a <|> Parser b = Parser (\s -> either (\_ -> b s) Right (a s)) + +-- | Backtracks. +instance MonadPlus Parser where + {-# INLINE mzero #-} + mzero = empty + {-# INLINE mplus #-} + mplus = (<|>) + +-------------------------------------------------------------------------------- +-- Some parsers + +-- | @'pElement' "foo" p@ runs a 'Parser' @p@ inside a element node named +-- @"foo"@. This fails if such element does not exist at the current position. +-- +-- Consumes the element from the parser state. +pElement :: T.Text -> Parser a -> Parser a +pElement t0 p0 = Parser $ \case + SReg t as (Element' t' as' cs' : cs) | t == t0 -> do + (a,_) <- unParser p0 (SReg t' as' cs') + Right (a, SReg t as cs) + STop (Element' t as cs : ns) | t == t0 -> do + (a,_) <- unParser p0 (SReg t as cs) + Right (a, STop ns) + _ -> Left ("Missing element " ++ show t0) + +-- | Return the value of the requested attribute, if defined. May return an +-- empty string in case the attribute is defined but no value was given to it. +-- +-- Consumes the attribute from the parser state. +pAttr :: T.Text -> Parser T.Text +{-# INLINABLE pAttr #-} +pAttr n = Parser $ \case + STop _ -> Left "Before selecting an attribute, you must select an element" + SReg t as cs -> case HM.lookup n as of + Just x -> Right (x, SReg t (HM.delete n as) cs) + Nothing -> Left ("Missing attribute " ++ show n ++ " in element " ++ show t) + +-- | Returns all of the available element attributes. May return empty strings +-- as values in case an attribute is defined but no value was given to it. +-- +-- Consumes all of the remaining attributes for this element from the parser +-- state. +pAttrs :: Parser (HM.HashMap T.Text T.Text) +{-# INLINABLE pAttrs #-} +pAttrs = Parser $ \case + STop _ -> Left "Before selecting an attribute, you must select an element" + SReg t as cs -> Right (as, SReg t mempty cs) + +-- | Return a text node value (including CDATA). +-- +-- Consumes the text node from the parser state. +-- +-- Law: When two consecutive calls to 'pText' are made, the first call returns +-- all of the available consecutive text, and the second call always fails. +pText :: Parser T.Text +{-# INLINABLE pText #-} +pText = Parser $ \case + -- Note: this works only because we asume 'normalize' has been used. + STop (Text x : ns) -> Right (x, STop ns) + SReg t as (Text x : cs) -> Right (x, SReg t as cs) + _ -> Left "Missing text node" + +-- | Parses a value that can be 'read'. +-- +-- Consumes the raw string from the parser state. +pRead :: (Typeable a, Read a) => T.Text -> Parser a +pRead = \t -> case Text.Read.readMaybe (T.unpack t) of + Just a -> pure a + ya@Nothing -> do + let ty = tyConName (typeRepTyCon (typeRep ya)) + Parser (\_ -> Left ("Can't read as " ++ ty ++ ": " ++ show t)) + +-- | Succeeds if all of the elements, attributes and text nodes have +-- been consumed. +pEndOfInput :: Parser () +pEndOfInput = Parser (\s -> + if isEof s then Right ((), s) + else Left "Not end of input yet") + +isEof :: S -> Bool +{-# INLINE isEof #-} +isEof = \case + SReg _ as cs -> HM.null as && null cs + STop ns -> null ns + +-------------------------------------------------------------------------------- +-- Rendering + +class ToXml a where + -- | Renders a value of type @a@ into an XML fragment. + -- + -- If a 'FromXml' instance for @a@ exists, then: + -- + -- @ + -- 'runParser' 'fromXml' ('toXml' a) == 'Right' a + -- @ + toXml :: a -> [Node] + +-- | Encodes a list of XML 'Node's to an UTF8-encoded and XML-escaped +-- bytestring. +encode :: [Node] -> BB.Builder +encode xs = mconcat $ xs >>= \case + Text x -> [encodeXmlUtf8 x] + Element' t as cs -> + [ "<" + , encodeUtf8 t + , mconcat $ do + (k,v) <- HM.toList as + guard (not (T.null k)) + [ " ", encodeUtf8 k, "=\"", encodeXmlUtf8 v, "\"" ] + , if null cs then "/" else "" + , ">" + , encode cs + , if null cs then "" else " encodeUtf8 t <> ">" + ] + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Node fixpoint + +-- | Post-order depth-first replacement of 'Node' and all of its children. +-- +-- This function works like 'fix', but the given function is trying to find a +-- fixpoint for the individual children nodes, not for the root node. +-- +-- For example, the following function renames every node named @"w"@ to @"y"@, +-- and every node named @"y"@ to @"z"@. It accomplishes this by first renaming +-- @"w"@ nodes to @"x"@, and then, by using @k@ recursively to further rename +-- all @"x"@ nodes (including the ones that were just created) to @"y"@ in a +-- post-order depth-first manner. After renaming an @"x"@ node to @"y"@, the +-- recursion stops (i.e., @k@ is not used), so our new @"y"@ nodes won't be +-- further renamed to @"z"@. However, nodes that were named @"y"@ initially will +-- be renamed to @"z"@. +-- +-- In our example we only replace one node with another, but a node can be +-- replaced with zero or more nodes, depending on the length of the resulting +-- list. +-- +-- @ +-- foo :: 'Node' -> ['Node'] +-- foo = 'df' $ \\k -> \\case +-- 'Element'' "w" as cs -> k ('Element'' "x" as cs) +-- 'Element'' "x" as cs -> ['Element'' "y" as cs] +-- 'Element'' "y" as cs -> k ('Element'' "z" as cs) +-- @ +-- +-- /WARNING/ If you call @k@ in every branch, then 'df' will never terminate. +-- Make sure the recursion stops at some point by simply returning a list of +-- nodes instead of calling @k@. +df :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node] +df f = runIdentity . dfM (\k -> Identity . f (runIdentity . k)) + +-- | Monadic version of 'df'. +dfM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node] +dfM f = \n0 -> do + let c0 = cursorFromNode n0 + c1 <- traverschildren (dfM f) c0 + c2 <- traverseRightSiblings (dfM f) c1 + fmap (normalize . join) + (traverse (f (dfM f)) (cursorSiblings c2)) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- INTERNAL: Cursor +-- +-- Most of this comes from Chris Smith's xmlhtml, BSD3 licensed +-- https://hackage.haskell.org/package/xmlhtml + +-- | Zipper into a 'Node' tree. +data Cursor = Cursor + { _cursorCurrent :: !Node + -- ^ Retrieves the current node of a 'Cursor'. + , _cursorLefts :: !(Seq Node) + -- ^ Nodes to the left (ordered right to left). + , _cursorRights :: !(Seq Node) + -- ^ Nodes to the right (ordered left to right). + , _cursorParents :: !(Seq (Seq Node, T.Text, HM.HashMap T.Text T.Text, Seq Node)) + -- ^ Parents' name, attributes, and siblings. + } + +------------------------------------------------------------------------------ + +-- | The cursor if left where it starts. +traverschildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor +{-# INLINE traverschildren #-} +traverschildren f c0 = case _cursorCurrent c0 of + Text _ -> pure c0 + Element' t as cs -> do + n1s <- fmap (normalize . join) (traverse f cs) + pure (c0 {_cursorCurrent = Element' t as n1s}) + +-- | The cursor if left in the rightmost sibling. +traverseRightSiblings :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor +{-# INLINE traverseRightSiblings #-} +traverseRightSiblings f c0 = case cursorRemoveRight c0 of + Nothing -> pure c0 + Just (n1, c1) -> do + n2s <- fmap normalize (f n1) + traverseRightSiblings f (cursorInsertManyRight n2s c1) + +-- | Builds a 'Cursor' for navigating a tree. That is, a forest with a single +-- root 'Node'. +cursorFromNode :: Node -> Cursor +{-# INLINE cursorFromNode #-} +cursorFromNode n = Cursor n mempty mempty mempty + +-- | Retrieves a list of the 'Node's at the same level as the current position +-- of a cursor, including the current node. +cursorSiblings :: Cursor -> [Node] +{-# INLINE cursorSiblings #-} +cursorSiblings (Cursor cur ls rs _) = + toList (Seq.reverse ls <> (cur Seq.<| rs)) + +-- | Removes the node to the right and return it. +cursorRemoveRight :: Cursor -> Maybe (Node, Cursor) +{-# INLINE cursorRemoveRight #-} +cursorRemoveRight = \case + Cursor n ls rs0 ps | not (Seq.null rs0) -> + case Seq.viewl rs0 of + r Seq.:< rs -> Just (r, Cursor n ls rs ps) + _ -> undefined -- unreachable, rs0 is not empty + _ -> Nothing + +-- | Inserts a list of new 'Node's to the right of the current position. +cursorInsertManyRight :: [Node] -> Cursor -> Cursor +{-# INLINE cursorInsertManyRight #-} +cursorInsertManyRight ns (Cursor nn ls rs ps) = + Cursor nn ls (Seq.fromList ns <> rs) ps + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Miscellaneous + +encodeUtf8 :: T.Text -> BB.Builder +{-# INLINE encodeUtf8 #-} +encodeUtf8 = T.encodeUtf8Builder + +encodeXmlUtf8 :: T.Text -> BB.Builder +{-# INLINE encodeXmlUtf8 #-} +encodeXmlUtf8 = T.encodeUtf8BuilderEscaped xmlEscaped + +xmlEscaped :: BBP.BoundedPrim Word8 +{-# INLINE xmlEscaped #-} +xmlEscaped = + BBP.condB (== 38) (fixed5 (38,(97,(109,(112,59))))) $ -- '&' -> "&" + BBP.condB (== 60) (fixed4 (38,(108,(116,59)))) $ -- '<' -> "<" + BBP.condB (== 62) (fixed4 (38,(103,(116,59)))) $ -- '>' -> ">" + BBP.condB (== 34) (fixed5 (38,(35,(51,(52,59))))) $ -- '"' -> """ + BBP.liftFixedToBounded BBP.word8 + where + {-# INLINE fixed4 #-} + fixed4 :: (Word8, (Word8, (Word8, Word8))) -> BBP.BoundedPrim Word8 + fixed4 x = BBP.liftFixedToBounded + (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8 + BBP.>*< BBP.word8 BBP.>*< BBP.word8) + {-# INLINE fixed5 #-} + fixed5 :: (Word8, (Word8, (Word8, (Word8, Word8)))) -> BBP.BoundedPrim Word8 + fixed5 x = BBP.liftFixedToBounded + (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8 + BBP.>*< BBP.word8 BBP.>*< BBP.word8 BBP.>*< BBP.word8) + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Debug.Trace + +import Control.Applicative (many, liftA2) +import qualified Control.Monad.Trans.State as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import Data.Either (isLeft) +import qualified Data.Text as T +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Runners as Tasty +import Test.Tasty.QuickCheck ((===)) +import qualified Test.Tasty.QuickCheck as QC +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.HUnit ((@?=), (@=?)) +import qualified Test.QuickCheck.Instances () + +import qualified Xmlbf as X + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] tt_main + +-------------------------------------------------------------------------------- +tt_main :: Tasty.TestTree +tt_main = Tasty.testGroup "main" + [ tt_element + , tt_encoding + , tt_parsing + , tt_fixpoints + ] + +tt_element :: Tasty.TestTree +tt_element = Tasty.testGroup "element" + [ HU.testCase "empty name" $ do + HU.assert (isLeft (X.element "" [] [])) + + , HU.testCase "name with leading whitespace" $ do + HU.assert (isLeft (X.element " x" [] [])) + + , HU.testCase "name with trailing whitespace" $ do + HU.assert (isLeft (X.element "x " [] [])) + + , HU.testCase "empty attribute" $ do + HU.assert (isLeft (X.element "x" [("","a")] [])) + + , HU.testCase "attribute with leading whitespace" $ do + HU.assert (isLeft (X.element "x" [(" x","a")] [])) + + , HU.testCase "attribute with trailing whitespace" $ do + HU.assert (isLeft (X.element "x" [("x ","a")] [])) + ] + +tt_encoding :: Tasty.TestTree +tt_encoding = Tasty.testGroup "Encoding" + [ HU.testCase "" $ do + bsEncode [] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [("a","y")] [] + bsEncode [n0] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [("a","y"), ("b","")] [] + bsEncode [n0] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [("a","y"), ("b","z")] [] + bsEncode [n0] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.Text ""] + bsEncode [n0] @?= "" + + , HU.testCase "foo" $ do + let n0 = unsafeElement "x" [] [X.Text "foo"] + bsEncode [n0] @?= "foo" + + , HU.testCase "foobar" $ do + let n0 = unsafeElement "x" [] [X.Text "foo", X.Text "bar"] + bsEncode [n0] @?= "foobar" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [] [unsafeElement "y" [] []] + bsEncode [n0] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [] + [X.Text "", unsafeElement "y" [] [], X.Text ""] + bsEncode [n0] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [] + [unsafeElement "y" [] [], unsafeElement "z" [] []] + bsEncode [n0] @?= "" + + , HU.testCase "" $ do + let n0 = unsafeElement "x" [] [] + n1 = unsafeElement "y" [] [] + bsEncode [n0,n1] @?= "" + ] + +-------------------------------------------------------------------------------- + +tt_parsing :: Tasty.TestTree +tt_parsing = Tasty.testGroup "Parsing" + [ HU.testCase "endOfInput" $ do + Right () @=? X.runParser X.pEndOfInput [] + + , HU.testCase "endOfInput: Not end of input yet" $ do + Left "Not end of input yet" @=? X.runParser X.pEndOfInput [X.Text "&"] + + , HU.testCase "text: empty" $ do + Left "Missing text node" @=? X.runParser X.pText [] + + , HU.testCase "text: Missing text node" $ do + Left "Missing text node" @=? X.runParser X.pText [unsafeElement "a" [] []] + + , HU.testCase "text" $ do + Right "&" @=? X.runParser X.pText [X.Text "&"] + + , HU.testCase "text: concat" $ do + Right "&<" @=? X.runParser X.pText + [X.Text "&", X.Text "", X.Text "<"] + + , HU.testCase "text: twice" $ do + Left "Missing text node" @=? X.runParser (X.pText >> X.pText) + [X.Text "&", X.Text "", X.Text "<"] + + , HU.testCase "element: empty" $ do + Left "Missing element \"x\"" @=? X.runParser (X.pElement "x" (pure ())) [] + + , HU.testCase "element: Missing element" $ do + Left "Missing element \"x\"" + @=? X.runParser (X.pElement "x" (pure ())) [unsafeElement "y" [] []] + + , HU.testCase "element: pure" $ do + Right () + @=? X.runParser (X.pElement "x" (pure ())) [unsafeElement "x" [] []] + + , HU.testCase "element: text" $ do + Right "ab" + @=? X.runParser (X.pElement "x" X.pText) + [unsafeElement "x" [] [X.Text "a", X.Text "b"]] + + , HU.testCase "attr" $ do + Right "a" + @=? X.runParser (X.pElement "x" (X.pAttr "y")) + [unsafeElement "x" [("y","a"), ("z","b")] []] + + , HU.testCase "attr: Missing" $ do + Left "Missing attribute \"y\" in element \"x\"" + @=? X.runParser (X.pElement "x" (X.pAttr "y")) [unsafeElement "x" [] []] + + , HU.testCase "attrs: empty" $ do + Right [] + @=? X.runParser (X.pElement "x" X.pAttrs) [unsafeElement "x" [] []] + + , HU.testCase "attrs" $ do + Right [("y","a"), ("z","b")] + @=? X.runParser (X.pElement "x" X.pAttrs) + [unsafeElement "x" [("z","b"), ("y","a")] []] + + , HU.testCase "read" $ do + Right False @=? X.runParser (X.pRead =<< X.pText) [X.Text "False"] + ] + +tt_fixpoints :: Tasty.TestTree +tt_fixpoints = Tasty.testGroup "fixpoints" + [ HU.testCase "df: depth-first post-order?" $ do + let n0 = unsafeElement "a" [] + [ unsafeElement "b" [] + [ unsafeElement "c" [] [] + , unsafeElement "d" [] [] ] + , unsafeElement "e" [] + [ unsafeElement "f" [] [] + , unsafeElement "g" [] [] ] ] + f = \k n@(X.Element t _ _) -> S.modify (t:) >> pure [n] + ["c","d","b","f","g","e","a"] @=? reverse (S.execState (X.dfM f n0) []) + [n0] @=? S.evalState (X.dfM f n0) [] + + , HU.testCase "df: output single node" $ do + let n0 = unsafeElement "x" [] [X.Text "a", X.Text "b"] + f = \k -> \case + X.Text "ab" -> k (X.Text "foo") + X.Text "foo" -> k (X.Text "FOO") + n -> [n] + n1 = unsafeElement "x" [] [X.Text "FOO"] + [n1] @=? X.df f n0 + + , HU.testCase "df: output multiple nodes" $ do + let n0 = unsafeElement "x" [] [X.Text "a"] + f = \k -> \case + X.Text "a" -> let ny = unsafeElement "y" [] [] in [ny, ny] >>= k + X.Element "y" _ _ -> k (X.Text "b") + X.Element "x" as cs -> + let nz = unsafeElement "z" as cs in [nz, X.Text "a"] >>= k + n -> [n] + ns1 = [unsafeElement "z" [] [X.Text "bb"], X.Text "bb"] + ns1 @=? X.df f n0 + ] + +-------------------------------------------------------------------------------- + +unsafeElement :: T.Text -> HM.HashMap T.Text T.Text -> [X.Node] -> X.Node +unsafeElement n as cs = case X.element n as cs of + Right e -> e + Left e -> error ("unsafeElement: " ++ e) + +bsEncode :: [X.Node] -> B.ByteString +bsEncode = BL.toStrict . BB.toLazyByteString . X.encode + +{-- + +instance QC.Arbitrary X.Node where + arbitrary = QC.frequency + [ (1, X.Element <$> QC.arbitrary) + , (50, X.Text <$> QC.arbitrary) ] + shrink (X.Text t0) = X.Text <$> QC.shrink t0 + shrink (X.Element e0) = X.Element <$> QC.shrink e0 + +instance QC.Arbitrary X.Element where + arbitrary = X.Element + <$> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + shrink (X.Element n as cs) = + X.Element <$> QC.shrink n <*> QC.shrink as <*> QC.shrink cs +-} diff --git a/xmlbf.cabal b/xmlbf.cabal new file mode 100644 --- /dev/null +++ b/xmlbf.cabal @@ -0,0 +1,47 @@ +name: xmlbf +version: 0.1 +synopsis: XML back and forth! Parser, renderer, ToXml, FromXml, fixpoints. +description: XML back and forth! Parser, renderer, ToXml, FromXml, fixpoints. +homepage: https://gitlab.com/k0001/xmlbf +license: Apache-2.0 +license-file: LICENSE +author: Renzo Carbonara +maintainer: ren§ren*zone +copyright: Copyright 2017 Renzo Carbonara +category: Text +build-type: Simple +extra-source-files: ChangeLog.md README.md +cabal-version: >=1.10 + +library + hs-source-dirs: lib + exposed-modules: Xmlbf + default-language: Haskell2010 + ghc-options: -O2 -Wall + ghcjs-options: -O3 -Wall + build-depends: + base <5, + bytestring, + containers, + text, + transformers, + unordered-containers + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + build-depends: + base, + bytestring, + xmlbf, + QuickCheck, + quickcheck-instances, + tasty, + tasty-hunit, + tasty-quickcheck, + text, + transformers, + unordered-containers +