@@ -5,7 +5,7 @@
55module Data.THGen.XML.Internal where
66
77import Control.DeepSeq
8−import Control.Lens hiding (repeated, enum, (&), Strict)
8+import Control.Lens hiding (repeated, enum, (&))
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 hiding (Strict)
18+import Language.Haskell.TH as TH
1919import Prelude hiding ((+), (*), (^))
2020import qualified Text.XML as X
2121import Text.XML.DOM.Parser hiding (parseContent)
@@ -23,22 +23,8 @@ 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
2926
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
27+data GenType = Parser | Generator | ParserAndGenerator
4228
4329data XmlFieldPlural
4430 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
@@ -160,7 +146,7 @@ instance Description ExhaustivenessName IsoXmlDescEnum where
160146 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
161147 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
162148
163−instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where
149+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
164150 fromString = IsoXmlDescPreField
165151
166152instance IsString IsoXmlDescPreField where
@@ -168,10 +154,10 @@ instance IsString IsoXmlDescPreField where
168154 where
169155 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
170156
171−instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where
157+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
172158 fromString = IsoXmlDescPreAttribute
173159
174−instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where
160+instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
175161 fromString = IsoXmlDescPreContent
176162
177163instance IsString IsoXmlDescPreAttribute where
@@ -225,14 +211,11 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
225211 (return [])
226212 [t|ToXmlAttribute $(TH.conT name)|]
227213 [funSimple 'toXmlAttribute [e|T.pack . show|]]
228− genFromDomInst mode = do
214+ genFromDomInst = do
229215 TH.instanceD
230216 (return [])
231217 [t|FromDom $(TH.conT name)|]
232− [case mode of
233− Strict -> funSimple 'fromDom [e|parseContent readContent|]
234− Lenient -> funSimple 'fromDom [e|ignoreBlank $ parseContent readContent|]
235− ]
218+ [funSimple 'fromDom [e|parseContent readContent|]]
236219 genFromAttributeInst = do
237220 TH.instanceD
238221 (return [])
@@ -244,24 +227,13 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
244227 toXmlAttributeInst <- genToXmlAttributeInst
245228 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]
246229 Parser -> do
247− fromDomInst <- genFromDomInst Strict
248− fromAttributeInst <- genFromAttributeInst
249− return $ enumDecls ++ [fromDomInst, fromAttributeInst]
250− LenientParser -> do
251− fromDomInst <- genFromDomInst Lenient
230+ fromDomInst <- genFromDomInst
252231 fromAttributeInst <- genFromAttributeInst
253232 return $ enumDecls ++ [fromDomInst, fromAttributeInst]
254233 ParserAndGenerator -> do
255234 toXmlInst <- genToXmlInst
256235 toXmlAttributeInst <- genToXmlAttributeInst
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
236+ fromDomInst <- genFromDomInst
265237 fromAttributeInst <- genFromAttributeInst
266238 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
267239 fromDomInst, fromAttributeInst]
@@ -284,14 +256,11 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
284256 IsoXmlDescField fieldPlural rawName fieldType = descField
285257 fieldStrName = xmlLocalName rawName
286258 fName = TH.mkName (fieldName fieldStrName)
287− fType' = case fieldPlural of
259+ fType = case fieldPlural of
288260 XmlFieldPluralMandatory -> fieldType
289261 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
290262 XmlFieldPluralRepeated -> [t| [$fieldType] |]
291263 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
292− fType = if isLenientType genType
293− then [t| Maybe $fType' |]
294− else fType'
295264 in if isNewtype
296265 then THC.varStrictType fName (THC.nonStrictType fType)
297266 else THC.varStrictType fName (THC.strictType fType)
@@ -326,7 +295,7 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
326295 [ ]
327296
328297 let
329− genFromDomInst mode = do
298+ genFromDomInst = do
330299 let
331300 exprHeader = [e|pure $(TH.conE name)|]
332301 exprRecordParts = do
@@ -340,9 +309,8 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
340309 fieldParse = case fieldPlural of
341310 XmlFieldPluralMandatory -> [e|inElem|]
342311 _ -> [e|inElemTrav|]
343− in case mode of
344− Strict -> [e|$fieldParse $exprFieldStrName fromDom|]
345− Lenient -> [e|$fieldParse $exprFieldStrName (ignoreBlank fromDom)|]
312+ in
313+ [e|$fieldParse $exprFieldStrName fromDom|]
346314 IsoXmlDescRecordAttribute descAttribute ->
347315 let
348316 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
@@ -428,21 +396,12 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
428396 return $ [termDecl] ++ lensDecls ++
429397 [toXmlInst, toXmlParentAttributesInst, nfDataInst]
430398 Parser -> do
431− fromDomInst <- genFromDomInst Strict
432− return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
433− LenientParser -> do
434− fromDomInst <- genFromDomInst Lenient
399+ fromDomInst <- genFromDomInst
435400 return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
436401 ParserAndGenerator -> do
437402 toXmlInst <- genToXmlInst
438403 toXmlParentAttributesInst <- genToXmlParentAttributeInst
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
404+ fromDomInst <- genFromDomInst
446405 return $ [termDecl] ++ lensDecls ++
447406 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
448407