eadf9d1...master · xml-isogen

git.iko.soy/xml-isogen

on master help sign in

.travis.yml+1−1

since splitsnapshots

unifiedsplit

@@ -6,7 +6,7 @@ env:

6 - STACK_YAML=stack.yaml

7 - STACK_YAML=ghc-802.yaml

8 - STACK_YAML=ghc-822.yaml

9− - STACK_YAML=ghc-841.yaml

9+ - STACK_YAML=ghc-844.yaml

11cache:

12 directories:

CHANGELOG.md+5

@@ -1,7 +1,12 @@

1HEAD

2------

4+0.3.0

5+------

7+* Add namespaces support

4* Builds with GHC 8.4

8* Builds with GHC 8.4

9+* Derive NFData for all generated datatypes

60.2.1

110.2.1

7------

12------

ghc-802.yaml+1−1

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

1−resolver: lts-9.0

1+resolver: lts-9.21

3packages:

4- .

ghc-822.yaml+1−1

@@ -1 +1 @@

1−resolver: lts-10.0

1+resolver: lts-11.22

ghc-841.yaml → ghc-844.yamlrenamed+1−1

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

1−resolver: nightly-2018-03-20

1+resolver: lts-12.16

2extra-deps:

3- dom-parser-3.1.0

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

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

1−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE FunctionalDependencies #-}

4{- |

3{- |

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

24Example 1.

23Example 1.

26−> "Color" =:= enum

25+> "Color" =:= enum Both

27> & "R"

26> & "R"

28> & "G"

27> & "G"

29> & "B"

28> & "B"

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

42Example 2.

41Example 2.

44−> "Message" =:= record

43+> "Message" =:= record Both

45> ! "author"

44> ! "author"

46> + "recipient"

45> + "recipient"

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

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

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

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

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

69is the default):

68is the default):

71−> "Enum1" Exhaustive =:= enum

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

72> ...

71> ...

74−> "Enum2" NonExhaustive =:= enum

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

75> ...

74> ...

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

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

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

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

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

80name. You can override it manually like so:

79name. You can override it manually like so:

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

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

83> ...

82> ...

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

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

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

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

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

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

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

97−> "Message" =:= record

96+> "Message" =:= record Both

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

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

99> ...

98> ...

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+

101-}

104-}

102

105

103

106

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

105 ( Exhaustiveness(..)

108 ( Exhaustiveness(..)

106 , PrefixName(..)

109 , PrefixName(..)

107 , ExhaustivenessName(..)

110 , ExhaustivenessName(..)

111+ , GenType(..)

108 , record

112 , record

109 , enum

113 , enum

110 , (!)

114 , (!)

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

114 , (!%)

118 , (!%)

115 , (?%)

119 , (?%)

116 , (&)

120 , (&)

121+ , (^)

117 , (=:=)

122 , (=:=)

118 -- Re-exports

123 -- Re-exports

119− , T.Text

124+ , Text

120− , Int

125+ , P.Int

121− , Integer

126+ , P.Integer

122 ) where

127 ) where

123

128

124−import Control.DeepSeq

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

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

127−import qualified Data.Char as C

128−import Data.List.NonEmpty (NonEmpty)

129−import Data.Maybe (maybeToList, mapMaybe)

130−import Data.String

131−import Data.THGen.Compat

132import Data.THGen.Enum

129import Data.THGen.Enum

133−import qualified Data.Text as T

130+import Data.THGen.XML.Internal

134−import GHC.Generics (Generic)

131+import Data.Text

135−import qualified Language.Haskell.TH as TH

136−import qualified Language.Haskell.TH.Syntax as TH

132+import qualified Prelude as P

137−import Prelude hiding ((+), (*))

138−import qualified Text.XML as X

139−import Text.XML.DOM.Parser

140−import Text.XML.ParentAttributes

141−import qualified Text.XML.Writer as XW

142−

143−

144−data XmlFieldPlural

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

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

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

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

149−

150−data XmlAttributePlural

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

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

153−

154−data PrefixName = PrefixName String String

155−

156−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ

157−

158−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

159−

160−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

161−

162−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

163−

164−data IsoXmlDescRecordPart

165− = IsoXmlDescRecordField IsoXmlDescField

166− | IsoXmlDescRecordAttribute IsoXmlDescAttribute

167−

168−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]

169−

170−makePrisms ''IsoXmlDescRecord

171−

172−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness

173−

174−newtype IsoXmlDescEnumCon

175− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }

176−

177−instance IsString IsoXmlDescEnumCon where

178− fromString = IsoXmlDescEnumCon

179−

180−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]

181−

182−makePrisms ''IsoXmlDescEnum

183−

184−appendField

185− :: XmlFieldPlural

186− -> IsoXmlDescRecord

187− -> IsoXmlDescPreField

188− -> IsoXmlDescRecord

189−appendField plural xrec (IsoXmlDescPreField name ty) =

190− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

191− in over _IsoXmlDescRecord (xfield:) xrec

192−

193−appendAttribute

194− :: XmlAttributePlural

195− -> IsoXmlDescRecord

196− -> IsoXmlDescPreAttribute

197− -> IsoXmlDescRecord

198−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =

199− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

200− in over _IsoXmlDescRecord (xattribute:) xrec

201−

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

203−(!) = appendField XmlFieldPluralMandatory

204−(?) = appendField XmlFieldPluralOptional

205−(*) = appendField XmlFieldPluralRepeated

206−(+) = appendField XmlFieldPluralMultiplied

207−

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

209−(!%) = appendAttribute XmlAttributePluralMandatory

210−(?%) = appendAttribute XmlAttributePluralOptional

211−

212−infixl 2 !

213−infixl 2 ?

214−infixl 2 *

215−infixl 2 +

216−infixl 2 !%

217−infixl 2 ?%

218−

219−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

220−appendEnumCon xenum xenumcon =

221− over _IsoXmlDescEnum (xenumcon:) xenum

222−

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

224−(&) = appendEnumCon

225−

226−infixl 2 &

227−

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

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

230−

231−infix 0 =:=

232−

233−instance Description PrefixName IsoXmlDescRecord where

234− prefixName =:= descRecord =

235− let descRecordParts = descRecord ^. _IsoXmlDescRecord

236− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)

237−

238−record :: IsoXmlDescRecord

239−record = IsoXmlDescRecord []

240−

241−enum :: IsoXmlDescEnum

242−enum = IsoXmlDescEnum []

243−

244−instance Description ExhaustivenessName IsoXmlDescEnum where

245− exhaustivenessName =:= descEnum =

246− let descEnumCons = descEnum ^. _IsoXmlDescEnum

247− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)

248−

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

250− fromString = IsoXmlDescPreField

251−

252−instance IsString IsoXmlDescPreField where

253− fromString name = IsoXmlDescPreField name ty

254− where

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

256−

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

258− fromString = IsoXmlDescPreAttribute

259−

260−instance IsString IsoXmlDescPreAttribute where

261− fromString name = IsoXmlDescPreAttribute name ty

262− where

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

264−

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

266− fromString = PrefixName

267−

268−instance IsString PrefixName where

269− fromString strName = PrefixName strName (makeNamePrefix strName)

270−

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

272− fromString = ExhaustivenessName

273−

274−instance IsString ExhaustivenessName where

275− fromString strName = ExhaustivenessName strName NonExhaustive

276−

277−makeNamePrefix :: String -> String

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

279−

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

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

282−

283−isoXmlGenerateEnum

284− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ

285−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do

286− let

287− strName = "Xml" ++ strName'

288− strVals = map unIsoXmlDescEnumCon enumCons

289− enumDesc = EnumDesc exh strName strVals

290− name = TH.mkName strName

291− enumDecls <- enumGenerate enumDesc

292− toXmlInst <- do

293− TH.instanceD

294− (return [])

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

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

297− toXmlAttributeInst <- do

298− TH.instanceD

299− (return [])

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

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

302− fromDomInst <- do

303− TH.instanceD

304− (return [])

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

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

307− fromAttributeInst <- do

308− TH.instanceD

309− (return [])

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

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

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

313− fromDomInst, fromAttributeInst]

314−

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

316−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do

317− let

318− isNewtype = length descRecordParts == 1

319− strName = "Xml" ++ strName'

320− strPrefix = "x" ++ strPrefix'

321− name = TH.mkName strName

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

323− termDecl <- do

324− let

325− fields = do

326− descRecordPart <- descRecordParts

327− return $ case descRecordPart of

328− IsoXmlDescRecordField descField ->

329− let

330− IsoXmlDescField fieldPlural rawName fieldType = descField

331− fieldStrName = xmlLocalName rawName

332− fName = TH.mkName (fieldName fieldStrName)

333− fType = case fieldPlural of

334− XmlFieldPluralMandatory -> fieldType

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

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

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

338− in if isNewtype

339− then varStrictType fName (nonStrictType fType)

340− else varStrictType fName (strictType fType)

341− IsoXmlDescRecordAttribute descAttribute ->

342− let

343− IsoXmlDescAttribute

344− attributePlural attributeStrName attributeType = descAttribute

345− fName = TH.mkName (fieldName attributeStrName)

346− fType = case attributePlural of

347− XmlAttributePluralMandatory -> attributeType

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

349− in if isNewtype

350− then varStrictType fName (nonStrictType fType)

351− else varStrictType fName (strictType fType)

352− if isNewtype

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

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

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

356− lensDecls <- makeFieldOpticsForDec lensRules termDecl

357− nfDataInst <- do

358− TH.instanceD

359− (return [])

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

361− [ ]

362− fromDomInst <- do

363− let

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

365− exprRecordParts = do

