xml-isogen 0.1.0 → 0.2.0
raw patch · 9 files changed
+323/−59 lines, 9 filesdep +xml-conduitdep +xml-isogendep ~basedep ~dom-parserdep ~template-haskell
Dependencies added: xml-conduit, xml-isogen
Dependency ranges changed: base, dom-parser, template-haskell, xml-conduit-writer
Files
- CHANGELOG.md +5/−0
- README.md +9/−0
- src/Data/THGen/Compat.hs +38/−0
- src/Data/THGen/Enum.hs +7/−8
- src/Data/THGen/XML.hs +152/−47
- src/Text/XML/ParentAttributes.hs +53/−0
- test/Main.hs +7/−0
- test/TestDefs.hs +27/−0
- xml-isogen.cabal +25/−4
CHANGELOG.md view
@@ -1,3 +1,8 @@+0.2.0+-------++* Builds with GHC 7.10.3, 8.0.2 and 8.2.1+ 0.1.0 -------
+ README.md view
@@ -0,0 +1,9 @@+# xml-isogen++[](https://travis-ci.org/typeable/xml-isogen)++TemplateHaskell generators for XML-isomorphic data types, including+instances for parsing and rendering. A convenient DSL to define those+types.++This is similar to XSD but is Haskell-specific.
+ src/Data/THGen/Compat.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}++module Data.THGen.Compat+ ( dataD+ , strictType+ , varStrictType+ ) where++import qualified Language.Haskell.TH as TH++dataD :: TH.Name -> [TH.ConQ] -> [TH.Name] -> TH.DecQ+#if MIN_VERSION_template_haskell(2,12,0)+dataD name cons derivs = TH.dataD (return []) name [] Nothing cons [derivCls]+ where+ derivCls = TH.derivClause Nothing $ fmap TH.conT derivs+#elif MIN_VERSION_template_haskell(2,11,0)+dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls+ where+ derivCls = traverse TH.conT derivs+#else+dataD name = TH.dataD (return []) name []+#endif++#if MIN_VERSION_template_haskell(2,11,0)+strictType :: TH.TypeQ -> TH.BangTypeQ+strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)+#else+strictType :: TH.TypeQ -> TH.StrictTypeQ+strictType = TH.strictType TH.isStrict+#endif++#if MIN_VERSION_template_haskell(2,11,0)+varStrictType :: TH.Name -> TH.BangTypeQ -> TH.VarBangTypeQ+varStrictType = TH.varBangType+#else+varStrictType :: TH.Name -> TH.StrictTypeQ -> TH.VarStrictTypeQ+varStrictType = TH.varStrictType+#endif
src/Data/THGen/Enum.hs view
@@ -25,9 +25,10 @@ ) where import Control.Applicative-import Control.Lens (over, _head)+import Control.Lens (over, _head, (<&>)) import Control.Monad import qualified Data.Char as C+import Data.THGen.Compat import qualified Language.Haskell.TH as TH import qualified Test.QuickCheck as QC import qualified Text.Read as R@@ -62,11 +63,11 @@ . words enumGenerate :: EnumDesc -> TH.DecsQ-enumGenerate (EnumDesc exh strName strVals') = do+enumGenerate (EnumDesc exh strName strVals) = do let name = TH.mkName strName- strVals = map mangleEnumConName strVals'- vals = map (\strVal -> TH.mkName (strName ++ strVal)) strVals+ vals = strVals <&> \strVal ->+ TH.mkName (strName ++ mangleEnumConName strVal) unknownVal = TH.mkName ("Unknown" ++ strName) dataDecl <- do let@@ -74,11 +75,9 @@ unknownConstr = case exh of Exhaustive -> [] NonExhaustive ->- [TH.normalC unknownVal [TH.strictType TH.isStrict [t|String|]]]- TH.dataD- (return [])+ [TH.normalC unknownVal [strictType [t|String|]]]+ dataD name- [] (constrs ++ unknownConstr) ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else []) showInstDecl <- do
src/Data/THGen/XML.hs view
@@ -111,6 +111,8 @@ , (?) , (*) , (+)+ , (!%)+ , (?%) , (&) , (=:=) -- Re-exports@@ -123,13 +125,17 @@ import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec) import qualified Data.Char as C import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (maybeToList, mapMaybe) import Data.String+import Data.THGen.Compat import Data.THGen.Enum import qualified Data.Text as T import qualified Language.Haskell.TH as TH import Prelude hiding ((+), (*)) import Text.XML.DOM.Parser+import Text.XML.ParentAttributes import qualified Text.XML.Writer as XW+import qualified Text.XML as X data XmlFieldPlural = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)@@ -137,14 +143,26 @@ | XmlFieldPluralRepeated -- Occurs 0 or more times (List) | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty) +data XmlAttributePlural+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)+ data PrefixName = PrefixName String String data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ +data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ+ data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ -data IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescField]+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ +data IsoXmlDescRecordPart+ = IsoXmlDescRecordField IsoXmlDescField+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute++newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]+ makePrisms ''IsoXmlDescRecord data ExhaustivenessName = ExhaustivenessName String Exhaustiveness@@ -165,25 +183,34 @@ -> IsoXmlDescPreField -> IsoXmlDescRecord appendField plural xrec (IsoXmlDescPreField name ty) =- let xfield = IsoXmlDescField plural name ty+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty in over _IsoXmlDescRecord (xfield:) xrec -(!) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord-(!) = appendField XmlFieldPluralMandatory+appendAttribute+ :: XmlAttributePlural+ -> IsoXmlDescRecord+ -> IsoXmlDescPreAttribute+ -> IsoXmlDescRecord+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty+ in over _IsoXmlDescRecord (xattribute:) xrec -(?) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord+(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord+(!) = appendField XmlFieldPluralMandatory (?) = appendField XmlFieldPluralOptional--(*) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord (*) = appendField XmlFieldPluralRepeated--(+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord (+) = appendField XmlFieldPluralMultiplied +(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord+(!%) = appendAttribute XmlAttributePluralMandatory+(?%) = appendAttribute XmlAttributePluralOptional+ infixl 2 ! infixl 2 ? infixl 2 * infixl 2 ++infixl 2 !%+infixl 2 ?% appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum appendEnumCon xenum xenumcon =@@ -201,8 +228,8 @@ instance Description PrefixName IsoXmlDescRecord where prefixName =:= descRecord =- let descFields = descRecord ^. _IsoXmlDescRecord- in isoXmlGenerateRecord prefixName (reverse descFields)+ let descRecordParts = descRecord ^. _IsoXmlDescRecord+ in isoXmlGenerateRecord prefixName (reverse descRecordParts) record :: IsoXmlDescRecord record = IsoXmlDescRecord []@@ -223,6 +250,14 @@ where ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name) +instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where+ fromString = IsoXmlDescPreAttribute++instance IsString IsoXmlDescPreAttribute where+ fromString name = IsoXmlDescPreAttribute name ty+ where+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)+ instance s ~ String => IsString (s -> PrefixName) where fromString = PrefixName @@ -251,20 +286,30 @@ name = TH.mkName strName enumDecls <- enumGenerate enumDesc toXmlInst <- do- let toXmlExpr = [e|XW.toXML . T.pack . show|] TH.instanceD (return []) [t|XW.ToXML $(TH.conT name)|]- [funSimple 'XW.toXML toXmlExpr]+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]+ toXmlAttributeInst <- do+ TH.instanceD+ (return [])+ [t|ToXmlAttribute $(TH.conT name)|]+ [funSimple 'toXmlAttribute [e|T.pack . show|]] fromDomInst <- do TH.instanceD (return []) [t|FromDom $(TH.conT name)|]- [ funSimple 'fromDom [e|parseContent readContent|] ]- return (enumDecls ++ [toXmlInst, fromDomInst])+ [funSimple 'fromDom [e|parseContent readContent|]]+ fromAttributeInst <- do+ TH.instanceD+ (return [])+ [t|FromAttribute $(TH.conT name)|]+ [funSimple 'fromAttribute [e|readContent|]]+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,+ fromDomInst, fromAttributeInst] -isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescField] -> TH.DecsQ-isoXmlGenerateRecord (PrefixName strName' strPrefix') descFields = do+isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ+isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do let strName = "Xml" ++ strName' strPrefix = "x" ++ strPrefix'@@ -272,35 +317,60 @@ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str dataDecl <- do let- constructors = do- IsoXmlDescField fieldPlural fieldStrName fieldType <- descFields- let- fName = TH.mkName (fieldName fieldStrName)- fType = case fieldPlural of- XmlFieldPluralMandatory -> fieldType- XmlFieldPluralOptional -> [t| Maybe $fieldType |]- XmlFieldPluralRepeated -> [t| [$fieldType] |]- XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]- return $ TH.varStrictType fName (TH.strictType TH.isStrict fType)- TH.dataD- (return [])+ fields = do+ descRecordPart <- descRecordParts+ return $ case descRecordPart of+ IsoXmlDescRecordField descField ->+ let+ IsoXmlDescField fieldPlural fieldStrName fieldType = descField+ fName = TH.mkName (fieldName fieldStrName)+ fType = case fieldPlural of+ XmlFieldPluralMandatory -> fieldType+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]+ XmlFieldPluralRepeated -> [t| [$fieldType] |]+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]+ in+ varStrictType fName (strictType fType)+ IsoXmlDescRecordAttribute descAttribute ->+ let+ IsoXmlDescAttribute+ attributePlural attributeStrName attributeType = descAttribute+ fName = TH.mkName (fieldName attributeStrName)+ fType = case attributePlural of+ XmlAttributePluralMandatory -> attributeType+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]+ in+ varStrictType fName (strictType fType)+ dataD name- []- [TH.recC name constructors]+ [TH.recC name fields] [''Eq, ''Show] lensDecls <- makeFieldOpticsForDec lensRules dataDecl fromDomInst <- do let- exprHeader = [e|pure $(TH.conE name)|]- exprFields = do- IsoXmlDescField fieldPlural fieldStrName _ <- descFields- let- exprFieldStrName = TH.litE (TH.stringL fieldStrName)- fieldParse = case fieldPlural of- XmlFieldPluralMandatory -> [e|inElem|]- _ -> [e|inElemTrav|]- return [e|$fieldParse $exprFieldStrName fromDom|]- fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprFields+ exprHeader = [e|pure $(TH.conE name)|]+ exprRecordParts = do+ descRecordPart <- descRecordParts+ return $ case descRecordPart of+ IsoXmlDescRecordField descField ->+ let+ IsoXmlDescField fieldPlural fieldStrName _ = descField+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)+ fieldParse = case fieldPlural of+ XmlFieldPluralMandatory -> [e|inElem|]+ _ -> [e|inElemTrav|]+ in+ [e|$fieldParse $exprFieldStrName fromDom|]+ IsoXmlDescRecordAttribute descAttribute ->+ let+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)+ attributeParse = case attributePlural of+ XmlAttributePluralMandatory -> [e|parseAttribute|]+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]+ in+ [e|$attributeParse $exprAttributeStrName fromAttribute|]+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts TH.instanceD (return []) [t|FromDom $(TH.conT name)|]@@ -309,24 +379,59 @@ toXmlInst <- do objName <- TH.newName strPrefix let- exprFooter = [e|return ()|] exprFields = do- IsoXmlDescField fieldPlural fieldStrName _ <- descFields+ descRecordPart <- descRecordParts+ IsoXmlDescField fieldPlural fieldStrName _ <-+ maybeToList $ case descRecordPart of+ IsoXmlDescRecordField descField -> Just descField+ _ -> Nothing let- fieldRender = [e|XW.toXML|] fName = TH.mkName (fieldName fieldStrName) exprFieldStrName = TH.litE (TH.stringL fieldStrName) exprForField = case fieldPlural of XmlFieldPluralMandatory -> [e|id|] _ -> [e|traverse|] exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]- exprFieldRender = [e|XW.element $exprFieldStrName . $fieldRender|]+ exprFieldRender = [e|mkElement $exprFieldStrName|] return [e|$exprForField $exprFieldRender $exprFieldValue|] toXmlExpr = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]- $ foldr (\fe e -> [e|$fe *> $e|]) exprFooter exprFields+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields TH.instanceD (return []) [t|XW.ToXML $(TH.conT name)|] [funSimple 'XW.toXML toXmlExpr]- return $ [dataDecl] ++ lensDecls ++ [fromDomInst, toXmlInst]++ toXmlParentAttributesInst <- do+ objName <- TH.newName strPrefix+ let+ exprAttributes = do+ descRecordPart <- descRecordParts+ IsoXmlDescAttribute attributePlural attributeStrName _ <-+ maybeToList $ case descRecordPart of+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute+ _ -> Nothing+ let+ fName = TH.mkName (fieldName attributeStrName)+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]+ exprAttrWrap = case attributePlural of+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]+ toXmlParentAttributesExpr+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]+ TH.instanceD+ (return [])+ [t|ToXmlParentAttributes $(TH.conT name)|]+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]++ return $ [dataDecl] ++ lensDecls +++ [fromDomInst, toXmlInst, toXmlParentAttributesInst]++mkElement :: (XW.ToXML a, ToXmlParentAttributes a) => X.Name -> a -> XW.XML+mkElement name a = XW.elementA name (toXmlParentAttributes a) a++distribPair :: Functor f => (a, f b) -> f (a, b)+distribPair (a, fb) = (a,) <$> fb
+ src/Text/XML/ParentAttributes.hs view
@@ -0,0 +1,53 @@+module Text.XML.ParentAttributes+ ( ToXmlParentAttributes(..)+ , ToXmlAttribute(..)+ , toXmlAttributeIntegral+ ) where++import Data.Text as T.S+import Data.Text.Lazy as T.L+import Data.Text.Lazy.Builder as T.L+import Data.Text.Lazy.Builder.Int as T.L+import Numeric.Natural+import Text.XML++class ToXmlParentAttributes a where+ toXmlParentAttributes :: a -> [(Name, T.S.Text)]++-- | A catch-all instance: by default objects don't have parent attributes.+-- The alternative solution is to write a default implementation in the class,+-- but it has a drawback that it requires numerous (boilerplate) empty+-- instances - one for each type that doesn't have parent attributes (most+-- types). This overlappable instance gets overriden for XML records+-- (described in "Data.THGen.XML") because they can store parent attributes+-- added via the @!%@ and @?%@ operators.+-- For example, `toXmlParentAttributes` applied to a `Text` or `Integer' value+-- returns @[]@ because of this instance. However, an XML record defined as+-- @"Foo" =:= record !% "bar"@ will have its own TH-generated+-- `ToXmlParentAttributes` instance that inspects the value of its @bar@ field+-- and returns it as an attribute.+-- This way the TH-generators can safely apply `toXmlParentAttributes` to any+-- value without worrying about missing instances.+instance {-# OVERLAPPABLE #-} ToXmlParentAttributes a where+ toXmlParentAttributes _ = []++class ToXmlAttribute a where+ toXmlAttribute :: a -> T.S.Text++instance ToXmlAttribute T.S.Text where+ toXmlAttribute = id++toXmlAttributeIntegral :: Integral a => a -> T.S.Text+toXmlAttributeIntegral = T.L.toStrict . T.L.toLazyText . T.L.decimal++instance ToXmlAttribute Int where+ toXmlAttribute = toXmlAttributeIntegral++instance ToXmlAttribute Word where+ toXmlAttribute = toXmlAttributeIntegral++instance ToXmlAttribute Integer where+ toXmlAttribute = toXmlAttributeIntegral++instance ToXmlAttribute Natural where+ toXmlAttribute = toXmlAttributeIntegral
+ test/Main.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS -fno-warn-unused-imports #-}+module Main where++import TestDefs++main :: IO ()+main = return ()
+ test/TestDefs.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS -ddump-splices #-}++module TestDefs where++import Data.THGen.XML++"Bar" =:= enum+ & "baroque"+ & "bartender"++"Quux" Exhaustive =:= enum+ & "ALL"+ & "YOUR"+ & "BASE"+ & "ARE"+ & "BELONG"+ & "TO"+ & "US"++"Foo" =:= record+ + "Bar"+ ? "Baz" [t|Text|]+ !% "Quux"
xml-isogen.cabal view
@@ -1,5 +1,5 @@ name: xml-isogen-version: 0.1.0+version: 0.2.0 synopsis: Generate XML-isomorphic types description: TemplateHaskell generators for XML-isomorphic data types, including@@ -14,21 +14,32 @@ maintainer: makeit@typeable.io category: Data build-type: Simple-extra-source-files: CHANGELOG.md cabal-version: >=1.22+homepage: https://github.com/typeable/xml-isogen+tested-with: GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.1+extra-source-files: CHANGELOG.md+ , README.md +source-repository head+ type: git+ location: git@github.com:typeable/xml-isogen.git+ library exposed-modules: Data.THGen.Enum Data.THGen.XML-+ Text.XML.ParentAttributes+ other-modules: Data.THGen.Compat build-depends: QuickCheck >= 2.8 , base >=4.8 && <5- , dom-parser >= 0.1.0+ , dom-parser >= 2.0.0 , lens >= 4.13 , mtl >= 2.2 , semigroups >= 0.18 , template-haskell >= 2.10 , text >= 1.2+ , xml-conduit >= 1.0 , xml-conduit-writer >= 0.1 hs-source-dirs: src@@ -38,3 +49,13 @@ LambdaCase FlexibleInstances TypeFamilies+ TupleSections++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: TestDefs+ build-depends: base, xml-isogen+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-missing-signatures