diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.2.0 +------- + +* Builds with GHC 7.10.3, 8.0.2 and 8.2.1 + 0.1.0 ------- diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# xml-isogen + +[![Build Status](https://travis-ci.org/typeable/xml-isogen.svg?branch=master)](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. diff --git a/src/Data/THGen/Compat.hs b/src/Data/THGen/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/THGen/Compat.hs @@ -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 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,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 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 @@ -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 diff --git a/src/Text/XML/ParentAttributes.hs b/src/Text/XML/ParentAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/ParentAttributes.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +{-# OPTIONS -fno-warn-unused-imports #-} +module Main where + +import TestDefs + +main :: IO () +main = return () diff --git a/test/TestDefs.hs b/test/TestDefs.hs new file mode 100644 --- /dev/null +++ b/test/TestDefs.hs @@ -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" 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.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