366− descRecordPart <- descRecordParts

367− return $ case descRecordPart of

368− IsoXmlDescRecordField descField ->

369− let

370− IsoXmlDescField fieldPlural rawName _ = descField

371− fieldStrName = xmlLocalName rawName

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

373− fieldParse = case fieldPlural of

374− XmlFieldPluralMandatory -> [e|inElem|]

375− _ -> [e|inElemTrav|]

376− in

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

378− IsoXmlDescRecordAttribute descAttribute ->

379− let

380− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

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

382− attributeParse = case attributePlural of

383− XmlAttributePluralMandatory -> [e|parseAttribute|]

384− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

385− in

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

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

388− TH.instanceD

389− (return [])

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

391− [ funSimple 'fromDom fromDomExpr ]

392−

393− toXmlInst <- do

394− objName <- TH.newName strPrefix

395− let

396− exprFields = do

397− descRecordPart <- descRecordParts

398− IsoXmlDescField fieldPlural rawName _ <-

399− maybeToList $ case descRecordPart of

400− IsoXmlDescRecordField descField -> Just descField

401− _ -> Nothing

402− let

403− fieldStrName = xmlLocalName rawName

404− fName = TH.mkName (fieldName fieldStrName)

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

406− exprForField = case fieldPlural of

407− XmlFieldPluralMandatory -> [e|id|]

408− _ -> [e|traverse|]

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

410− exprFieldRender =

411− [e|(\a -> XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]

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

413− toXmlExpr

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

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

416− TH.instanceD

417− (return [])

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

419− [funSimple 'XW.toXML toXmlExpr]

420−

421− toXmlParentAttributesInst <- do

422− objName <- TH.newName strPrefix

423− let

424− exprAttributes = do

425− descRecordPart <- descRecordParts

426− IsoXmlDescAttribute attributePlural attributeStrName _ <-

427− maybeToList $ case descRecordPart of

428− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute

429− _ -> Nothing

430− let

431− fName = TH.mkName (fieldName attributeStrName)

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

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

434− exprAttrWrap = case attributePlural of

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

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

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

438− toXmlParentAttributesExpr

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

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

441−#if __GLASGOW_HASKELL__ < 800

442− TH.instanceD

443−#else

444− TH.instanceWithOverlapD (Just TH.Overlapping)

445−#endif

446− (return [])

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

448− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]

449−

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

451− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

452−

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

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

455−

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

457−--

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

459−-- "my-name"

460−xmlLocalName :: String -> String

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

src/Data/THGen/XML/Internal.hsnew file+416

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

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE UndecidableInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

5+module Data.THGen.XML.Internal where

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.hsnew file+28

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

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)

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+1−1

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

1−resolver: lts-6.35

1+resolver: lts-10.0

2extra-deps:

3- dom-parser-3.0.0

4- generic-arbitrary-0.1.0

test/TestDefs.hs+6−5

@@ -4,16 +4,16 @@

5module TestDefs where

7−import Data.List.NonEmpty

7+-- import Data.List.NonEmpty

8import Data.THGen.XML

9import Test.QuickCheck.Arbitrary.Generic

10import Test.QuickCheck.Instances ()

12−"Bar" =:= enum

12+"Bar" =:= enum Both

13 & "baroque"

14 & "bartender"

16−"Quux" Exhaustive =:= enum

16+"Quux" Exhaustive =:= enum Both

17 & "ALL"

18 & "YOUR"

19 & "BASE"

@@ -22,13 +22,14 @@ import Test.QuickCheck.Instances ()

22 & "TO"

23 & "US"

25−"Foo" =:= record

25+"Foo" =:= record Both

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

26 + "Bar"

27 + "Bar"

27 ? "Baz" [t|Text|]

28 ? "Baz" [t|Text|]

28 !% "Quux"

29 !% "Quux"

29 ?% "Muux" [t|XmlQuux|]

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

31−"Root" =:= record

32+"Root" =:= record Both

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

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

34instance Arbitrary XmlRoot where

35instance Arbitrary XmlRoot where

xml-isogen.cabal+3−1

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

1name: xml-isogen

2−version: 0.2.1

2+version: 0.3.1

3synopsis: Generate XML-isomorphic types

4description:

5 TemplateHaskell generators for XML-isomorphic data types, including

@@ -30,8 +30,10 @@ source-repository head

30library

31 exposed-modules: Data.THGen.Enum

32 , Data.THGen.XML

33+ , Data.THGen.XML.Internal

33 , Text.XML.ParentAttributes

34 , Text.XML.ParentAttributes

34 other-modules: Data.THGen.Compat

35 other-modules: Data.THGen.Compat

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

35 build-depends: QuickCheck >= 2.8

37 build-depends: QuickCheck >= 2.8

36 , base >=4.8 && <5

38 , base >=4.8 && <5

37 , dom-parser >= 2.0.0

39 , dom-parser >= 2.0.0