XML 0.0.0.0 → 0.0.1.0

raw patch · 2 files changed

+64/−6 lines, 2 filesdep +hs-functorsdep +multivector

Dependencies added: hs-functors, multivector

Files

• Data/XML.hs +60/−5
• XML.cabal +4/−1

@@ -1,9 +1,64 @@+{-# LANGUAGE ViewPatterns, RecordWildCards #-}+{-# LANGUAGE PatternSynonyms #-}+ module Data.XML where +import Control.Arrow+import Data.Fix+import Data.Functor.Classes+import Data.Functor.Compose+import Data.List.NonEmpty (NonEmpty (..)) import Data.Text-import Data.Vector+import qualified Data.Text.Lazy as L+import qualified Data.Vector.Generic as V+import Data.Vector.Multi (Vector)+import Util -data Element = Element-  { name :: Text-  , attrs :: Vector (Text, Text)-  , content :: Vector (Either Char Element) }+data ElementF a = ElementF+  { nameF :: !Text+  , attrsF :: !(Vector (Text, Text))+  , contentF :: !a }+  deriving (Functor, Foldable, Traversable)++instance Eq1 ElementF where+    liftEq eq x y = nameF x == nameF y && V.toList (attrsF x) == V.toList (attrsF y) && contentF x `eq` contentF y++instance Eq a => Eq (ElementF a) where (==) = eq1++data ContentF a = ContentF !L.Text !(Vector (NonEmpty a, L.Text))+instance Functor ContentF where fmap f (ContentF xs cs) = Content xs $ V.map (fmap f *** id) cs+instance Foldable ContentF where foldMap f (ContentF _ cs) = foldMap (foldMap f . fst) (V.toList cs)+instance Traversable ContentF where traverse f (ContentF xs cs) = Content xs . V.fromList <$> traverse (traverse f *=* pure) (V.toList cs)+instance Eq1 ContentF where+    liftEq eq (ContentF xs cs) (ContentF ys ds) = xs == ys && liftEq (liftEq2 (liftEq eq) (==)) (V.toList cs) (V.toList ds)++instance Eq a => Eq (ContentF a) where (==) = eq1++instance Semigroup (ContentF a) where+    ContentF xs cs <> ContentF ys ds = case V.unsnoc cs of+        Nothing -> ContentF (xs <> ys) ds+        Just (cs, (es, zs)) -> ContentF xs (cs V.++ V.cons (es, zs <> ys) ds)++instance Monoid (ContentF a) where mempty = ContentF mempty V.empty++type Element = Fix (Compose ElementF ContentF)+type Content = ContentF Element++pattern Element { name, attrs, content } = Fix (Compose (ElementF { nameF = name, attrsF = attrs, contentF = content }))+{-# COMPLETE Element #-}++pattern Content :: L.Text -> Vector (NonEmpty a, L.Text) -> ContentF a+pattern Content xs cs = ContentF xs cs+{-# COMPLETE Content #-}++showElement :: Element -> L.Text+showElement (Element {..}) =+    mconcat+    ["<",+     intercalate " " . fmap L.fromStrict $+     name :| ((\ (a, b) -> a <> "=\"" <> b <> "\"") <$> V.toList attrs),+     case content of+         Content "" (V.null -> True) -> "/>"+         Content xs cs -> ">" <> xs <>+                          foldMap (\ (es, xs) -> foldMap showElement es <> xs) (V.toList cs) <>+                          "</" <> L.fromStrict name <> ">"]

@@ -1,5 +1,5 @@ name:                XML-version:             0.0.0.0+version:             0.0.1.0 synopsis:            Extensible Markup Language -- description: license:             BSD3@@ -17,6 +17,8 @@   exposed-modules:     Data.XML   build-depends:       base >= 4.7 && < 5                      , base-unicode-symbols+                     , hs-functors >=0.1.2 && <0.2+                     , multivector >=0.1 && <0.2                      , util >=0.1.7 && <0.2                      , txt >=0.0.1 && <0.1                      , vector >=0.12 && <0.13@@ -36,6 +38,7 @@                      , OverloadedStrings   ghc-options:         -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing                        -Wincomplete-record-updates -Wincomplete-uni-patterns+                       -funbox-strict-fields  test-suite test   type:                exitcode-stdio-1.0