git.iko.soy/jrec
on master help sign in
Add options to json encoder/decoder
588247bkana-sama
src/JRec/Internal.hs+32−24
compare with master
unifiedsplit
@@ -87,6 +87,12 @@ data Rec (lts :: [*]) = MkRec
87 { _unRec :: SmallArray# Any -- Note that the values are physically in reverse order
87 { _unRec :: SmallArray# Any -- Note that the values are physically in reverse order
88 }
88 }
89
89
90+data JSONOptions = JSONOptions
91+ {fieldTransform :: String -> String}
92+
93+defaultJSONOptions :: JSONOptions
94+defaultJSONOptions = JSONOptions {fieldTransform = id}
95+
90type role Rec representational
96type role Rec representational
91
97
92instance
98instance
@@ -107,11 +113,11 @@ instance
107 ) =>
113 ) =>
108 ToJSON (Rec lts)
114 ToJSON (Rec lts)
109 where
115 where
110− toJSON = recToValue
116+ toJSON = recToValue defaultJSONOptions
111− toEncoding = recToEncoding
117+ toEncoding = recToEncoding defaultJSONOptions
112
118
113instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where
119instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where
114− parseJSON = recJsonParser
120+ parseJSON = recJsonParser defaultJSONOptions
115
121
116instance RecNfData lts lts => NFData (Rec lts) where
122instance RecNfData lts lts => NFData (Rec lts) where
117 rnf = recNfData (Proxy :: Proxy lts)
123 rnf = recNfData (Proxy :: Proxy lts)
@@ -222,7 +228,7 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
222 )
228 )
223 KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts
229 KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts
224
230
225−type family Reverse (xs :: [*]) where
231+type family Reverse (xs :: [*]) where
226 Reverse '[] = '[]
232 Reverse '[] = '[]
227 Reverse (x ': xs) = RecAppend (Reverse xs) '[x]
233 Reverse (x ': xs) = RecAppend (Reverse xs) '[x]
228
234
@@ -430,7 +436,7 @@ union lts rts =
430{-# INLINE union #-}
436{-# INLINE union #-}
431
437
432-- | Insert a field
438-- | Insert a field
433−--
439+--
434-- Insert at beginning, unless the field already exists, in which case set it
440-- Insert at beginning, unless the field already exists, in which case set it
435-- directly.
441-- directly.
436insert ::
442insert ::
@@ -459,8 +465,6 @@ insert (l := v) rts =
459 (# s''''#, a# #) -> (# s''''#, MkRec a# #)
465 (# s''''#, a# #) -> (# s''''#, MkRec a# #)
460{-# INLINE insert #-}
466{-# INLINE insert #-}
461
467
462−
463−
464-- | Alias for 'combine'
468-- | Alias for 'combine'
465(++:) ::
469(++:) ::
466 forall lhs rhs res.
470 forall lhs rhs res.
@@ -538,16 +542,21 @@ reflectRecFold _ f r =
538showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)]
542showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)]
539showRec = reflectRec @Show Proxy (\k v -> (k, show v))
543showRec = reflectRec @Show Proxy (\k v -> (k, show v))
540
544
541−recToValue :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Value
545+recToValue :: forall lts. (RecApply lts lts ToJSON) => JSONOptions -> Rec lts -> Value
546+recToValue options r =
542−recToValue r = object $ reflectRec @ToJSON Proxy (\k v -> (T.pack k, toJSON v)) r
547+ object $ reflectRec @ToJSON Proxy (\k v -> (T.pack (fieldTransform options k), toJSON v)) r
543
548
544−recToEncoding :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Encoding
549+recToEncoding :: forall lts. (RecApply lts lts ToJSON) => JSONOptions -> Rec lts -> Encoding
550+recToEncoding options r =
545−recToEncoding r = pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack k .= v)) r
551+ pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack (fieldTransform options k) .= v)) r
546
552
553+recJsonParser ::
554+ forall lts s.
547−recJsonParser :: forall lts s. (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => Value -> Parser (Rec lts)
555+ (RecSize lts ~ s, KnownNat s, RecJsonParse lts) =>
556+ (JSONOptions -> Value -> Parser (Rec lts))
548−recJsonParser =
557+recJsonParser options =
549 withObject "Record" $ \o ->
558 withObject "Record" $ \o ->
550− recJsonParse initSize o
559+ recJsonParse options initSize o
551 where
560 where
552 initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)
561 initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)
553
562
@@ -607,10 +616,10 @@ type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where
607
616
608-- | Machinery to implement parseJSON
617-- | Machinery to implement parseJSON
609class RecJsonParse (lts :: [*]) where
618class RecJsonParse (lts :: [*]) where
610− recJsonParse :: Int -> Object -> Parser (Rec lts)
619+ recJsonParse :: JSONOptions -> Int -> Object -> Parser (Rec lts)
611
620
612instance RecJsonParse '[] where
621instance RecJsonParse '[] where
613− recJsonParse initSize _ = pure (unsafeRNil initSize)
622+ recJsonParse _ initSize _ = pure (unsafeRNil initSize)
614
623
615instance
624instance
616 ( KnownSymbol l,
625 ( KnownSymbol l,
@@ -622,13 +631,12 @@ instance
622 ) =>
631 ) =>
623 RecJsonParse (l := t ': lts)
632 RecJsonParse (l := t ': lts)
624 where
633 where
625− recJsonParse initSize obj =
634+ recJsonParse options initSize obj = do
626− do
627− let lbl :: FldProxy l
635+ let lbl :: FldProxy l
628− lbl = FldProxy
636+ lbl = FldProxy
629− rest <- recJsonParse initSize obj
637+ rest <- recJsonParse options initSize obj
630− (v :: t) <- obj .: T.pack (symbolVal lbl)
638+ (v :: t) <- obj .: T.pack (fieldTransform options (symbolVal lbl))
631− pure $ unsafeRCons (lbl := v) rest
639+ pure $ unsafeRCons (lbl := v) rest
632
640
633-- | Machinery for NFData
641-- | Machinery for NFData
634class RecNfData (lts :: [*]) (rts :: [*]) where
642class RecNfData (lts :: [*]) (rts :: [*]) where
@@ -744,7 +752,7 @@ class NoConstraint x
744instance NoConstraint x
752instance NoConstraint x
745
753
746-- | Convert a record into a list of fields.
754-- | Convert a record into a list of fields.
747−--
755+--
748-- | Not present in original superrecord
756-- | Not present in original superrecord
749getFields :: RecApply fields fields NoConstraint => Rec fields -> [Any]
757getFields :: RecApply fields fields NoConstraint => Rec fields -> [Any]
750getFields =
758getFields =