1
1
mirror of https://github.com/juspay/jrec.git synced 2024-09-19 14:18:17 +03:00

Merge pull request #7 from juspay/kana-json-options

Add options to json encoder/decoder
This commit is contained in:
Andrew / Kana 2020-09-03 17:16:58 +03:00 committed by GitHub
commit 24006893b4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 44 additions and 24 deletions

View File

@ -17,6 +17,13 @@ extra-source-files:
CHANGELOG.md
README.md
flag with-aeson
description: Enable Aeson instances
-- don't let the solver fiddle with the flag
manual: True
-- with instances by default
default: True
-- A common stanza to share with tests, so that ghcid (bin/test) will reload
-- instantly when the library sources change (without us having to restart it).
common library-common
@ -72,6 +79,8 @@ library
other-modules:
JRec.Tuple
JRec.Field
if flag(with-aeson)
cpp-options: -DWITH_AESON
test-suite jrec-test
import: library-common

View File

@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
@ -87,6 +88,12 @@ data Rec (lts :: [*]) = MkRec
{ _unRec :: SmallArray# Any -- Note that the values are physically in reverse order
}
data JSONOptions = JSONOptions
{fieldTransform :: String -> String}
defaultJSONOptions :: JSONOptions
defaultJSONOptions = JSONOptions {fieldTransform = id}
type role Rec representational
instance
@ -102,16 +109,18 @@ instance RecEq lts lts => Eq (Rec lts) where
(==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts)
{-# INLINE (==) #-}
#ifdef WITH_AESON
instance
( RecApply lts lts ToJSON
) =>
ToJSON (Rec lts)
where
toJSON = recToValue
toEncoding = recToEncoding
toJSON = recToValue defaultJSONOptions
toEncoding = recToEncoding defaultJSONOptions
instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where
parseJSON = recJsonParser
parseJSON = recJsonParser defaultJSONOptions
#endif
instance RecNfData lts lts => NFData (Rec lts) where
rnf = recNfData (Proxy :: Proxy lts)
@ -222,7 +231,7 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
)
KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts
type family Reverse (xs :: [*]) where
type family Reverse (xs :: [*]) where
Reverse '[] = '[]
Reverse (x ': xs) = RecAppend (Reverse xs) '[x]
@ -430,7 +439,7 @@ union lts rts =
{-# INLINE union #-}
-- | Insert a field
--
--
-- Insert at beginning, unless the field already exists, in which case set it
-- directly.
insert ::
@ -459,8 +468,6 @@ insert (l := v) rts =
(# s''''#, a# #) -> (# s''''#, MkRec a# #)
{-# INLINE insert #-}
-- | Alias for 'combine'
(++:) ::
forall lhs rhs res.
@ -538,16 +545,21 @@ reflectRecFold _ f r =
showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)]
showRec = reflectRec @Show Proxy (\k v -> (k, show v))
recToValue :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Value
recToValue r = object $ reflectRec @ToJSON Proxy (\k v -> (T.pack k, toJSON v)) r
recToValue :: forall lts. (RecApply lts lts ToJSON) => JSONOptions -> Rec lts -> Value
recToValue options r =
object $ reflectRec @ToJSON Proxy (\k v -> (T.pack (fieldTransform options k), toJSON v)) r
recToEncoding :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Encoding
recToEncoding r = pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack k .= v)) r
recToEncoding :: forall lts. (RecApply lts lts ToJSON) => JSONOptions -> Rec lts -> Encoding
recToEncoding options r =
pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack (fieldTransform options k) .= v)) r
recJsonParser :: forall lts s. (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => Value -> Parser (Rec lts)
recJsonParser =
recJsonParser ::
forall lts s.
(RecSize lts ~ s, KnownNat s, RecJsonParse lts) =>
(JSONOptions -> Value -> Parser (Rec lts))
recJsonParser options =
withObject "Record" $ \o ->
recJsonParse initSize o
recJsonParse options initSize o
where
initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)
@ -607,10 +619,10 @@ type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where
-- | Machinery to implement parseJSON
class RecJsonParse (lts :: [*]) where
recJsonParse :: Int -> Object -> Parser (Rec lts)
recJsonParse :: JSONOptions -> Int -> Object -> Parser (Rec lts)
instance RecJsonParse '[] where
recJsonParse initSize _ = pure (unsafeRNil initSize)
recJsonParse _ initSize _ = pure (unsafeRNil initSize)
instance
( KnownSymbol l,
@ -622,13 +634,12 @@ instance
) =>
RecJsonParse (l := t ': lts)
where
recJsonParse initSize obj =
do
let lbl :: FldProxy l
lbl = FldProxy
rest <- recJsonParse initSize obj
(v :: t) <- obj .: T.pack (symbolVal lbl)
pure $ unsafeRCons (lbl := v) rest
recJsonParse options initSize obj = do
let lbl :: FldProxy l
lbl = FldProxy
rest <- recJsonParse options initSize obj
(v :: t) <- obj .: T.pack (fieldTransform options (symbolVal lbl))
pure $ unsafeRCons (lbl := v) rest
-- | Machinery for NFData
class RecNfData (lts :: [*]) (rts :: [*]) where
@ -744,7 +755,7 @@ class NoConstraint x
instance NoConstraint x
-- | Convert a record into a list of fields.
--
--
-- | Not present in original superrecord
getFields :: RecApply fields fields NoConstraint => Rec fields -> [Any]
getFields =