xml-isogen 0.2.1 → 0.3.0
raw patch · 6 files changed
+92/−31 lines, 6 filesdep +deepseq
Dependencies added: deepseq
Files
- CHANGELOG.md +10/−0
- src/Data/THGen/Compat.hs +23/−0
- src/Data/THGen/Enum.hs +10/−2
- src/Data/THGen/XML.hs +43/−21
- test/TestDefs.hs +1/−6
- xml-isogen.cabal +5/−2
CHANGELOG.md view
@@ -1,3 +1,13 @@+HEAD+------++0.3.0+------++* Add namespaces support+* Builds with GHC 8.4+* Derive NFData for all generated datatypes+ 0.2.1 ------
src/Data/THGen/Compat.hs view
@@ -2,6 +2,8 @@ module Data.THGen.Compat ( dataD+ , newtypeD+ , nonStrictType , strictType , varStrictType ) where@@ -19,6 +21,27 @@ derivCls = traverse TH.conT derivs #else dataD name = TH.dataD (return []) name []+#endif++newtypeD :: TH.Name -> TH.ConQ -> [TH.Name] -> TH.DecQ+#if MIN_VERSION_template_haskell(2,12,0)+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons [derivCls]+ where+ derivCls = TH.derivClause Nothing $ fmap TH.conT derivs+#elif MIN_VERSION_template_haskell(2,11,0)+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons derivCls+ where+ derivCls = traverse TH.conT derivs+#else+newtypeD name = TH.newtypeD (return []) name []+#endif++#if MIN_VERSION_template_haskell(2,11,0)+nonStrictType :: TH.TypeQ -> TH.BangTypeQ+nonStrictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.noSourceStrictness)+#else+nonStrictType :: TH.TypeQ -> TH.StrictTypeQ+nonStrictType = TH.strictType TH.notStrict #endif #if MIN_VERSION_template_haskell(2,11,0)
src/Data/THGen/Enum.hs view
@@ -25,14 +25,17 @@ ) where import Control.Applicative+import Control.DeepSeq import Control.Lens (over, _head, (<&>)) import Control.Monad import qualified Data.Char as C import Data.THGen.Compat+import GHC.Generics (Generic) import qualified Language.Haskell.TH as TH import qualified Test.QuickCheck as QC import qualified Text.Read as R + data Exhaustiveness = Exhaustive | NonExhaustive deriving (Eq, Ord, Show) @@ -79,7 +82,7 @@ dataD name (constrs ++ unknownConstr)- ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else []) showInstDecl <- do unknownMatch <- case exh of Exhaustive -> return []@@ -126,4 +129,9 @@ (return []) [t|QC.Arbitrary $(TH.conT name)|] [funSimple 'QC.arbitrary arbExpr]- return [dataDecl, readInstDecl, showInstDecl, arbInstance]+ nfDataInst <- do+ TH.instanceD+ (return [])+ [t|NFData $(TH.conT name)|]+ []+ return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]
src/Data/THGen/XML.hs view
@@ -121,6 +121,7 @@ , Integer ) where +import Control.DeepSeq import Control.Lens hiding (repeated, enum, (&)) import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec) import qualified Data.Char as C@@ -130,13 +131,16 @@ import Data.THGen.Compat import Data.THGen.Enum import qualified Data.Text as T+import GHC.Generics (Generic) import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH import Prelude hiding ((+), (*))+import qualified Text.XML as X 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) | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)@@ -229,7 +233,7 @@ instance Description PrefixName IsoXmlDescRecord where prefixName =:= descRecord = let descRecordParts = descRecord ^. _IsoXmlDescRecord- in isoXmlGenerateRecord prefixName (reverse descRecordParts)+ in isoXmlGenerateDatatype prefixName (reverse descRecordParts) record :: IsoXmlDescRecord record = IsoXmlDescRecord []@@ -248,7 +252,7 @@ instance IsString IsoXmlDescPreField where fromString name = IsoXmlDescPreField name ty where- ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name)) instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where fromString = IsoXmlDescPreAttribute@@ -308,29 +312,32 @@ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst, fromDomInst, fromAttributeInst] -isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ-isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do+isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ+isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do let+ isNewtype = length descRecordParts == 1 strName = "Xml" ++ strName' strPrefix = "x" ++ strPrefix' name = TH.mkName strName fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str- dataDecl <- do+ termDecl <- do let fields = do descRecordPart <- descRecordParts return $ case descRecordPart of IsoXmlDescRecordField descField -> let- IsoXmlDescField fieldPlural fieldStrName fieldType = descField+ IsoXmlDescField fieldPlural rawName fieldType = descField+ fieldStrName = xmlLocalName rawName 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)+ in if isNewtype+ then varStrictType fName (nonStrictType fType)+ else varStrictType fName (strictType fType) IsoXmlDescRecordAttribute descAttribute -> let IsoXmlDescAttribute@@ -339,13 +346,19 @@ fType = case attributePlural of XmlAttributePluralMandatory -> attributeType XmlAttributePluralOptional -> [t| Maybe $attributeType |]- in- varStrictType fName (strictType fType)- dataD- name- [TH.recC name fields]- [''Eq, ''Show]- lensDecls <- makeFieldOpticsForDec lensRules dataDecl+ in if isNewtype+ then varStrictType fName (nonStrictType fType)+ else varStrictType fName (strictType fType)+ if isNewtype+ -- generate a newtype instead to do less allocations later+ then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]+ else dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]+ lensDecls <- makeFieldOpticsForDec lensRules termDecl+ nfDataInst <- do+ TH.instanceD+ (return [])+ [t|NFData $(TH.conT name)|]+ [ ] fromDomInst <- do let exprHeader = [e|pure $(TH.conE name)|]@@ -354,7 +367,8 @@ return $ case descRecordPart of IsoXmlDescRecordField descField -> let- IsoXmlDescField fieldPlural fieldStrName _ = descField+ IsoXmlDescField fieldPlural rawName _ = descField+ fieldStrName = xmlLocalName rawName exprFieldStrName = TH.litE (TH.stringL fieldStrName) fieldParse = case fieldPlural of XmlFieldPluralMandatory -> [e|inElem|]@@ -381,13 +395,14 @@ let exprFields = do descRecordPart <- descRecordParts- IsoXmlDescField fieldPlural fieldStrName _ <-+ IsoXmlDescField fieldPlural rawName _ <- maybeToList $ case descRecordPart of IsoXmlDescRecordField descField -> Just descField _ -> Nothing let+ fieldStrName = xmlLocalName rawName fName = TH.mkName (fieldName fieldStrName)- exprFieldStrName = TH.litE (TH.stringL fieldStrName)+ exprFieldStrName = TH.litE (TH.stringL rawName) exprForField = case fieldPlural of XmlFieldPluralMandatory -> [e|id|] _ -> [e|traverse|]@@ -432,8 +447,15 @@ [t|ToXmlParentAttributes $(TH.conT name)|] [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr] - return $ [dataDecl] ++ lensDecls ++- [fromDomInst, toXmlInst, toXmlParentAttributesInst]+ return $ [termDecl] ++ lensDecls +++ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst] distribPair :: Functor f => (a, f b) -> f (a, b) distribPair (a, fb) = (a,) <$> fb++-- | Get a local part of (possibly) fully qualified 'X.Name':+--+-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"+-- "my-name"+xmlLocalName :: String -> String+xmlLocalName = T.unpack . X.nameLocalName . fromString
test/TestDefs.hs view
@@ -6,7 +6,6 @@ import Data.List.NonEmpty import Data.THGen.XML-import GHC.Generics (Generic) import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Instances () @@ -30,15 +29,11 @@ ?% "Muux" [t|XmlQuux|] "Root" =:= record- ! "Foo"--deriving instance Generic XmlRoot+ ! "{http://example.com/ns/my-namespace}Foo" instance Arbitrary XmlRoot where arbitrary = genericArbitrary shrink = genericShrink--deriving instance Generic XmlFoo instance Arbitrary XmlFoo where arbitrary = genericArbitrary
xml-isogen.cabal view
@@ -1,5 +1,5 @@ name: xml-isogen-version: 0.2.1+version: 0.3.0 synopsis: Generate XML-isomorphic types description: TemplateHaskell generators for XML-isomorphic data types, including@@ -18,7 +18,8 @@ homepage: https://github.com/typeable/xml-isogen tested-with: GHC == 7.10.3 , GHC == 8.0.2- , GHC == 8.2.1+ , GHC == 8.2.2+ , GHC == 8.4.1 extra-source-files: CHANGELOG.md , README.md @@ -34,6 +35,7 @@ build-depends: QuickCheck >= 2.8 , base >=4.8 && <5 , dom-parser >= 2.0.0+ , deepseq , lens >= 4.13 , mtl >= 2.2 , semigroups >= 0.18@@ -60,6 +62,7 @@ build-depends: base , QuickCheck , data-default+ , deepseq , dom-parser , generic-arbitrary , hspec