@@ -120,6 +120,9 @@ data Options = Options
120120 { fieldNameModifier :: String -> String
121121 -- ^ Function applied to field names.
122122 -- Handy for removing common record prefixes for example.
123+ , constructorNameModifier :: String -> String
124+ -- ^ Function applied to constructor names.
125+ -- Handy for lower-casing constructor names for example.
123126 , nullaryToString :: Bool
124127 -- ^ If 'True' the constructors of a datatypes, with all nullary
125128 -- constructors, will be encoded to a string with the
@@ -153,9 +156,10 @@ data SumEncoding =
153156-- 2-element array for other sum datatypes.
154157defaultOptions :: Options
155158defaultOptions = Options
156− { fieldNameModifier = id
157− , nullaryToString = True
158− , sumEncoding = TwoElemArray
159+ { fieldNameModifier = id
160+ , constructorNameModifier = id
161+ , nullaryToString = True
162+ , sumEncoding = TwoElemArray
159163 }
160164
161165--------------------------------------------------------------------------------
@@ -245,26 +249,22 @@ consToJSON opts cons = do
245249 value <- newName "value"
246250 lam1E (varP value) $ caseE (varE value) matches
247251 where
248− -- Constructors of a datatype with all nullary constructors are encoded to
249− -- just a string with the constructor name:
250− matches | nullaryToString opts && all isNullary cons =
251− [ match (conP conName []) (normalB $ conStr conName) []
252− | con <- cons
253− , let conName = getConName con
254− ]
255− -- Constructors of a datatype having some constructors with arity > 0 are
256− -- encoded to a 2-element array where the first element is a string with
257− -- the constructor name and the second element is the encoded argument or
258− -- arguments of the constructor.
259− | otherwise = [ encodeArgs opts True con
260− | con <- cons
261− ]
252+ matches
253+ | nullaryToString opts && all isNullary cons =
254+ [ match (conP conName []) (normalB $ conStr opts conName) []
255+ | con <- cons
256+ , let conName = getConName con
257+ ]
258+ | otherwise = [encodeArgs opts True con | con <- cons]
259+
260+conStr :: Options -> Name -> Q Exp
261+conStr opts = appE [|String|] . conTxt opts
262262
263−conStr :: Name -> Q Exp
264−conStr = appE [|String|] . conTxt
263+conTxt :: Options -> Name -> Q Exp
264+conTxt opts = appE [|T.pack|] . conStringE opts
265265
266−conTxt :: Name -> Q Exp
267−conTxt = appE [|T.pack|] . stringE . nameBase
266+conStringE :: Options -> Name -> Q Exp
267+conStringE opts = stringE . constructorNameModifier opts . nameBase
268268
269269-- | If constructor is nullary.
270270isNullary :: Con -> Bool
@@ -276,15 +276,15 @@ encodeSum opts multiCons conName exp
276276 | multiCons =
277277 case sumEncoding opts of
278278 TwoElemArray ->
279− [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr conName, exp])
279+ [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
280280 ObjectWithType{typeFieldName, valueFieldName} ->
281281 [|object|] `appE` listE
282− [ infixApp [|T.pack typeFieldName|] [|(.=)|] (conStr conName)
282+ [ infixApp [|T.pack typeFieldName|] [|(.=)|] (conStr opts conName)
283283 , infixApp [|T.pack valueFieldName|] [|(.=)|] exp
284284 ]
285285 ObjectWithSingleField ->
286286 [|object|] `appE` listE
287− [ infixApp (conTxt conName) [|(.=)|] exp
287+ [ infixApp (conTxt opts conName) [|(.=)|] exp
288288 ]
289289
290290 | otherwise = exp
@@ -340,16 +340,16 @@ encodeArgs opts multiCons (RecC conName ts) = do
340340 ( normalB
341341 $ if multiCons
342342 then case sumEncoding opts of
343− TwoElemArray -> [|toJSON|] `appE` tupE [conStr conName, exp]
343+ TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
344344 ObjectWithType{typeFieldName} ->
345345 [|object|] `appE` listE
346346 ( infixApp [|T.pack typeFieldName|] [|(.=)|]
347− (conStr conName)
347+ (conStr opts conName)
348348 : js
349349 )
350350 ObjectWithSingleField ->
351351 [|object|] `appE` listE
352− [ infixApp (conTxt conName) [|(.=)|] exp ]
352+ [ infixApp (conTxt opts conName) [|(.=)|] exp ]
353353 else exp
354354 ) []
355355
@@ -441,7 +441,8 @@ consFromJSON tName opts cons = do
441441 infixApp (varE txt)
442442 [|(==)|]
443443 ([|T.pack|] `appE`
444− stringE (nameBase conName)))
444+ conStringE opts conName)
445+ )
445446 ([|pure|] `appE` conE conName)
446447 | con <- cons
447448 , let conName = getConName con
@@ -563,7 +564,8 @@ consFromJSON tName opts cons = do
563564 ( guardedB $
564565 [ do g <- normalG $ infixApp (varE conKey)
565566 [|(==)|]
566− ([|T.pack|] `appE` conNameExp con)
567+ ([|T.pack|] `appE`
568+ conNameExp opts con)
567569 e <- parseArgs tName opts con contents
568570 return (g, e)
569571 | con <- cons
@@ -573,7 +575,13 @@ consFromJSON tName opts cons = do
573575 (normalG [e|otherwise|])
574576 ( varE errorFun
575577 `appE` (litE $ stringL $ show tName)
576− `appE` listE (map (litE . stringL . nameBase . getConName) cons)
578+ `appE` listE (map ( litE
579+ . stringL
580+ . constructorNameModifier opts
581+ . nameBase
582+ . getConName
583+ ) cons
584+ )
577585 `appE` ([|T.unpack|] `appE` varE conKey)
578586 )
579587 ]
@@ -621,7 +629,7 @@ parseRecord opts tName conName ts obj =
621629 where
622630 x:xs = [ [|lookupField|]
623631 `appE` (litE $ stringL $ show tName)
624− `appE` (litE $ stringL $ nameBase conName)
632+ `appE` (litE $ stringL $ constructorNameModifier opts $ nameBase conName)
625633 `appE` (varE obj)
626634 `appE` ( [|T.pack|] `appE` fieldNameExp opts field
627635 )
@@ -846,8 +854,12 @@ tvbName (PlainTV name ) = name
846854tvbName (KindedTV name _) = name
847855
848856-- | Makes a string literal expression from a constructor's name.
849−conNameExp :: Con -> Q Exp
850−conNameExp = litE . stringL . nameBase . getConName
857+conNameExp :: Options -> Con -> Q Exp
858+conNameExp opts = litE
859+ . stringL
860+ . constructorNameModifier opts
861+ . nameBase
862+ . getConName
851863
852864-- | Creates a string literal expression from a record field name.
853865fieldNameExp :: Options -- ^ Encoding options