@@ -0,0 +1,332 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE FunctionalDependencies #-}
3+
4+{- |
5+
6+Generate XML-isomorphic types from declarative descriptions.
7+
8+There are two kinds of XML-isomorphic types: enumerations and records.
9+Enumerations are simple enum-types generated via "Data.THGen.Enum"
10+plus a `FromContent` instance and a `ToXML` instance which are derived
11+from `Read` and `Show`. Records are a bit more complicated: to define
12+a record you need to supply its name, a prefix for fields, and a list
13+of field descriptions. A field description contains the XML tag name
14+and repetition kind (mandatory, optional, repeated or multiplied).
15+
16+The repetition kind determines both the parsing strategy and the
17+wrapper around the field type:
18+
19+* @a@ for mandatory fields
20+* @Maybe a@ for optional fields
21+* @[a]@ for repeated fields
22+* @NonEmpty a@ for multiplied fields
23+
24+Example 1.
25+
26+> "Color" =:= enum
27+> & "R"
28+> & "G"
29+> & "B"
30+
31+produces
32+
33+> data XmlColor
34+> = XmlColorR
35+> | XmlColorG
36+> | XmlColorB
37+> | UnknownXmlColor String
38+
39+with a `FromContent` instance that expects the current element content
40+to be either @R@, @G@ or @B@.
41+
42+Example 2.
43+
44+> "Message" =:= record
45+> ! "author"
46+> + "recipient"
47+> ? "message" [t|Text|]
48+> * "attachement"
49+
50+produces
51+
52+> data Message = Message
53+> { _mAuthor :: Author
54+> , _mRecipient :: NonEmpty Recipient
55+> , _mMessage :: Maybe Text
56+> , _mAttachement :: [Attachement]
57+> } deriving (...)
58+
59+with a corresponding `FromDom` instance. Lenses are generated
60+automatically as well.
61+
62+The examples above also demonstrate that to define the declarative
63+descriptions of data types we provide a terse and convenient EDSL.
64+
65+To define an enumeration, use the `enum` function followed by the name
66+of the data type to be generated. You can optionally specify if the
67+enumeration is exhaustive (contains only the listed constructors) or
68+non-exhaustive (also contains a constructor for unknown values; this
69+is the default):
70+
71+> "Enum1" Exhaustive =:= enum
72+> ...
73+
74+> "Enum2" NonExhaustive =:= enum
75+> ...
76+
77+To define a record, use the `record` function followed by the name of
78+the data type to be generated. The prefix for the record fields is
79+inferred automatically by taking all of the uppercase letters in the
80+name. You can override it manually like so:
81+
82+> "Reference" "ref" =:= record
83+> ...
84+
85+To describe a record field you must supply its name as it appears
86+in the XML tag, prefixed by its repetition kind:
87+
88+* @!@ for mandatory fields
89+* @?@ for optional fields
90+* @*@ for repeated fields
91+* @+@ for multiplied fields
92+
93+The type of the field is inferred automatically from its name, so
94+if the field is called @"author"@ its type will be @Author@. You can
95+override the type by specifying it in quasiquotes like so:
96+
97+> "Message" =:= record
98+> ! "author" [t|Person|]
99+> ...
100+
101+-}
102+
103+
104+module Data.THGen.XML
105+ ( Exhaustiveness(..)
106+ , PrefixName(..)
107+ , ExhaustivenessName(..)
108+ , record
109+ , enum
110+ , (!)
111+ , (?)
112+ , (*)
113+ , (+)
114+ , (&)
115+ , (=:=)
116+ -- Re-exports
117+ , T.Text
118+ , Int
119+ , Integer
120+ ) where
121+
122+import Control.Lens hiding (repeated, enum, (&))
123+import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
124+import qualified Data.Char as C
125+import Data.List.NonEmpty (NonEmpty)
126+import Data.String
127+import Data.THGen.Enum
128+import qualified Data.Text as T
129+import qualified Language.Haskell.TH as TH
130+import Prelude hiding ((+), (*))
131+import Text.XML.DOM.Parser
132+import qualified Text.XML.Writer as XW
133+
134+data XmlFieldPlural
135+ = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
136+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
137+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
138+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
139+
140+data PrefixName = PrefixName String String
141+
142+data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
143+
144+data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
145+
146+data IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescField]
147+
148+makePrisms ''IsoXmlDescRecord
149+
150+data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
151+
152+newtype IsoXmlDescEnumCon
153+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
154+
155+instance IsString IsoXmlDescEnumCon where
156+ fromString = IsoXmlDescEnumCon
157+
158+data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
159+
160+makePrisms ''IsoXmlDescEnum
161+
162+appendField
163+ :: XmlFieldPlural
164+ -> IsoXmlDescRecord
165+ -> IsoXmlDescPreField
166+ -> IsoXmlDescRecord
167+appendField plural xrec (IsoXmlDescPreField name ty) =
168+ let xfield = IsoXmlDescField plural name ty
169+ in over _IsoXmlDescRecord (xfield:) xrec
170+
171+(!) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
172+(!) = appendField XmlFieldPluralMandatory
173+
174+(?) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
175+(?) = appendField XmlFieldPluralOptional
176+
177+(*) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
178+(*) = appendField XmlFieldPluralRepeated
179+
180+(+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
181+(+) = appendField XmlFieldPluralMultiplied
182+
183+infixl 2 !
184+infixl 2 ?
185+infixl 2 *
186+infixl 2 +
187+
188+appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
189+appendEnumCon xenum xenumcon =
190+ over _IsoXmlDescEnum (xenumcon:) xenum
191+
192+(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
193+(&) = appendEnumCon
194+
195+infixl 2 &
196+
197+class Description name desc | desc -> name where
198+ (=:=) :: name -> desc -> TH.DecsQ
199+
200+infix 0 =:=
201+
202+instance Description PrefixName IsoXmlDescRecord where
203+ prefixName =:= descRecord =
204+ let descFields = descRecord ^. _IsoXmlDescRecord
205+ in isoXmlGenerateRecord prefixName (reverse descFields)
206+
207+record :: IsoXmlDescRecord
208+record = IsoXmlDescRecord []
209+
210+enum :: IsoXmlDescEnum
211+enum = IsoXmlDescEnum []
212+
213+instance Description ExhaustivenessName IsoXmlDescEnum where
214+ exhaustivenessName =:= descEnum =
215+ let descEnumCons = descEnum ^. _IsoXmlDescEnum
216+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
217+
218+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
219+ fromString = IsoXmlDescPreField
220+
221+instance IsString IsoXmlDescPreField where
222+ fromString name = IsoXmlDescPreField name ty
223+ where
224+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
225+
226+instance s ~ String => IsString (s -> PrefixName) where
227+ fromString = PrefixName
228+
229+instance IsString PrefixName where
230+ fromString strName = PrefixName strName (makeNamePrefix strName)
231+
232+instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
233+ fromString = ExhaustivenessName
234+
235+instance IsString ExhaustivenessName where
236+ fromString strName = ExhaustivenessName strName NonExhaustive
237+
238+makeNamePrefix :: String -> String
239+makeNamePrefix = map C.toLower . filter C.isUpper
240+
241+funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
242+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
243+
244+isoXmlGenerateEnum
245+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
246+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
247+ let
248+ strName = "Xml" ++ strName'
249+ strVals = map unIsoXmlDescEnumCon enumCons
250+ enumDesc = EnumDesc exh strName strVals
251+ name = TH.mkName strName
252+ enumDecls <- enumGenerate enumDesc
253+ toXmlInst <- do
254+ let toXmlExpr = [e|XW.toXML . T.pack . show|]
255+ TH.instanceD
256+ (return [])
257+ [t|XW.ToXML $(TH.conT name)|]
258+ [funSimple 'XW.toXML toXmlExpr]
259+ fromDomInst <- do
260+ TH.instanceD
261+ (return [])
262+ [t|FromDom $(TH.conT name)|]
263+ [ funSimple 'fromDom [e|parseContent readContent|] ]
264+ return (enumDecls ++ [toXmlInst, fromDomInst])
265+
266+isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescField] -> TH.DecsQ
267+isoXmlGenerateRecord (PrefixName strName' strPrefix') descFields = do
268+ let
269+ strName = "Xml" ++ strName'
270+ strPrefix = "x" ++ strPrefix'
271+ name = TH.mkName strName
272+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
273+ dataDecl <- do
274+ let
275+ constructors = do
276+ IsoXmlDescField fieldPlural fieldStrName fieldType <- descFields
277+ let
278+ fName = TH.mkName (fieldName fieldStrName)
279+ fType = case fieldPlural of
280+ XmlFieldPluralMandatory -> fieldType
281+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]
282+ XmlFieldPluralRepeated -> [t| [$fieldType] |]
283+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
284+ return $ TH.varStrictType fName (TH.strictType TH.isStrict fType)
285+ TH.dataD
286+ (return [])
287+ name
288+ []
289+ [TH.recC name constructors]
290+ [''Eq, ''Show]
291+ lensDecls <- makeFieldOpticsForDec lensRules dataDecl
292+ fromDomInst <- do
293+ let
294+ exprHeader = [e|pure $(TH.conE name)|]
295+ exprFields = do
296+ IsoXmlDescField fieldPlural fieldStrName _ <- descFields
297+ let
298+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
299+ fieldParse = case fieldPlural of
300+ XmlFieldPluralMandatory -> [e|inElem|]
301+ _ -> [e|inElemTrav|]
302+ return [e|$fieldParse $exprFieldStrName fromDom|]
303+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprFields
304+ TH.instanceD
305+ (return [])
306+ [t|FromDom $(TH.conT name)|]
307+ [ funSimple 'fromDom fromDomExpr ]
308+
309+ toXmlInst <- do
310+ objName <- TH.newName strPrefix
311+ let
312+ exprFooter = [e|return ()|]
313+ exprFields = do
314+ IsoXmlDescField fieldPlural fieldStrName _ <- descFields
315+ let
316+ fieldRender = [e|XW.toXML|]
317+ fName = TH.mkName (fieldName fieldStrName)
318+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
319+ exprForField = case fieldPlural of
320+ XmlFieldPluralMandatory -> [e|id|]
321+ _ -> [e|traverse|]
322+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
323+ exprFieldRender = [e|XW.element $exprFieldStrName . $fieldRender|]
324+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
325+ toXmlExpr
326+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
327+ $ foldr (\fe e -> [e|$fe *> $e|]) exprFooter exprFields
328+ TH.instanceD
329+ (return [])
330+ [t|XW.ToXML $(TH.conT name)|]
331+ [funSimple 'XW.toXML toXmlExpr]
332+ return $ [dataDecl] ++ lensDecls ++ [fromDomInst, toXmlInst]