composite-xml (empty) → 0.1.0.0
raw patch · 7 files changed
+450/−0 lines, 7 filesdep +basedep +composite-basedep +composite-xml
Dependencies added: base, composite-base, composite-xml, containers, tasty, tasty-hunit, text, vinyl, xml-conduit
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +55/−0
- composite-xml.cabal +62/−0
- src/Composite/XML.hs +223/−0
- test/Spec.hs +69/−0
- test/data/A.xml +6/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for composite-xml++## v0.1.0++* Add RecXML Type
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,55 @@+# composite-xml++A simple xml parser/printer type using composite records. RecXML is defined like++```+data RecXML :: Symbol -> [Type] -> [Type] -> Type where+ RNode :: Rec Maybe xs -> [Field ys] -> RecXML s xs ys+```++An `RNode` is typed indexed by it's node name, an index of attributes it may+contain, and list of child node types of which it may contain any number or+multiplicity. The child nodes will typically also be RecXMLs, but this is not+enforced.++```+withLensesAndProxies+ [d|+ type A = "a" :-> Text++ type B = "b" :-> Int++ type C = "c" :-> Bool++ type D = "d" :-> Text++ type E = "e" :-> Int+ |]++type Child1 = RecXML "Child1" '[C] '[]+type Child2 = RecXML "Child2" '[D, E] '[]++type Root = RecXML "Root" '[A, B] '[Child1, Child2]++child1 :: Child1+child1 = RNode (Just True :^: RNil) []++child2 :: Child2+child2 = RNode (Just "bar" :^: Just 7 :^: RNil) []++child2b :: Child2+child2b = RNode (Just "quux" :^: Just 8 :^: RNil) []++root :: Root+root = RNode (Just "foo" :^: Just 5 :^: RNil) $ [field child1, field child2, field child2b]+```++corresponds to the xml++```+<Root a="foo" b="5">+ <Child1 c="true"></Child1>+ <Child2 d="bar" e="7"></Child2>+ <Child2 d="quux" e="8"></Child2>+</Root>+```
+ composite-xml.cabal view
@@ -0,0 +1,62 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name: composite-xml+version: 0.1.0.0+synopsis: RecXML Type+description: RecXML type+category: Composite, Data, XML+author: Daniel Firth+maintainer: dan.firth@homotopic.tech+copyright: 2021 Daniel Firth+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+ test/data/A.xml++source-repository head+ type: git+ location: https://gitlab.homotopic.tech/haskell/composite-xml++library+ exposed-modules:+ Composite.XML+ other-modules:+ Paths_composite_xml+ hs-source-dirs:+ src+ ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-missing-import-lists -Wno-implicit-prelude -Wno-monomorphism-restriction -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-orphans -Wno-safe -Wno-unsafe+ build-depends:+ base >=4.7 && <5+ , composite-base >=0.7.0.0 && <0.9+ , containers+ , text >=1.0 && <2.1+ , vinyl >=0.13.0 && <0.15+ , xml-conduit >=1.9 && <2.0+ default-language: Haskell2010++test-suite composite-xml-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_composite_xml+ hs-source-dirs:+ test+ ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-missing-import-lists -Wno-implicit-prelude -Wno-monomorphism-restriction -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-orphans -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , composite-base >=0.7.0.0 && <0.9+ , composite-xml+ , containers+ , tasty+ , tasty-hunit+ , text >=1.0 && <2.1+ , vinyl >=0.13.0 && <0.15+ , xml-conduit >=1.9 && <2.0+ default-language: Haskell2010
+ src/Composite/XML.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Composite.XML (RecXML(RNode)+ , ToAttr(..)+ , ToAttrs(..)+ , FromAttr(..)+ , FromAttrs(..)+ , Formattable(..)+ , Readable(..)+ , ToElement(..)+ , ToElements(..)+ , FromElement(..)+ , FromElements(..)) where++++import Composite.CoRecord+import Composite.Record+import Control.Arrow+import Control.Monad+import Data.Functor.Identity+import Data.Kind+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Proxy+import Data.Ratio+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vinyl+import Data.Vinyl.Functor hiding (Identity)+import GHC.TypeLits+import Text.XML as X++type RecXML :: Symbol -> [Type] -> [Type] -> Type+data RecXML :: Symbol -> [Type] -> [Type] -> Type where+ RNode :: Rec Maybe xs -> [Field ys] -> RecXML s xs ys++deriving stock instance (Show (Field ys), Show (Rec Maybe xs), RecApplicative ys) => Show (RecXML s xs ys)+deriving stock instance (Eq (Field ys), Eq (Rec Maybe xs), RecApplicative ys) => Eq (RecXML s xs ys)++type ToAttrs :: Type -> Constraint+class ToAttrs x where+ toAttrs :: x -> Map Name Text++instance ToAttrs (Rec f '[]) where+ toAttrs RNil = mempty++type Formattable :: Type -> Constraint+class Formattable x where+ formatC :: x -> Text++instance Formattable Bool where+ formatC True = "true"+ formatC False = "false"++instance Formattable String where+ formatC = T.pack++instance Formattable Int where+ formatC = T.pack . show++instance Formattable () where+ formatC = T.pack . show++instance Formattable (Ratio Integer) where+ formatC = T.pack . show++instance Formattable Double where+ formatC = T.pack . show++instance Formattable Text where+ formatC = id++type ToAttr :: Type -> Constraint+class ToAttr a where+ toAttr :: a -> (Name, Text)++instance (Formattable a, KnownSymbol s) => ToAttr (s :-> a) where+ toAttr = first (fromString . T.unpack) . fmap formatC . valWithName++instance (ToAttr x, ToAttrs (Record xs)) => ToAttrs (Record (x ': xs)) where+ toAttrs (Identity x :& xs) = (Map.fromList . pure . toAttr $ x) <> toAttrs xs++instance (ToAttr x, ToAttrs (Rec Maybe xs)) => ToAttrs (Rec Maybe (x ': xs)) where+ toAttrs (Just x :& xs) = (Map.fromList . pure . toAttr $ x) <> toAttrs xs+ toAttrs (Nothing :& xs) = toAttrs xs+++type ToElement :: Type -> Constraint+class ToElement a where+ toElement :: a -> Element++type ToElements :: Type -> Constraint+class ToElements x where+ toElements :: x -> [Element]++instance ToElements (Rec f '[]) where+ toElements RNil = mempty++instance (ToElement x, ToElements (Record xs)) => ToElements (Record (x ': xs)) where+ toElements (Identity x :& xs) = toElement x : toElements xs++instance (KnownSymbol s, ToAttrs (Rec Maybe xs), RecApplicative ys, AllHave '[ToElement] ys) => ToElement (RecXML s xs ys) where+ toElement (RNode x y) = Element (fromString $ symbolVal @s (Proxy :: Proxy s)) (toAttrs x) (NodeElement <$> toElements y)++type Readable :: Type -> Constraint+class Readable x where+ readC :: Text -> Maybe x++instance Readable Bool where+ readC = \case+ "true" -> Just True+ "false" -> Just False+ _ -> Nothing++instance Readable String where+ readC = Just . T.unpack++instance Readable Text where+ readC = Just++instance Readable Double where+ readC = Just . read . T.unpack++instance Readable Int where+ readC = Just . read . T.unpack++type FromAttr :: Symbol -> Type -> Constraint+class FromAttr s a | a -> s where+ fromAttr :: (Name, Text) -> Maybe a++instance (Readable a, KnownSymbol s) => FromAttr s (s :-> a) where+ fromAttr (n, x) = if n == fromString (symbolVal @s (Proxy :: Proxy s)) then Val @s <$> readC x else Nothing++type FromAttrs :: Type -> Constraint+class FromAttrs a where+ fromAttrs :: [(Name, Text)] -> Maybe a++instance FromAttrs (Rec f '[]) where+ fromAttrs _ = pure RNil++instance (FromAttr s (s :-> x), FromAttrs (Record xs)) => FromAttrs (Record (s :-> x ': xs)) where+ fromAttrs xs = do+ let as' = fmap (\i -> (i, fromAttr @s @(s :-> x) i)) xs+ let ts = snd <$> Prelude.filter (isJust . snd) as'+ let rs = fst <$> Prelude.filter (isNothing . snd) as'+ t <- join $ listToMaybe ts+ xs' <- fromAttrs rs+ pure $ Identity t :& xs'++instance (FromAttr s (s :-> x), FromAttrs (Rec Maybe xs)) => FromAttrs (Rec Maybe (s :-> x ': xs)) where+ fromAttrs xs = do+ let as' = fmap (\i -> (i, fromAttr @s @(s :-> x) i)) xs+ let ts = snd <$> Prelude.filter (isJust . snd) as'+ let rs = fst <$> Prelude.filter (isNothing . snd) as'+ let t = join $ listToMaybe ts+ xs' <- fromAttrs rs+ pure $ t :& xs'++type FromElement :: Type -> Constraint+class FromElement a where+ fromElement :: Element -> Maybe a++type FromElements :: Type -> Constraint+class FromElements x where+ fromElements :: [Element] -> Maybe x++instance forall ys. (AllHave '[ToElement] ys, RecApplicative ys) => ToElement (CoRec Identity ys) where+ toElement (CoVal (Identity x)) = toElement' x+ where+ toElementer :: Rec (Op Element) ys+ toElementer = reifyDicts (Proxy @'[ToElement]) (\_ -> Op toElement)+ toElement' = runOp (rget toElementer)++instance forall ys. (AllHave '[FromElement] ys, RecApplicative ys, FoldRec ys ys, RMap ys) => FromElement (CoRec Identity ys) where+ fromElement x = firstField $ ($ x) $ rtraverse getCompose fromElementer where+ fromElementer :: Rec ((->) Element :. Maybe ) ys+ fromElementer = reifyDicts (Proxy @'[FromElement]) (\_ -> Compose fromElement)++instance ToElement a => ToElements [a] where+ toElements = Prelude.map toElement++instance FromElement a => FromElements [a] where+ fromElements = Prelude.traverse fromElement++instance FromElements (Record '[]) where+ fromElements [] = Just RNil+ fromElements _ = Nothing++instance (FromElement x, FromElements (Record xs)) => FromElements (Record (x ': xs)) where+ fromElements (x : xs) = do+ x' <- fromElement x+ xs' <- fromElements xs+ pure $ Identity x' :& xs'+ fromElements _ = Nothing++instance (KnownSymbol s, FromAttrs (Rec Maybe xs), FromElement (CoRec Identity ys)) => FromElement (RecXML s xs ys) where+ fromElement (Element n xs ys) = do+ guard (symbolVal (Proxy @s) == T.unpack (nameLocalName n))+ xs' <- fromAttrs $ Map.toList xs+ ts <- sequence $ Prelude.filter isJust $ Prelude.map+ (\case+ NodeElement x' -> Just x'+ _ -> Nothing) ys+ ys' <- fromElements ts+ pure $ RNode xs' ys'
+ test/Spec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+{-# OPTIONS_GHC -fno-warn-missing-kind-signatures #-}++module Main (main) where++import Composite+import Composite.CoRecord hiding (Op)+import Composite.TH+import Composite.XML+import Data.Text+import Test.Tasty+import Test.Tasty.HUnit+import Text.XML as X++withLensesAndProxies+ [d|+ type A = "a" :-> Text++ type B = "b" :-> Int++ type C = "c" :-> Bool++ type D = "d" :-> Text++ type E = "e" :-> Int+ |]++type Child1 = RecXML "Child1" '[C] '[]++type Child2 = RecXML "Child2" '[D, E] '[]++type Root = RecXML "Root" '[A, B] '[Child1, Child2]++child1 :: Child1+child1 = RNode (Just True :^: RNil) []++child2 :: Child2+child2 = RNode (Just "bar" :^: Just 7 :^: RNil) []++child2b :: Child2+child2b = RNode (Just "quux" :^: Just 8 :^: RNil) []++root :: Root+root = RNode (Just "foo" :^: Just 5 :^: RNil) [field child1, field child2, field child2b]++tests :: TestTree+tests =+ testGroup+ "Parsing Tests"+ [ testCase "parses RecXML" $ do+ k <- X.readFile def "./test/data/A.xml"+ let x = fromElement @Root $ documentRoot k+ assertEqual "" (Just root) x+ ]++main :: IO ()+main = defaultMain tests
+ test/data/A.xml view
@@ -0,0 +1,6 @@+<?xml version="1.0" encoding="UTF-8"?>+<Root a="foo" b="5">+ <Child1 c="true"></Child1>+ <Child2 d="bar" e="7"></Child2>+ <Child2 d="quux" e="8"></Child2>+</Root>