master..f4cb81d · xml-isogen

git.iko.soy/xml-isogen

on f4cb81d help sign in

.travis.ymldeleted−27

since splitsnapshots

unifiedsplit

@@ -1,27 +0,0 @@

1−sudo: false

2−

3−language: generic

4−

5−env:

6− - STACK_YAML=stack.yaml

7− - STACK_YAML=ghc-802.yaml

8− - STACK_YAML=ghc-822.yaml

9− - STACK_YAML=ghc-844.yaml

10−

11−cache:

12− directories:

13− - $HOME/.stack

14−

15−addons:

16− apt:

17− packages:

18− - libgmp-dev

19−

20−before_install:

21−# Download and unpack the stack executable

22−- mkdir -p ~/.local/bin

23−- export PATH=$HOME/.local/bin:$PATH

24−- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

25−

26−script:

27−- stack --no-terminal --install-ghc test --haddock --no-haddock-deps

CHANGELOG.md−22

@@ -1,25 +1,3 @@

1−HEAD

2−------

3−

4−0.3.0

5−------

6−

7−* Add namespaces support

8−* Builds with GHC 8.4

9−* Derive NFData for all generated datatypes

10−

11−0.2.1

12−------

13−

14−* Workaround for the GHC 8.2.1 attribute generation bug

15−

16−* Add tests checking run-time behaviour of generated code

17−

18−0.2.0

19−-------

20−

21−* Builds with GHC 7.10.3, 8.0.2 and 8.2.1

22−

230.1.0

10.1.0

24-------

2-------

README.mddeleted−9

@@ -1,9 +0,0 @@

1−# xml-isogen

2−

