xmlbf (empty) → 0.1
raw patch · 7 files changed
+945/−0 lines, 7 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, containers, quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck, text, transformers, unordered-containers, xmlbf
Files
- ChangeLog.md +3/−0
- LICENSE +202/−0
- README.md +11/−0
- Setup.hs +4/−0
- lib/Xmlbf.hs +437/−0
- test/Test.hs +241/−0
- xmlbf.cabal +47/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# 0.1++* First version.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,4 @@+#! /usr/bin/env nix-shell+#! nix-shell ./default.nix -i runghc+import Distribution.Simple+main = defaultMain
+ lib/Xmlbf.hs view
@@ -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)+
+ test/Test.hs view
@@ -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 "<x a=\"y\"/>" $ do+ let n0 = unsafeElement "x" [("a","y")] []+ bsEncode [n0] @?= "<x a=\"y\"/>"++ , HU.testCase "<x a=\"y\" b=\"\"/>" $ do+ let n0 = unsafeElement "x" [("a","y"), ("b","")] []+ bsEncode [n0] @?= "<x a=\"y\" b=\"\"/>"++ , HU.testCase "<x a=\"y\" b=\"z\"/>" $ do+ let n0 = unsafeElement "x" [("a","y"), ("b","z")] []+ bsEncode [n0] @?= "<x a=\"y\" b=\"z\"/>"++ , HU.testCase "<x a=\"y\" b=\"z\"></x>" $ do+ let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.Text ""]+ bsEncode [n0] @?= "<x a=\"y\" b=\"z\"></x>"++ , HU.testCase "<x>foo</x>" $ do+ let n0 = unsafeElement "x" [] [X.Text "foo"]+ bsEncode [n0] @?= "<x>foo</x>"++ , HU.testCase "<x>foobar</x>" $ do+ let n0 = unsafeElement "x" [] [X.Text "foo", X.Text "bar"]+ bsEncode [n0] @?= "<x>foobar</x>"++ , HU.testCase "<x><y/></x>" $ do+ let n0 = unsafeElement "x" [] [unsafeElement "y" [] []]+ bsEncode [n0] @?= "<x><y/></x>"++ , HU.testCase "<x><y/></x>" $ do+ let n0 = unsafeElement "x" []+ [X.Text "", unsafeElement "y" [] [], X.Text ""]+ bsEncode [n0] @?= "<x><y/></x>"++ , HU.testCase "<x><y/><z/></x>" $ do+ let n0 = unsafeElement "x" []+ [unsafeElement "y" [] [], unsafeElement "z" [] []]+ bsEncode [n0] @?= "<x><y/><z/></x>"++ , HU.testCase "<x><y>" $ do+ let n0 = unsafeElement "x" [] []+ n1 = unsafeElement "y" [] []+ bsEncode [n0,n1] @?= "<x/><y/>"+ ]++--------------------------------------------------------------------------------++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+-}
+ xmlbf.cabal view
@@ -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+