@@ -1,10 +1,11 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE UndecidableInstances #-}
23{-# LANGUAGE FunctionalDependencies #-}
34
45module Data.THGen.XML.Internal where
56
67import Control.DeepSeq
7−import Control.Lens hiding (repeated, enum, (&))
8+import Control.Lens hiding (repeated, enum, (&), Strict)
89import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
910import qualified Data.Char as C
1011import Data.List.NonEmpty (NonEmpty)
@@ -14,7 +15,7 @@ import Data.THGen.Compat as THC
1415import Data.THGen.Enum
1516import qualified Data.Text as T
1617import GHC.Generics (Generic)
17−import Language.Haskell.TH as TH
18+import Language.Haskell.TH as TH hiding (Strict)
1819import Prelude hiding ((+), (*), (^))
1920import qualified Text.XML as X
2021import Text.XML.DOM.Parser hiding (parseContent)
@@ -22,8 +23,22 @@ import Text.XML.DOM.Parser.Internal.Content
2223import Text.XML.ParentAttributes
2324import qualified Text.XML.Writer as XW
2425
26+data ParserMode
27+ = Strict
28+ | Lenient
2529
26−data GenType = Parser | Generator | Both
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
2742
2843data XmlFieldPlural
2944 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
@@ -145,7 +160,7 @@ instance Description ExhaustivenessName IsoXmlDescEnum where
145160 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
146161 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
147162
148−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
163+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where
149164 fromString = IsoXmlDescPreField
150165
151166instance IsString IsoXmlDescPreField where
@@ -153,10 +168,10 @@ instance IsString IsoXmlDescPreField where
153168 where
154169 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
155170
156−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
171+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where
157172 fromString = IsoXmlDescPreAttribute
158173
159−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
174+instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where
160175 fromString = IsoXmlDescPreContent
161176
162177instance IsString IsoXmlDescPreAttribute where
@@ -182,7 +197,7 @@ instance IsString ExhaustivenessName where
182197 fromString strName = ExhaustivenessName strName NonExhaustive
183198
184199makeNamePrefix :: String -> String
185−makeNamePrefix = map C.toLower . filter C.isUpper
200+makeNamePrefix = map C.toLower . filter (\c -> C.isUpper c || C.isDigit c)
186201
187202funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
188203funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
@@ -210,11 +225,14 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
210225 (return [])
211226 [t|ToXmlAttribute $(TH.conT name)|]
212227 [funSimple 'toXmlAttribute [e|T.pack . show|]]
213− genFromDomInst = do
228+ genFromDomInst mode = do
214229 TH.instanceD
215230 (return [])
216231 [t|FromDom $(TH.conT name)|]
217− [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+ ]
218236 genFromAttributeInst = do
219237 TH.instanceD
220238 (return [])
@@ -226,13 +244,24 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
226244 toXmlAttributeInst <- genToXmlAttributeInst
227245 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]
228246 Parser -> do
229− fromDomInst <- genFromDomInst
247+ fromDomInst <- genFromDomInst Strict
248+ fromAttributeInst <- genFromAttributeInst
249+ return $ enumDecls ++ [fromDomInst, fromAttributeInst]
250+ LenientParser -> do
251+ fromDomInst <- genFromDomInst Lenient
230252 fromAttributeInst <- genFromAttributeInst
231253 return $ enumDecls ++ [fromDomInst, fromAttributeInst]
232− Both -> do
254+ ParserAndGenerator -> do
255+ toXmlInst <- genToXmlInst
256+ toXmlAttributeInst <- genToXmlAttributeInst
257+ fromDomInst <- genFromDomInst Strict
258+ fromAttributeInst <- genFromAttributeInst
259+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
260+ fromDomInst, fromAttributeInst]
261+ LenientParserAndGenerator -> do
233262 toXmlInst <- genToXmlInst
234263 toXmlAttributeInst <- genToXmlAttributeInst
235− fromDomInst <- genFromDomInst
264+ fromDomInst <- genFromDomInst Lenient
236265 fromAttributeInst <- genFromAttributeInst
237266 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
238267 fromDomInst, fromAttributeInst]
@@ -255,11 +284,14 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
255284 IsoXmlDescField fieldPlural rawName fieldType = descField
256285 fieldStrName = xmlLocalName rawName
257286 fName = TH.mkName (fieldName fieldStrName)
258− fType = case fieldPlural of
287+ fType' = case fieldPlural of
259288 XmlFieldPluralMandatory -> fieldType
260289 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
261290 XmlFieldPluralRepeated -> [t| [$fieldType] |]
262291 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
292+ fType = if isLenientType genType
293+ then [t| Maybe $fType' |]
294+ else fType'
263295 in if isNewtype
264296 then THC.varStrictType fName (THC.nonStrictType fType)
265297 else THC.varStrictType fName (THC.strictType fType)
@@ -294,7 +326,7 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
294326 [ ]
295327
296328 let
297− genFromDomInst = do
329+ genFromDomInst mode = do
298330 let
299331 exprHeader = [e|pure $(TH.conE name)|]
300332 exprRecordParts = do
@@ -308,8 +340,9 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
308340 fieldParse = case fieldPlural of
309341 XmlFieldPluralMandatory -> [e|inElem|]
310342 _ -> [e|inElemTrav|]
311− in
312− [e|$fieldParse $exprFieldStrName fromDom|]
343+ in case mode of
344+ Strict -> [e|$fieldParse $exprFieldStrName fromDom|]
345+ Lenient -> [e|$fieldParse $exprFieldStrName (ignoreBlank fromDom)|]
313346 IsoXmlDescRecordAttribute descAttribute ->
314347 let
315348 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
@@ -379,11 +412,11 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
379412 toXmlParentAttributesExpr
380413 = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
381414 $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
382− #if __GLASGOW_HASKELL__ < 800
415+#if __GLASGOW_HASKELL__ < 800
383416 TH.instanceD
384− #else
417+#else
385418 TH.instanceWithOverlapD (Just TH.Overlapping)
386− #endif
419+#endif
387420 (return [])
388421 [t|ToXmlParentAttributes $(TH.conT name)|]
389422 [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
@@ -395,12 +428,21 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
395428 return $ [termDecl] ++ lensDecls ++
396429 [toXmlInst, toXmlParentAttributesInst, nfDataInst]
397430 Parser -> do
398− fromDomInst <- genFromDomInst
431+ fromDomInst <- genFromDomInst Strict
399432 return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
400− Both -> do
433+ LenientParser -> do
434+ fromDomInst <- genFromDomInst Lenient
435+ return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
436+ ParserAndGenerator -> do
437+ toXmlInst <- genToXmlInst
438+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
439+ fromDomInst <- genFromDomInst Strict
440+ return $ [termDecl] ++ lensDecls ++
441+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
442+ LenientParserAndGenerator -> do
401443 toXmlInst <- genToXmlInst
402444 toXmlParentAttributesInst <- genToXmlParentAttributeInst
403− fromDomInst <- genFromDomInst
445+ fromDomInst <- genFromDomInst Lenient
404446 return $ [termDecl] ++ lensDecls ++
405447 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
406448