diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------ diff --git a/src/Data/THGen/Compat.hs b/src/Data/THGen/Compat.hs --- a/src/Data/THGen/Compat.hs +++ b/src/Data/THGen/Compat.hs @@ -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) diff --git a/src/Data/THGen/Enum.hs b/src/Data/THGen/Enum.hs --- a/src/Data/THGen/Enum.hs +++ b/src/Data/THGen/Enum.hs @@ -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] diff --git a/src/Data/THGen/XML.hs b/src/Data/THGen/XML.hs --- a/src/Data/THGen/XML.hs +++ b/src/Data/THGen/XML.hs @@ -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 diff --git a/test/TestDefs.hs b/test/TestDefs.hs --- a/test/TestDefs.hs +++ b/test/TestDefs.hs @@ -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 diff --git a/xml-isogen.cabal b/xml-isogen.cabal --- a/xml-isogen.cabal +++ b/xml-isogen.cabal @@ -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