@@ -5,7 +5,7 @@
55module Data.THGen.XML.Internal where
66
77import Control.DeepSeq
8−import Control.Lens hiding (repeated, enum, (&))
8+import Control.Lens hiding (repeated, enum, (&), Strict)
99import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
1010import qualified Data.Char as C
1111import Data.List.NonEmpty (NonEmpty)
@@ -15,7 +15,7 @@ import Data.THGen.Compat as THC
1515import Data.THGen.Enum
1616import qualified Data.Text as T
1717import GHC.Generics (Generic)
18−import Language.Haskell.TH as TH
18+import Language.Haskell.TH as TH hiding (Strict)
1919import Prelude hiding ((+), (*), (^))
2020import qualified Text.XML as X
2121import Text.XML.DOM.Parser hiding (parseContent)
@@ -23,8 +23,22 @@ import Text.XML.DOM.Parser.Internal.Content
2323import Text.XML.ParentAttributes
2424import qualified Text.XML.Writer as XW
2525
26+data ParserMode
27+ = Strict
28+ | Lenient
2629
27−data GenType = Parser | Generator | ParserAndGenerator
30+data GenType
31+ = Parser
32+ | Generator
33+ | ParserAndGenerator
34+ | LenientParser
35+ | LenientParserAndGenerator
36+
37+isLenientType :: GenType -> Bool
38+isLenientType = \case
39+ LenientParser -> True
40+ LenientParserAndGenerator -> True
41+ _ -> False
2842
2943data XmlFieldPlural
3044 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
@@ -146,7 +160,7 @@ instance Description ExhaustivenessName IsoXmlDescEnum where
146160 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
147161 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
148162
149−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
163+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where
150164 fromString = IsoXmlDescPreField
151165
152166instance IsString IsoXmlDescPreField where
@@ -154,10 +168,10 @@ instance IsString IsoXmlDescPreField where
154168 where
155169 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
156170
157−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
171+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where
158172 fromString = IsoXmlDescPreAttribute
159173
160−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
174+instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where
161175 fromString = IsoXmlDescPreContent
162176
163177instance IsString IsoXmlDescPreAttribute where
@@ -211,11 +225,14 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
211225 (return [])
212226 [t|ToXmlAttribute $(TH.conT name)|]
213227 [funSimple 'toXmlAttribute [e|T.pack . show|]]
214− genFromDomInst = do
228+ genFromDomInst mode = do
215229 TH.instanceD
216230 (return [])
217231 [t|FromDom $(TH.conT name)|]
218− [funSimple 'fromDom [e|parseContent readContent|]]
232+ [case mode of
233+ Strict -> funSimple 'fromDom [e|parseContent readContent|]
234+ Lenient -> funSimple 'fromDom [e|ignoreBlank $ parseContent readContent|]
235+ ]
219236 genFromAttributeInst = do
220237 TH.instanceD
221238 (return [])
@@ -227,13 +244,24 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
227244 toXmlAttributeInst <- genToXmlAttributeInst
228245 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]
229246 Parser -> do
230− fromDomInst <- genFromDomInst
247+ fromDomInst <- genFromDomInst Strict
248+ fromAttributeInst <- genFromAttributeInst
249+ return $ enumDecls ++ [fromDomInst, fromAttributeInst]
250+ LenientParser -> do
251+ fromDomInst <- genFromDomInst Lenient
231252 fromAttributeInst <- genFromAttributeInst
232253 return $ enumDecls ++ [fromDomInst, fromAttributeInst]
233254 ParserAndGenerator -> do
234255 toXmlInst <- genToXmlInst
235256 toXmlAttributeInst <- genToXmlAttributeInst
236− fromDomInst <- genFromDomInst
257+ fromDomInst <- genFromDomInst Strict
258+ fromAttributeInst <- genFromAttributeInst
259+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
260+ fromDomInst, fromAttributeInst]
261+ LenientParserAndGenerator -> do
262+ toXmlInst <- genToXmlInst
263+ toXmlAttributeInst <- genToXmlAttributeInst
264+ fromDomInst <- genFromDomInst Lenient
237265 fromAttributeInst <- genFromAttributeInst
238266 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
239267 fromDomInst, fromAttributeInst]
@@ -256,11 +284,14 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
256284 IsoXmlDescField fieldPlural rawName fieldType = descField
257285 fieldStrName = xmlLocalName rawName
258286 fName = TH.mkName (fieldName fieldStrName)
259− fType = case fieldPlural of
287+ fType' = case fieldPlural of
260288 XmlFieldPluralMandatory -> fieldType
261289 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
262290 XmlFieldPluralRepeated -> [t| [$fieldType] |]
263291 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
292+ fType = if isLenientType genType
293+ then [t| Maybe $fType' |]
294+ else fType'
264295 in if isNewtype
265296 then THC.varStrictType fName (THC.nonStrictType fType)
266297 else THC.varStrictType fName (THC.strictType fType)
@@ -295,7 +326,7 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
295326 [ ]
296327
297328 let
298− genFromDomInst = do
329+ genFromDomInst mode = do
299330 let
300331 exprHeader = [e|pure $(TH.conE name)|]
301332 exprRecordParts = do
@@ -309,8 +340,9 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
309340 fieldParse = case fieldPlural of
310341 XmlFieldPluralMandatory -> [e|inElem|]
311342 _ -> [e|inElemTrav|]
312− in
313− [e|$fieldParse $exprFieldStrName fromDom|]
343+ in case mode of
344+ Strict -> [e|$fieldParse $exprFieldStrName fromDom|]
345+ Lenient -> [e|$fieldParse $exprFieldStrName (ignoreBlank fromDom)|]
314346 IsoXmlDescRecordAttribute descAttribute ->
315347 let
316348 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
@@ -396,12 +428,21 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
396428 return $ [termDecl] ++ lensDecls ++
397429 [toXmlInst, toXmlParentAttributesInst, nfDataInst]
398430 Parser -> do
399− fromDomInst <- genFromDomInst
431+ fromDomInst <- genFromDomInst Strict
432+ return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
433+ LenientParser -> do
434+ fromDomInst <- genFromDomInst Lenient
400435 return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
401436 ParserAndGenerator -> do
402437 toXmlInst <- genToXmlInst
403438 toXmlParentAttributesInst <- genToXmlParentAttributeInst
404− fromDomInst <- genFromDomInst
439+ fromDomInst <- genFromDomInst Strict
440+ return $ [termDecl] ++ lensDecls ++
441+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
442+ LenientParserAndGenerator -> do
443+ toXmlInst <- genToXmlInst
444+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
445+ fromDomInst <- genFromDomInst Lenient
405446 return $ [termDecl] ++ lensDecls ++
406447 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
407448