4422442 · typeable/xml-isogen

git.iko.soy/typeable/xml-isogen

on master help sign in

Add: contents in composite types

4422442Dmitry Olshansky8 years ago

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

compare with master

unifiedsplit

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

1−resolver: nightly-2018-03-20

1+resolver: lts-12.11

2extra-deps:

3- dom-parser-3.1.0

src/Data/THGen/XML.hs+59−18

@@ -114,6 +114,7 @@ module Data.THGen.XML

114 , (!%)

115 , (?%)

116 , (&)

117+ , (^)

117 , (=:=)

118 , (=:=)

118 -- Re-exports

119 -- Re-exports

119 , T.Text

120 , T.Text

@@ -133,12 +134,12 @@ import Data.THGen.Enum

133import qualified Data.Text as T

134import qualified Data.Text as T

134import GHC.Generics (Generic)

135import GHC.Generics (Generic)

135import qualified Language.Haskell.TH as TH

136import qualified Language.Haskell.TH as TH

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

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

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

138import qualified Text.XML as X

139−import Text.XML.DOM.Parser

139+import Text.XML.DOM.Parser hiding (parseContent)

140import Text.XML.ParentAttributes

141import qualified Text.XML.Writer as XW

142+import Text.XML.DOM.Parser.Internal.Content

142

143

144

144data XmlFieldPlural

145data XmlFieldPlural

@@ -157,13 +158,18 @@ data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ

157

158

158data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

159data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

159

160

161+data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ

162+

160data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

163data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

161

164

162data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

165data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

163

166

167+data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ

168+

164data IsoXmlDescRecordPart

169data IsoXmlDescRecordPart

165 = IsoXmlDescRecordField IsoXmlDescField

170 = IsoXmlDescRecordField IsoXmlDescField

166 | IsoXmlDescRecordAttribute IsoXmlDescAttribute

171 | IsoXmlDescRecordAttribute IsoXmlDescAttribute

172+ | IsoXmlDescRecordContent IsoXmlDescContent

167

173

168newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]

174newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]

169

175

@@ -199,6 +205,14 @@ appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =

199 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

205 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

200 in over _IsoXmlDescRecord (xattribute:) xrec

206 in over _IsoXmlDescRecord (xattribute:) xrec

201

207

208+appendContent

209+ :: IsoXmlDescRecord

210+ -> IsoXmlDescPreContent

211+ -> IsoXmlDescRecord

212+appendContent xrec (IsoXmlDescPreContent name ty) =

213+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

214+ in over _IsoXmlDescRecord (xcontent:) xrec

215+

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

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

203(!) = appendField XmlFieldPluralMandatory

217(!) = appendField XmlFieldPluralMandatory

204(?) = appendField XmlFieldPluralOptional

218(?) = appendField XmlFieldPluralOptional

@@ -209,12 +223,16 @@ appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =

209(!%) = appendAttribute XmlAttributePluralMandatory

223(!%) = appendAttribute XmlAttributePluralMandatory

210(?%) = appendAttribute XmlAttributePluralOptional

224(?%) = appendAttribute XmlAttributePluralOptional

211

225