3−[![Build Status](https://travis-ci.org/typeable/xml-isogen.svg?branch=master)](https://travis-ci.org/typeable/xml-isogen)

4−

5−TemplateHaskell generators for XML-isomorphic data types, including

6−instances for parsing and rendering. A convenient DSL to define those

7−types.

8−

9−This is similar to XSD but is Haskell-specific.

ghc-802.yamldeleted−8

@@ -1,8 +0,0 @@

1−resolver: lts-9.21

2−

3−packages:

4−- .

5−

6−extra-deps:

7−- dom-parser-3.0.0

8−- generic-arbitrary-0.1.0

ghc-822.yamldeleted−1

@@ -1 +0,0 @@

1−resolver: lts-11.22

ghc-844.yamldeleted−3

@@ -1,3 +0,0 @@

1−resolver: lts-12.16

2−extra-deps:

3−- dom-parser-3.1.0

releasedeleted−35

@@ -1,35 +0,0 @@

1−#!/bin/bash

2−

3−set -o xtrace

4−

5−dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`

6−

7−echo -e "\033[1;36mTesting library...\033[0m"

8−stack test 2> /dev/null

9−

10−echo -e "\033[1;36mRunning sdist...\033[0m"

11−cabal sdist

12−

13−echo -e "\033[1;36mGenerating documentation...\033[0m"

14−stack haddock 2> /dev/null

15−

16−if [ "$?" -eq "0" ]; then

17− echo -e "\033[1;32mUploading package to Hackage...\033[0m"

18− read -p "Hackage username: " username

19− read -p "Hackage password: " -s password

20− echo ""

21− cabal upload -u $username -p $password dist/$1-$2.tar.gz

22−

23− docdir=$dist/doc/html

24− cd $docdir

25− doc=$1-$2-docs

26−

27− echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$1\033[0m-\033[1;33m$2\033[1;30m"

28− cp -r $1 $doc

29− tar -c -v -z --format=ustar -f $doc.tar.gz $doc

30− echo -e "\033[1;32mUploading documentation to Hackage...\033[0m"

31− curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"

32− exit $?

33−else

34− echo -e "\033[1;31mNot in a stack-powered project\033[0m"

35−fi

src/Data/THGen/Compat.hsdeleted−61

@@ -1,61 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−

3−module Data.THGen.Compat

4− ( dataD

5− , newtypeD

6− , nonStrictType

7− , strictType

8− , varStrictType

9− ) where

10−

11−import qualified Language.Haskell.TH as TH

12−

13−dataD :: TH.Name -> [TH.ConQ] -> [TH.Name] -> TH.DecQ

14−#if MIN_VERSION_template_haskell(2,12,0)

15−dataD name cons derivs = TH.dataD (return []) name [] Nothing cons [derivCls]

16− where

17− derivCls = TH.derivClause Nothing $ fmap TH.conT derivs

18−#elif MIN_VERSION_template_haskell(2,11,0)

19−dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls

20− where

21− derivCls = traverse TH.conT derivs

22−#else

23−dataD name = TH.dataD (return []) name []

24−#endif

25−

26−newtypeD :: TH.Name -> TH.ConQ -> [TH.Name] -> TH.DecQ

27−#if MIN_VERSION_template_haskell(2,12,0)

28−newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons [derivCls]

29− where

30− derivCls = TH.derivClause Nothing $ fmap TH.conT derivs

31−#elif MIN_VERSION_template_haskell(2,11,0)

32−newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons derivCls

33− where

34− derivCls = traverse TH.conT derivs

35−#else

36−newtypeD name = TH.newtypeD (return []) name []

37−#endif

38−

39−#if MIN_VERSION_template_haskell(2,11,0)

40−nonStrictType :: TH.TypeQ -> TH.BangTypeQ

41−nonStrictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.noSourceStrictness)

42−#else

43−nonStrictType :: TH.TypeQ -> TH.StrictTypeQ

44−nonStrictType = TH.strictType TH.notStrict

45−#endif

46−

47−#if MIN_VERSION_template_haskell(2,11,0)

48−strictType :: TH.TypeQ -> TH.BangTypeQ

49−strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)

50−#else

51−strictType :: TH.TypeQ -> TH.StrictTypeQ

52−strictType = TH.strictType TH.isStrict

53−#endif

54−

55−#if MIN_VERSION_template_haskell(2,11,0)

56−varStrictType :: TH.Name -> TH.BangTypeQ -> TH.VarBangTypeQ

57−varStrictType = TH.varBangType

58−#else

59−varStrictType :: TH.Name -> TH.StrictTypeQ -> TH.VarStrictTypeQ

60−varStrictType = TH.varStrictType

61−#endif

src/Data/THGen/Enum.hs+6−13

@@ -25,17 +25,13 @@ module Data.THGen.Enum

25 ) where

27import Control.Applicative

28−import Control.DeepSeq

29import Control.Lens (over, _head, (<&>))

28import Control.Lens (over, _head, (<&>))

30import Control.Monad

29import Control.Monad

31import qualified Data.Char as C

30import qualified Data.Char as C

32−import Data.THGen.Compat

33−import GHC.Generics (Generic)

34import qualified Language.Haskell.TH as TH

31import qualified Language.Haskell.TH as TH

35import qualified Test.QuickCheck as QC

32import qualified Test.QuickCheck as QC

36import qualified Text.Read as R

33import qualified Text.Read as R

38−

39data Exhaustiveness = Exhaustive | NonExhaustive

35data Exhaustiveness = Exhaustive | NonExhaustive

40 deriving (Eq, Ord, Show)

36 deriving (Eq, Ord, Show)

@@ -78,11 +74,13 @@ enumGenerate (EnumDesc exh strName strVals) = do

78 unknownConstr = case exh of

74 unknownConstr = case exh of

79 Exhaustive -> []

75 Exhaustive -> []

80 NonExhaustive ->

76 NonExhaustive ->

81− [TH.normalC unknownVal [strictType [t|String|]]]

77+ [TH.normalC unknownVal [TH.strictType TH.isStrict [t|String|]]]

82− dataD

78+ TH.dataD

79+ (return [])

83 name

80 name

81+ []

84 (constrs ++ unknownConstr)

82 (constrs ++ unknownConstr)

85− ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])

83+ ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])

86 showInstDecl <- do

84 showInstDecl <- do

87 unknownMatch <- case exh of

85 unknownMatch <- case exh of

88 Exhaustive -> return []

86 Exhaustive -> return []

@@ -129,9 +127,4 @@ enumGenerate (EnumDesc exh strName strVals) = do

129 (return [])

127 (return [])

130 [t|QC.Arbitrary $(TH.conT name)|]

128 [t|QC.Arbitrary $(TH.conT name)|]

131 [funSimple 'QC.arbitrary arbExpr]

129 [funSimple 'QC.arbitrary arbExpr]

132− nfDataInst <- do

133− TH.instanceD

134− (return [])

135− [t|NFData $(TH.conT name)|]

136− []

137− return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]

130+ return [dataDecl, readInstDecl, showInstDecl, arbInstance]

src/Data/THGen/XML.hs+326−20

@@ -1,4 +1,5 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

1+{-# LANGUAGE UndecidableInstances #-}

2+{-# LANGUAGE FunctionalDependencies #-}

3{- |

4{- |

@@ -22,7 +23,7 @@ wrapper around the field type:

23Example 1.

24Example 1.

25−> "Color" =:= enum Both

26+> "Color" =:= enum

26> & "R"

27> & "R"

27> & "G"

28> & "G"

28> & "B"

29> & "B"

@@ -40,7 +41,7 @@ to be either @R@, @G@ or @B@.

41Example 2.

42Example 2.

43−> "Message" =:= record Both

44+> "Message" =:= record

44> ! "author"

45> ! "author"

45> + "recipient"

46> + "recipient"

46> ? "message" [t|Text|]

47> ? "message" [t|Text|]

@@ -67,10 +68,10 @@ enumeration is exhaustive (contains only the listed constructors) or

67non-exhaustive (also contains a constructor for unknown values; this

68non-exhaustive (also contains a constructor for unknown values; this

68is the default):

69is the default):

70−> "Enum1" Exhaustive =:= enum Generator

71+> "Enum1" Exhaustive =:= enum

71> ...

72> ...

73−> "Enum2" NonExhaustive =:= enum Generator

74+> "Enum2" NonExhaustive =:= enum

74> ...

75> ...

76To define a record, use the `record` function followed by the name of

77To define a record, use the `record` function followed by the name of

@@ -78,7 +79,7 @@ the data type to be generated. The prefix for the record fields is

78inferred automatically by taking all of the uppercase letters in the

79inferred automatically by taking all of the uppercase letters in the

79name. You can override it manually like so:

80name. You can override it manually like so:

81−> "Reference" "ref" =:= record Parser

82+> "Reference" "ref" =:= record

82> ...

83> ...

84To describe a record field you must supply its name as it appears

85To describe a record field you must supply its name as it appears

@@ -93,14 +94,10 @@ The type of the field is inferred automatically from its name, so

93if the field is called @"author"@ its type will be @Author@. You can

94if the field is called @"author"@ its type will be @Author@. You can

94override the type by specifying it in quasiquotes like so:

95override the type by specifying it in quasiquotes like so:

96−> "Message" =:= record Both

97+> "Message" =:= record

97−> ! "author" [t|Person|].

98+> ! "author" [t|Person|]

98> ...

99> ...

100

100−Both @record@ and @enum@ take a @GenType@ argument which tells it to generate

101−generator, parser or both. It's being used to optimize compilation time by

102−skipping the unnecessary TH instance generation.

103−

104-}

101-}

105

102

106

103

@@ -108,7 +105,6 @@ module Data.THGen.XML

108 ( Exhaustiveness(..)

105 ( Exhaustiveness(..)

109 , PrefixName(..)

106 , PrefixName(..)

110 , ExhaustivenessName(..)

107 , ExhaustivenessName(..)

111− , GenType(..)

112 , record

108 , record

113 , enum

109 , enum

114 , (!)

110 , (!)

@@ -118,15 +114,325 @@ module Data.THGen.XML

118 , (!%)

114 , (!%)

119 , (?%)

115 , (?%)

120 , (&)

116 , (&)

121− , (^)

122 , (=:=)

117 , (=:=)

123 -- Re-exports

118 -- Re-exports

124− , Text

119+ , T.Text

125− , P.Int

120+ , Int

126− , P.Integer

121+ , Integer

127 ) where

122 ) where

128

123

124+import Control.Lens hiding (repeated, enum, (&))

125+import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)

126+import qualified Data.Char as C

127+import Data.List.NonEmpty (NonEmpty)

128+import Data.Maybe (maybeToList, mapMaybe)

129+import Data.String

129import Data.THGen.Enum

130import Data.THGen.Enum

130−import Data.THGen.XML.Internal

131−import Data.Text

131+import qualified Data.Text as T

132−import qualified Prelude as P

132+import qualified Language.Haskell.TH as TH

133+import Prelude hiding ((+), (*))

134+import Text.XML.DOM.Parser

135+import Text.XML.ParentAttributes

136+import qualified Text.XML.Writer as XW

137+import qualified Text.XML as X

138+

139+data XmlFieldPlural

140+ = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)

141+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)

142+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)

143+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)

144+

145+data XmlAttributePlural

146+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)

147+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)

148+

149+data PrefixName = PrefixName String String

150+

151+data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ

152+

153+data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

154+

155+data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

156+

157+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

158+

159+data IsoXmlDescRecordPart

160+ = IsoXmlDescRecordField IsoXmlDescField

161+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute

162+

163+newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]

164+

165+makePrisms ''IsoXmlDescRecord

166+

167+data ExhaustivenessName = ExhaustivenessName String Exhaustiveness

168+

169+newtype IsoXmlDescEnumCon

170+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }

171+

172+instance IsString IsoXmlDescEnumCon where

173+ fromString = IsoXmlDescEnumCon

174+

175+data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]

176+

177+makePrisms ''IsoXmlDescEnum

178+

179+appendField

180+ :: XmlFieldPlural

181+ -> IsoXmlDescRecord

182+ -> IsoXmlDescPreField

183+ -> IsoXmlDescRecord

184+appendField plural xrec (IsoXmlDescPreField name ty) =

185+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

186+ in over _IsoXmlDescRecord (xfield:) xrec

187+

188+appendAttribute

189+ :: XmlAttributePlural

190+ -> IsoXmlDescRecord

191+ -> IsoXmlDescPreAttribute

192+ -> IsoXmlDescRecord

193+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =

194+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

195+ in over _IsoXmlDescRecord (xattribute:) xrec

196+

197+(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord

198+(!) = appendField XmlFieldPluralMandatory

199+(?) = appendField XmlFieldPluralOptional

200+(*) = appendField XmlFieldPluralRepeated

201+(+) = appendField XmlFieldPluralMultiplied

202+

203+(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord

204+(!%) = appendAttribute XmlAttributePluralMandatory

205+(?%) = appendAttribute XmlAttributePluralOptional

206+

207+infixl 2 !

208+infixl 2 ?

209+infixl 2 *

210+infixl 2 +

211+infixl 2 !%

212+infixl 2 ?%

213+

214+appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

215+appendEnumCon xenum xenumcon =

216+ over _IsoXmlDescEnum (xenumcon:) xenum

217+

218+(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

219+(&) = appendEnumCon

220+

221+infixl 2 &

222+

223+class Description name desc | desc -> name where

224+ (=:=) :: name -> desc -> TH.DecsQ

225+

226+infix 0 =:=

227+

228+instance Description PrefixName IsoXmlDescRecord where

229+ prefixName =:= descRecord =

230+ let descRecordParts = descRecord ^. _IsoXmlDescRecord

231+ in isoXmlGenerateRecord prefixName (reverse descRecordParts)

232+

233+record :: IsoXmlDescRecord

234+record = IsoXmlDescRecord []

235+

236+enum :: IsoXmlDescEnum

237+enum = IsoXmlDescEnum []

238+

239+instance Description ExhaustivenessName IsoXmlDescEnum where

240+ exhaustivenessName =:= descEnum =

241+ let descEnumCons = descEnum ^. _IsoXmlDescEnum

242+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)

243+

244+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where

245+ fromString = IsoXmlDescPreField

246+

247+instance IsString IsoXmlDescPreField where

248+ fromString name = IsoXmlDescPreField name ty

249+ where

250+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)

251+

252+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where

253+ fromString = IsoXmlDescPreAttribute

254+

255+instance IsString IsoXmlDescPreAttribute where

256+ fromString name = IsoXmlDescPreAttribute name ty

257+ where

258+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)

259+

260+instance s ~ String => IsString (s -> PrefixName) where

261+ fromString = PrefixName

262+

263+instance IsString PrefixName where

264+ fromString strName = PrefixName strName (makeNamePrefix strName)

265+

266+instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where

267+ fromString = ExhaustivenessName

268+

269+instance IsString ExhaustivenessName where

270+ fromString strName = ExhaustivenessName strName NonExhaustive

271+

272+makeNamePrefix :: String -> String

273+makeNamePrefix = map C.toLower . filter C.isUpper

274+

275+funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ

276+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]

277+

278+isoXmlGenerateEnum

279+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ

280+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do

281+ let

282+ strName = "Xml" ++ strName'

283+ strVals = map unIsoXmlDescEnumCon enumCons

284+ enumDesc = EnumDesc exh strName strVals

285+ name = TH.mkName strName

286+ enumDecls <- enumGenerate enumDesc

287+ toXmlInst <- do

288+ TH.instanceD

289+ (return [])

290+ [t|XW.ToXML $(TH.conT name)|]

291+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]

292+ toXmlAttributeInst <- do

293+ TH.instanceD

294+ (return [])

295+ [t|ToXmlAttribute $(TH.conT name)|]

296+ [funSimple 'toXmlAttribute [e|T.pack . show|]]

297+ fromDomInst <- do

298+ TH.instanceD

299+ (return [])

300+ [t|FromDom $(TH.conT name)|]

301+ [funSimple 'fromDom [e|parseContent readContent|]]

302+ fromAttributeInst <- do

303+ TH.instanceD

304+ (return [])

305+ [t|FromAttribute $(TH.conT name)|]

306+ [funSimple 'fromAttribute [e|readContent|]]

307+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

308+ fromDomInst, fromAttributeInst]

309+

310+isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ

311+isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do

312+ let

313+ strName = "Xml" ++ strName'

314+ strPrefix = "x" ++ strPrefix'

315+ name = TH.mkName strName

316+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str

317+ dataDecl <- do

318+ let

319+ fields = do

320+ descRecordPart <- descRecordParts

321+ return $ case descRecordPart of

322+ IsoXmlDescRecordField descField ->

323+ let

324+ IsoXmlDescField fieldPlural fieldStrName fieldType = descField

325+ fName = TH.mkName (fieldName fieldStrName)

326+ fType = case fieldPlural of

327+ XmlFieldPluralMandatory -> fieldType

328+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]

329+ XmlFieldPluralRepeated -> [t| [$fieldType] |]

330+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]

331+ in

332+ TH.varStrictType fName (TH.strictType TH.isStrict fType)

333+ IsoXmlDescRecordAttribute descAttribute ->

334+ let

335+ IsoXmlDescAttribute

336+ attributePlural attributeStrName attributeType = descAttribute

337+ fName = TH.mkName (fieldName attributeStrName)

338+ fType = case attributePlural of

339+ XmlAttributePluralMandatory -> attributeType

340+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]

341+ in

342+ TH.varStrictType fName (TH.strictType TH.isStrict fType)

343+ TH.dataD

344+ (return [])

345+ name

346+ []

347+ [TH.recC name fields]

348+ [''Eq, ''Show]

349+ lensDecls <- makeFieldOpticsForDec lensRules dataDecl

350+ fromDomInst <- do

351+ let

352+ exprHeader = [e|pure $(TH.conE name)|]

353+ exprRecordParts = do

354+ descRecordPart <- descRecordParts

355+ return $ case descRecordPart of

356+ IsoXmlDescRecordField descField ->

357+ let

358+ IsoXmlDescField fieldPlural fieldStrName _ = descField

359+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)

360+ fieldParse = case fieldPlural of

361+ XmlFieldPluralMandatory -> [e|inElem|]

362+ _ -> [e|inElemTrav|]

363+ in

364+ [e|$fieldParse $exprFieldStrName fromDom|]

365+ IsoXmlDescRecordAttribute descAttribute ->

366+ let

367+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

368+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)

369+ attributeParse = case attributePlural of

370+ XmlAttributePluralMandatory -> [e|parseAttribute|]

371+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

372+ in

373+ [e|$attributeParse $exprAttributeStrName fromAttribute|]

374+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts

375+ TH.instanceD

376+ (return [])

377+ [t|FromDom $(TH.conT name)|]

378+ [ funSimple 'fromDom fromDomExpr ]

379+

380+ toXmlInst <- do

381+ objName <- TH.newName strPrefix

382+ let

383+ exprFields = do

384+ descRecordPart <- descRecordParts

385+ IsoXmlDescField fieldPlural fieldStrName _ <-

386+ maybeToList $ case descRecordPart of

387+ IsoXmlDescRecordField descField -> Just descField

388+ _ -> Nothing

389+ let

390+ fName = TH.mkName (fieldName fieldStrName)

391+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)

392+ exprForField = case fieldPlural of

393+ XmlFieldPluralMandatory -> [e|id|]

394+ _ -> [e|traverse|]

395+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]

396+ exprFieldRender = [e|mkElement $exprFieldStrName|]

397+ return [e|$exprForField $exprFieldRender $exprFieldValue|]

398+ toXmlExpr

399+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]

400+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields

401+ TH.instanceD

402+ (return [])

403+ [t|XW.ToXML $(TH.conT name)|]

404+ [funSimple 'XW.toXML toXmlExpr]

405+

406+ toXmlParentAttributesInst <- do

407+ objName <- TH.newName strPrefix

408+ let

409+ exprAttributes = do

410+ descRecordPart <- descRecordParts

411+ IsoXmlDescAttribute attributePlural attributeStrName _ <-

412+ maybeToList $ case descRecordPart of

413+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute

414+ _ -> Nothing

415+ let

416+ fName = TH.mkName (fieldName attributeStrName)

417+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)

418+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]

419+ exprAttrWrap = case attributePlural of

420+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]

421+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]

422+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]

423+ toXmlParentAttributesExpr

424+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]

425+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]

426+ TH.instanceD

427+ (return [])

428+ [t|ToXmlParentAttributes $(TH.conT name)|]

429+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]

430+

431+ return $ [dataDecl] ++ lensDecls ++

432+ [fromDomInst, toXmlInst, toXmlParentAttributesInst]

433+

434+mkElement :: (XW.ToXML a, ToXmlParentAttributes a) => X.Name -> a -> XW.XML

435+mkElement name a = XW.elementA name (toXmlParentAttributes a) (XW.toXML a)

436+

437+distribPair :: Functor f => (a, f b) -> f (a, b)

438+distribPair (a, fb) = (a,) <$> fb

src/Data/THGen/XML/Internal.hsdeleted−416

@@ -1,416 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−{-# LANGUAGE FunctionalDependencies #-}

4−

5−module Data.THGen.XML.Internal where

6−

7−import Control.DeepSeq

8−import Control.Lens hiding (repeated, enum, (&))

9−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)

10−import qualified Data.Char as C

11−import Data.List.NonEmpty (NonEmpty)

12−import Data.Maybe (maybeToList, mapMaybe)

13−import Data.String

14−import Data.THGen.Compat as THC

15−import Data.THGen.Enum

16−import qualified Data.Text as T

17−import GHC.Generics (Generic)

18−import Language.Haskell.TH as TH

19−import Prelude hiding ((+), (*), (^))

20−import qualified Text.XML as X

21−import Text.XML.DOM.Parser hiding (parseContent)

22−import Text.XML.DOM.Parser.Internal.Content

23−import Text.XML.ParentAttributes

24−import qualified Text.XML.Writer as XW

25−

26−

27−data GenType = Parser | Generator | Both

28−

29−data XmlFieldPlural

30− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)

31− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)

32− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)

33− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)

34−

35−data XmlAttributePlural

36− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)

37− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)

38−

39−data PrefixName = PrefixName String String

40−

41−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ

42−

43−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

44−

45−data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ

46−

47−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

48−

49−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

50−

51−data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ

52−

53−data IsoXmlDescRecordPart

54− = IsoXmlDescRecordField IsoXmlDescField

55− | IsoXmlDescRecordAttribute IsoXmlDescAttribute

56− | IsoXmlDescRecordContent IsoXmlDescContent

57−

58−data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]

59−

60−makePrisms ''IsoXmlDescRecord

61−

62−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness

63−

64−newtype IsoXmlDescEnumCon

65− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }

66−

67−instance IsString IsoXmlDescEnumCon where

68− fromString = IsoXmlDescEnumCon

69−

70−data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]

71−

72−makePrisms ''IsoXmlDescEnum

73−

74−appendField

75− :: XmlFieldPlural

76− -> IsoXmlDescRecord

77− -> IsoXmlDescPreField

78− -> IsoXmlDescRecord

79−appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =

80− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

81− in IsoXmlDescRecord genType (xfield:fields)

82−

83−appendAttribute

84− :: XmlAttributePlural

85− -> IsoXmlDescRecord

86− -> IsoXmlDescPreAttribute

87− -> IsoXmlDescRecord

88−appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =

89− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

90− in IsoXmlDescRecord genType (xattribute:fields)

91−

92−appendContent

93− :: IsoXmlDescRecord

94− -> IsoXmlDescPreContent

95− -> IsoXmlDescRecord

96−appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =

97− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

98− in IsoXmlDescRecord genType (xcontent:fields)

99−

100−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord

101−(!) = appendField XmlFieldPluralMandatory

102−(?) = appendField XmlFieldPluralOptional

103−(*) = appendField XmlFieldPluralRepeated

104−(+) = appendField XmlFieldPluralMultiplied

105−

106−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord

107−(!%) = appendAttribute XmlAttributePluralMandatory

108−(?%) = appendAttribute XmlAttributePluralOptional

109−

110−(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord

111−(^) = appendContent

112−

113−infixl 2 !

114−infixl 2 ?

115−infixl 2 *

116−infixl 2 +

117−infixl 2 !%

118−infixl 2 ?%

119−infixl 2 ^

120−

121−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

122−appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =

123− IsoXmlDescEnum genType (xenumcon:enumCons)

124−

125−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

126−(&) = appendEnumCon

127−

128−infixl 2 &

129−

130−class Description name desc | desc -> name where

131− (=:=) :: name -> desc -> TH.DecsQ

132−

133−infix 0 =:=

134−

135−instance Description PrefixName IsoXmlDescRecord where

136− prefixName =:= (IsoXmlDescRecord genType descRecordParts) =

137− isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)

138−

139−record :: GenType -> IsoXmlDescRecord

140−record gt = IsoXmlDescRecord gt []

141−

142−enum :: GenType -> IsoXmlDescEnum

143−enum gt = IsoXmlDescEnum gt []

144−

145−instance Description ExhaustivenessName IsoXmlDescEnum where

146− exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

147− isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

148−

149−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where

150− fromString = IsoXmlDescPreField

151−

152−instance IsString IsoXmlDescPreField where

153− fromString name = IsoXmlDescPreField name ty

154− where

155− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))

156−

157−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where

158− fromString = IsoXmlDescPreAttribute

159−

160−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where

161− fromString = IsoXmlDescPreContent

162−

163−instance IsString IsoXmlDescPreAttribute where

164− fromString name = IsoXmlDescPreAttribute name ty

165− where

166− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)

167−

168−instance IsString IsoXmlDescPreContent where

169− fromString name = IsoXmlDescPreContent name ty

170− where

171− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)

172−

173−instance s ~ String => IsString (s -> PrefixName) where

174− fromString = PrefixName

175−

176−instance IsString PrefixName where

177− fromString strName = PrefixName strName (makeNamePrefix strName)

178−

179−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where

180− fromString = ExhaustivenessName

181−

182−instance IsString ExhaustivenessName where

183− fromString strName = ExhaustivenessName strName NonExhaustive

184−

185−makeNamePrefix :: String -> String

186−makeNamePrefix = map C.toLower . filter C.isUpper

187−

188−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ

189−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]

190−

191−isoXmlGenerateEnum

192− :: GenType

193− -> ExhaustivenessName

194− -> [IsoXmlDescEnumCon]

195− -> TH.DecsQ

196−isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do

197− let

198− strName = "Xml" ++ strName'

199− strVals = map unIsoXmlDescEnumCon enumCons

200− enumDesc = EnumDesc exh strName strVals

201− name = TH.mkName strName

202− enumDecls <- enumGenerate enumDesc

203− let

204− genToXmlInst = do

205− TH.instanceD

206− (return [])

207− [t|XW.ToXML $(TH.conT name)|]

208− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]

209− genToXmlAttributeInst = do

210− TH.instanceD

211− (return [])

212− [t|ToXmlAttribute $(TH.conT name)|]

213− [funSimple 'toXmlAttribute [e|T.pack . show|]]

214− genFromDomInst = do

215− TH.instanceD

216− (return [])

217− [t|FromDom $(TH.conT name)|]

218− [funSimple 'fromDom [e|parseContent readContent|]]

219− genFromAttributeInst = do

220− TH.instanceD

221− (return [])

222− [t|FromAttribute $(TH.conT name)|]

223− [funSimple 'fromAttribute [e|readContent|]]

224− case genType of

225− Generator -> do

226− toXmlInst <- genToXmlInst

227− toXmlAttributeInst <- genToXmlAttributeInst

228− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

229− Parser -> do

230− fromDomInst <- genFromDomInst

231− fromAttributeInst <- genFromAttributeInst

232− return $ enumDecls ++ [fromDomInst, fromAttributeInst]

233− Both -> do

234− toXmlInst <- genToXmlInst

235− toXmlAttributeInst <- genToXmlAttributeInst

236− fromDomInst <- genFromDomInst

237− fromAttributeInst <- genFromAttributeInst

238− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

239− fromDomInst, fromAttributeInst]

240−

241−isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ

242−isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do

243− let

244− isNewtype = length descRecordParts == 1

245− strName = "Xml" ++ strName'

246− strPrefix = "x" ++ strPrefix'

247− name = TH.mkName strName

248− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str

249− termDecl <- do

250− let

251− fields = do

252− descRecordPart <- descRecordParts

253− return $ case descRecordPart of

254− IsoXmlDescRecordField descField ->

255− let

256− IsoXmlDescField fieldPlural rawName fieldType = descField

257− fieldStrName = xmlLocalName rawName

258− fName = TH.mkName (fieldName fieldStrName)

259− fType = case fieldPlural of

260− XmlFieldPluralMandatory -> fieldType

261− XmlFieldPluralOptional -> [t| Maybe $fieldType |]

262− XmlFieldPluralRepeated -> [t| [$fieldType] |]

263− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]

264− in if isNewtype

265− then THC.varStrictType fName (THC.nonStrictType fType)

266− else THC.varStrictType fName (THC.strictType fType)

267− IsoXmlDescRecordAttribute descAttribute ->

268− let

269− IsoXmlDescAttribute

270− attributePlural attributeStrName attributeType = descAttribute

271− fName = TH.mkName (fieldName attributeStrName)

272− fType = case attributePlural of

273− XmlAttributePluralMandatory -> attributeType

274− XmlAttributePluralOptional -> [t| Maybe $attributeType |]

275− in if isNewtype

276− then THC.varStrictType fName (THC.nonStrictType fType)

277− else THC.varStrictType fName (THC.strictType fType)

278− IsoXmlDescRecordContent descContent ->

279− let

280− IsoXmlDescContent contentStrName contentType = descContent

281− fName = TH.mkName (fieldName contentStrName)

282− fType = contentType

283− in if isNewtype

284− then THC.varStrictType fName (THC.nonStrictType fType)

285− else THC.varStrictType fName (THC.strictType fType)

286− if isNewtype

287− -- generate a newtype instead to do less allocations later

288− then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]

289− else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]

290− lensDecls <- makeFieldOpticsForDec lensRules termDecl

291− nfDataInst <- do

292− TH.instanceD

293− (return [])

294− [t|NFData $(TH.conT name)|]

295− [ ]

296−

297− let

298− genFromDomInst = do

299− let

300− exprHeader = [e|pure $(TH.conE name)|]

301− exprRecordParts = do

302− descRecordPart <- descRecordParts

303− return $ case descRecordPart of

304− IsoXmlDescRecordField descField ->

305− let

306− IsoXmlDescField fieldPlural rawName _ = descField

307− fieldStrName = xmlLocalName rawName

308− exprFieldStrName = TH.litE (TH.stringL fieldStrName)

309− fieldParse = case fieldPlural of

310− XmlFieldPluralMandatory -> [e|inElem|]

311− _ -> [e|inElemTrav|]

312− in

313− [e|$fieldParse $exprFieldStrName fromDom|]

314− IsoXmlDescRecordAttribute descAttribute ->

315− let

316− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

317− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)

318− attributeParse = case attributePlural of

319− XmlAttributePluralMandatory -> [e|parseAttribute|]

320− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

321− in

322− [e|$attributeParse $exprAttributeStrName fromAttribute|]

323− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]

324− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts

325− TH.instanceD

326− (return [])

327− [t|FromDom $(TH.conT name)|]

328− [ funSimple 'fromDom fromDomExpr ]

329−

330− genToXmlInst = do

331− objName <- TH.newName strPrefix

332− let

333− exprFields = do

334− descRecordPart <- descRecordParts

335− case descRecordPart of

336− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do

337− let

338− fieldStrName = xmlLocalName rawName

339− fName = TH.mkName (fieldName fieldStrName)

340− exprFieldStrName = TH.litE (TH.stringL rawName)

341− exprForField = case fieldPlural of

342− XmlFieldPluralMandatory -> [e|id|]

343− _ -> [e|traverse|]

344− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]

345− exprFieldRender =

346− [e|(\a ->

347− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]

348− return [e|$exprForField $exprFieldRender $exprFieldValue|]

349− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do

350− let

351− fieldStrName = xmlLocalName rawName

352− fName = TH.mkName (fieldName fieldStrName)

353− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]

354− return [e|XW.content . toXmlAttribute $ $exprFieldValue|]

355− _ -> []

356− toXmlExpr

357− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]

358− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields

359− TH.instanceD

360− (return [])

361− [t|XW.ToXML $(TH.conT name)|]

362− [funSimple 'XW.toXML toXmlExpr]

363− genToXmlParentAttributeInst = do

364− objName <- TH.newName strPrefix

365− let

366− exprAttributes = do

367− descRecordPart <- descRecordParts

368− IsoXmlDescAttribute attributePlural attributeStrName _ <-

369− maybeToList $ case descRecordPart of

370− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute

371− _ -> Nothing

372− let

373− fName = TH.mkName (fieldName attributeStrName)

374− exprAttrStrName = TH.litE (TH.stringL attributeStrName)

375− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]

376− exprAttrWrap = case attributePlural of

377− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]

378− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]

379− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]

380− toXmlParentAttributesExpr

381− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]

382− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]

383−#if __GLASGOW_HASKELL__ < 800

384− TH.instanceD

385−#else

386− TH.instanceWithOverlapD (Just TH.Overlapping)

387−#endif

388− (return [])

389− [t|ToXmlParentAttributes $(TH.conT name)|]

390− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]

391−

392− case genType of

393− Generator -> do

394− toXmlInst <- genToXmlInst

395− toXmlParentAttributesInst <- genToXmlParentAttributeInst

396− return $ [termDecl] ++ lensDecls ++

397− [toXmlInst, toXmlParentAttributesInst, nfDataInst]

398− Parser -> do

399− fromDomInst <- genFromDomInst

400− return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]

401− Both -> do

402− toXmlInst <- genToXmlInst

403− toXmlParentAttributesInst <- genToXmlParentAttributeInst

404− fromDomInst <- genFromDomInst

405− return $ [termDecl] ++ lensDecls ++

406− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

407−

408−distribPair :: Functor f => (a, f b) -> f (a, b)

409−distribPair (a, fb) = (a,) <$> fb

410−

411−-- | Get a local part of (possibly) fully qualified 'X.Name':

412−--

413−-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"

414−-- "my-name"

415−xmlLocalName :: String -> String

416−xmlLocalName = T.unpack . X.nameLocalName . fromString

src/Text/XML/DOM/Parser/Internal/Content.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Text.XML.DOM.Parser.Internal.Content where

3−import Control.Lens

4−import Control.Monad.Reader

5−import Data.Text as T

6−import Text.XML

7−import Text.XML.DOM.Parser hiding (getCurrentContent, parseContent)

8−

9−-- Get current content. If there are more than one content

10−-- they are intercalate with space like in xpath `text()`

11−--

12−getCurrentContent :: (Monad m) => DomParserT Identity m Text

13−getCurrentContent

14− = T.intercalate " "

15− . (\e -> [T.strip cs| (NodeContent cs) <- e])

16− . elementNodes

17− . runIdentity

18− . _pdElements

19− <$> ask

20−

21−parseContent

22− :: (Monad m)

23− => (Text -> Either Text a)

24− -- ^ Content parser, return error msg if value is not parsed

25− -> DomParserT Identity m a

26−parseContent parse

27− = getCurrentContent

28− >>= either (throwParserError . PEContentWrongFormat) return . parse

stack.yaml+8−3

@@ -1,4 +1,9 @@

1−resolver: lts-10.0

1+resolver: lts-6.27

3+packages:

4+- "."

2extra-deps:

6extra-deps:

3−- dom-parser-3.0.0

7+- dom-parser-2.0.0

4−- generic-arbitrary-0.1.0

8+- type-fun-0.0.1

9+- open-union-0.2.0.0

test/Main.hs+1−26

@@ -1,31 +1,6 @@

1−{-# OPTIONS -fno-warn-unused-imports #-}

2module Main where

1module Main where

4−import Control.Exception

5−import Text.XML

6−import Data.Default

7−import System.IO.Unsafe

8−import Test.Hspec

9−import Test.Hspec.QuickCheck

10−import Test.QuickCheck

11import TestDefs

3import TestDefs

12−import Text.XML.DOM.Parser

13−import Text.XML.Writer

14−

15−isomorphicFoo :: XmlRoot -> Property

16−isomorphicFoo a = a === isogen

17− where

18− isogen :: XmlRoot

19− isogen =

20− let

21− doc = document "Root" $ toXML a

22− res = case runDomParser doc fromDom of

23− Left e -> unsafePerformIO $ do

24− pprint doc

25− throwIO e

26− Right a' -> a'

27− in res

29main :: IO ()

5main :: IO ()

30−main = hspec $ do

6+main = return ()

31− prop "isomorphic" isomorphicFoo

test/TestDefs.hs+5−25

@@ -1,19 +1,18 @@

1{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TemplateHaskell #-}

3{-# OPTIONS -ddump-splices #-}

5{-# OPTIONS -ddump-splices #-}

5module TestDefs where

7module TestDefs where

7−-- import Data.List.NonEmpty

8import Data.THGen.XML

9import Data.THGen.XML

9−import Test.QuickCheck.Arbitrary.Generic

10−import Test.QuickCheck.Instances ()

12−"Bar" =:= enum Both

11+"Bar" =:= enum

13 & "baroque"

12 & "baroque"

14 & "bartender"

13 & "bartender"

16−"Quux" Exhaustive =:= enum Both

15+"Quux" Exhaustive =:= enum

17 & "ALL"

16 & "ALL"

18 & "YOUR"

17 & "YOUR"

19 & "BASE"

18 & "BASE"

@@ -22,26 +21,7 @@ import Test.QuickCheck.Instances ()

22 & "TO"

21 & "TO"

23 & "US"

22 & "US"

25−"Foo" =:= record Both

24+"Foo" =:= record

26− ^ "Shmuux" [t|XmlQuux|]

27 + "Bar"

25 + "Bar"

28 ? "Baz" [t|Text|]

26 ? "Baz" [t|Text|]

29 !% "Quux"

27 !% "Quux"

30− ?% "Muux" [t|XmlQuux|]

31−

32−"Root" =:= record Both

33− ! "{http://example.com/ns/my-namespace}Foo"

34−

35−instance Arbitrary XmlRoot where

36− arbitrary = genericArbitrary

37− shrink = genericShrink

38−

39−instance Arbitrary XmlFoo where

40− arbitrary = genericArbitrary

41− shrink = genericShrink

42−

43−#if __GLASGOW_HASKELL__ < 800

44−instance Arbitrary (NonEmpty XmlBar) where

45− arbitrary = genericArbitrary

46− shrink = genericShrink

47−#endif

xml-isogen.cabal+11−45

@@ -1,5 +1,5 @@

1name: xml-isogen

2−version: 0.3.1

2+version: 0.1.0

3synopsis: Generate XML-isomorphic types

4description:

5 TemplateHaskell generators for XML-isomorphic data types, including

@@ -14,30 +14,17 @@ author: Typeable.io contributors

14maintainer: makeit@typeable.io

15category: Data

16build-type: Simple

17−cabal-version: >=1.22

18−homepage: https://github.com/typeable/xml-isogen

19−tested-with: GHC == 7.10.3

20− , GHC == 8.0.2

21− , GHC == 8.2.2

22− , GHC == 8.4.1

23extra-source-files: CHANGELOG.md

17extra-source-files: CHANGELOG.md

24− , README.md

18+cabal-version: >=1.22

25−

26−source-repository head

27− type: git

28− location: git@github.com:typeable/xml-isogen.git

30library

20library

31 exposed-modules: Data.THGen.Enum

21 exposed-modules: Data.THGen.Enum

32− , Data.THGen.XML

33− , Data.THGen.XML.Internal

22+ Data.THGen.XML

34− , Text.XML.ParentAttributes

23+ Text.XML.ParentAttributes

35− other-modules: Data.THGen.Compat

24+

36− , Text.XML.DOM.Parser.Internal.Content

37 build-depends: QuickCheck >= 2.8

25 build-depends: QuickCheck >= 2.8

38 , base >=4.8 && <5

26 , base >=4.8 && <5

39 , dom-parser >= 2.0.0

27 , dom-parser >= 2.0.0

40− , deepseq

41 , lens >= 4.13

28 , lens >= 4.13

42 , mtl >= 2.2

29 , mtl >= 2.2

43 , semigroups >= 0.18

30 , semigroups >= 0.18

@@ -49,38 +36,17 @@ library

49 hs-source-dirs: src

36 hs-source-dirs: src

51 default-language: Haskell2010

38 default-language: Haskell2010

52− default-extensions: CPP

39+ default-extensions: TemplateHaskell

53− , FlexibleInstances

40+ LambdaCase

54− , LambdaCase

41+ FlexibleInstances

55− , TemplateHaskell

56− , TupleSections

57− , TypeFamilies

42+ TypeFamilies

43+ TupleSections

59test-suite spec

45test-suite spec

60 type: exitcode-stdio-1.0

46 type: exitcode-stdio-1.0

61 hs-source-dirs: test

47 hs-source-dirs: test

62 main-is: Main.hs

48 main-is: Main.hs

63 other-modules: TestDefs

49 other-modules: TestDefs

64− build-depends: base

50+ build-depends: base, xml-isogen

65− , QuickCheck

66− , data-default

67− , deepseq

68− , dom-parser

69− , generic-arbitrary

70− , hspec

71− , quickcheck-instances

72− , semigroups

73− , xml-conduit

74− , xml-conduit-writer

75− , xml-isogen

76 default-language: Haskell2010

51 default-language: Haskell2010

77− default-extensions: CPP

78− , DeriveGeneric

79− , FlexibleInstances

80− , LambdaCase

81− , OverloadedStrings

82− , StandaloneDeriving

83− , TemplateHaskell

84− , TupleSections

85− , TypeFamilies

86 ghc-options: -Wall -fno-warn-missing-signatures

52 ghc-options: -Wall -fno-warn-missing-signatures