226+(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord

227+(^) = appendContent

228+

212infixl 2 !

229infixl 2 !

213infixl 2 ?

230infixl 2 ?

214infixl 2 *

231infixl 2 *

215infixl 2 +

232infixl 2 +

216infixl 2 !%

233infixl 2 !%

217infixl 2 ?%

234infixl 2 ?%

235+infixl 2 ^

218

236

219appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

237appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

220appendEnumCon xenum xenumcon =

238appendEnumCon xenum xenumcon =

@@ -257,11 +275,19 @@ instance IsString IsoXmlDescPreField where

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

275instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where

258 fromString = IsoXmlDescPreAttribute

276 fromString = IsoXmlDescPreAttribute

259

277

278+instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where

279+ fromString = IsoXmlDescPreContent

280+

260instance IsString IsoXmlDescPreAttribute where

281instance IsString IsoXmlDescPreAttribute where

261 fromString name = IsoXmlDescPreAttribute name ty

282 fromString name = IsoXmlDescPreAttribute name ty

262 where

283 where

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

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

264

285

286+instance IsString IsoXmlDescPreContent where

287+ fromString name = IsoXmlDescPreContent name ty

288+ where

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

290+

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

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

266 fromString = PrefixName

292 fromString = PrefixName

267

293

@@ -349,6 +375,14 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do

349 in if isNewtype

375 in if isNewtype

350 then varStrictType fName (nonStrictType fType)

376 then varStrictType fName (nonStrictType fType)

351 else varStrictType fName (strictType fType)

377 else varStrictType fName (strictType fType)

378+ IsoXmlDescRecordContent descContent ->

379+ let

380+ IsoXmlDescContent contentStrName contentType = descContent

381+ fName = TH.mkName (fieldName contentStrName)

382+ fType = contentType

383+ in if isNewtype

384+ then varStrictType fName (nonStrictType fType)

385+ else varStrictType fName (strictType fType)

352 if isNewtype

386 if isNewtype

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

387 -- generate a newtype instead to do less allocations later

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

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

@@ -384,6 +418,7 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do

384 XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

418 XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

385 in

419 in

386 [e|$attributeParse $exprAttributeStrName fromAttribute|]

420 [e|$attributeParse $exprAttributeStrName fromAttribute|]

421+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]

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

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

388 TH.instanceD

423 TH.instanceD

389 (return [])

424 (return [])

@@ -395,21 +430,27 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do

395 let

430 let

396 exprFields = do

431 exprFields = do

397 descRecordPart <- descRecordParts

432 descRecordPart <- descRecordParts

398− IsoXmlDescField fieldPlural rawName _ <-

399− maybeToList $ case descRecordPart of

433+ case descRecordPart of

400− IsoXmlDescRecordField descField -> Just descField

434+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do

401− _ -> Nothing

402− let

435+ let

403− fieldStrName = xmlLocalName rawName

436+ fieldStrName = xmlLocalName rawName

404− fName = TH.mkName (fieldName fieldStrName)

437+ fName = TH.mkName (fieldName fieldStrName)

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

438+ exprFieldStrName = TH.litE (TH.stringL rawName)

406− exprForField = case fieldPlural of

439+ exprForField = case fieldPlural of

407− XmlFieldPluralMandatory -> [e|id|]

440+ XmlFieldPluralMandatory -> [e|id|]

408− _ -> [e|traverse|]

441+ _ -> [e|traverse|]

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

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

410− exprFieldRender =

443+ exprFieldRender =

444+ [e|(\a ->

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

445+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]

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

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

447+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do

448+ let

449+ fieldStrName = xmlLocalName rawName

450+ fName = TH.mkName (fieldName fieldStrName)

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

452+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]

453+ _ -> []

413 toXmlExpr

454 toXmlExpr

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

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

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

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

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

@@ -4,7 +4,7 @@

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 ()

@@ -23,6 +23,7 @@ import Test.QuickCheck.Instances ()

23 & "US"

25"Foo" =:= record

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

26 + "Bar"

27 + "Bar"

27 ? "Baz" [t|Text|]

28 ? "Baz" [t|Text|]

28 !% "Quux"

29 !% "Quux"

xml-isogen.cabal+2−1

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

1name: xml-isogen

2−version: 0.3.0

2+version: 0.3.1

3synopsis: Generate XML-isomorphic types

4description:

5 TemplateHaskell generators for XML-isomorphic data types, including

@@ -32,6 +32,7 @@ library

32 , Data.THGen.XML

33 , Text.XML.ParentAttributes

34 other-modules: Data.THGen.Compat

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

35 build-depends: QuickCheck >= 2.8

36 build-depends: QuickCheck >= 2.8

36 , base >=4.8 && <5

37 , base >=4.8 && <5

37 , dom-parser >= 2.0.0

38 , dom-parser >= 2.0.0