2400689 · jrec · git.iko.soy

git.iko.soy/jrec

on master help sign in

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

2400689Andrew / Kana6 years ago

jrec.cabal+9

compare with master

unifiedsplit

@@ -17,6 +17,13 @@ extra-source-files:

17 CHANGELOG.md

18 README.md

20+flag with-aeson

21+ description: Enable Aeson instances

22+ -- don't let the solver fiddle with the flag

23+ manual: True

24+ -- with instances by default

25+ default: True

26+

20-- A common stanza to share with tests, so that ghcid (bin/test) will reload

27-- A common stanza to share with tests, so that ghcid (bin/test) will reload

21-- instantly when the library sources change (without us having to restart it).

28-- instantly when the library sources change (without us having to restart it).

22common library-common

29common library-common

@@ -72,6 +79,8 @@ library

72 other-modules:

79 other-modules:

73 JRec.Tuple

80 JRec.Tuple

74 JRec.Field

81 JRec.Field

82+ if flag(with-aeson)

83+ cpp-options: -DWITH_AESON

76test-suite jrec-test

85test-suite jrec-test

77 import: library-common

86 import: library-common

src/JRec/Internal.hs+35−24

@@ -1,4 +1,5 @@

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE ExistentialQuantification #-}

@@ -87,6 +88,12 @@ data Rec (lts :: [*]) = MkRec

87 { _unRec :: SmallArray# Any -- Note that the values are physically in reverse order

88 { _unRec :: SmallArray# Any -- Note that the values are physically in reverse order

88 }

89 }

91+data JSONOptions = JSONOptions

92+ {fieldTransform :: String -> String}

93+

94+defaultJSONOptions :: JSONOptions

95+defaultJSONOptions = JSONOptions {fieldTransform = id}

96+

90type role Rec representational

97type role Rec representational

92instance

99instance

@@ -102,16 +109,18 @@ instance RecEq lts lts => Eq (Rec lts) where

102 (==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts)

109 (==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts)

103 {-# INLINE (==) #-}

110 {-# INLINE (==) #-}

104

111

112+#ifdef WITH_AESON

105instance

113instance

106 ( RecApply lts lts ToJSON

114 ( RecApply lts lts ToJSON

107 ) =>

115 ) =>

108 ToJSON (Rec lts)

116 ToJSON (Rec lts)

109 where

117 where

110− toJSON = recToValue

118+ toJSON = recToValue defaultJSONOptions

111− toEncoding = recToEncoding

119+ toEncoding = recToEncoding defaultJSONOptions

112

120

113instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where

121instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where

114− parseJSON = recJsonParser

122+ parseJSON = recJsonParser defaultJSONOptions

123+#endif

115

124

116instance RecNfData lts lts => NFData (Rec lts) where

125instance RecNfData lts lts => NFData (Rec lts) where

117 rnf = recNfData (Proxy :: Proxy lts)

126 rnf = recNfData (Proxy :: Proxy lts)

@@ -222,7 +231,7 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where

222 )

231 )

223 KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts

232 KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts

224

233

225−type family Reverse (xs :: [*]) where

234+type family Reverse (xs :: [*]) where

226 Reverse '[] = '[]

235 Reverse '[] = '[]

227 Reverse (x ': xs) = RecAppend (Reverse xs) '[x]

236 Reverse (x ': xs) = RecAppend (Reverse xs) '[x]

228

237

@@ -430,7 +439,7 @@ union lts rts =

430{-# INLINE union #-}

439{-# INLINE union #-}

431

440

432-- | Insert a field

441-- | Insert a field

433−--

442+--

434-- Insert at beginning, unless the field already exists, in which case set it

443-- Insert at beginning, unless the field already exists, in which case set it

435-- directly.

444-- directly.

436insert ::

445insert ::

@@ -459,8 +468,6 @@ insert (l := v) rts =

459 (# s''''#, a# #) -> (# s''''#, MkRec a# #)

468 (# s''''#, a# #) -> (# s''''#, MkRec a# #)

460{-# INLINE insert #-}

469{-# INLINE insert #-}

461

470

462−

463−

464-- | Alias for 'combine'

471-- | Alias for 'combine'

465(++:) ::

472(++:) ::

466 forall lhs rhs res.

473 forall lhs rhs res.

@@ -538,16 +545,21 @@ reflectRecFold _ f r =

538showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)]

545showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)]

539showRec = reflectRec @Show Proxy (\k v -> (k, show v))

546showRec = reflectRec @Show Proxy (\k v -> (k, show v))

540

547

541−recToValue :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Value

548+recToValue :: forall lts. (RecApply lts lts ToJSON) => JSONOptions -> Rec lts -> Value

549+recToValue options r =

542−recToValue r = object $ reflectRec @ToJSON Proxy (\k v -> (T.pack k, toJSON v)) r

550+ object $ reflectRec @ToJSON Proxy (\k v -> (T.pack (fieldTransform options k), toJSON v)) r

543

551

544−recToEncoding :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Encoding

552+recToEncoding :: forall lts. (RecApply lts lts ToJSON) => JSONOptions -> Rec lts -> Encoding

553+recToEncoding options r =

545−recToEncoding r = pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack k .= v)) r

554+ pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack (fieldTransform options k) .= v)) r

546

555

556+recJsonParser ::

557+ forall lts s.

547−recJsonParser :: forall lts s. (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => Value -> Parser (Rec lts)

558+ (RecSize lts ~ s, KnownNat s, RecJsonParse lts) =>

559+ (JSONOptions -> Value -> Parser (Rec lts))

548−recJsonParser =

560+recJsonParser options =

549 withObject "Record" $ \o ->

561 withObject "Record" $ \o ->

550− recJsonParse initSize o

562+ recJsonParse options initSize o

551 where

563 where

552 initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)

564 initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)

553

565

@@ -607,10 +619,10 @@ type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where

607

619

608-- | Machinery to implement parseJSON

620-- | Machinery to implement parseJSON

609class RecJsonParse (lts :: [*]) where

621class RecJsonParse (lts :: [*]) where

610− recJsonParse :: Int -> Object -> Parser (Rec lts)

622+ recJsonParse :: JSONOptions -> Int -> Object -> Parser (Rec lts)

611

623

612instance RecJsonParse '[] where

624instance RecJsonParse '[] where

613− recJsonParse initSize _ = pure (unsafeRNil initSize)

625+ recJsonParse _ initSize _ = pure (unsafeRNil initSize)

614

626

615instance

627instance

616 ( KnownSymbol l,

628 ( KnownSymbol l,

@@ -622,13 +634,12 @@ instance

622 ) =>

634 ) =>

623 RecJsonParse (l := t ': lts)

635 RecJsonParse (l := t ': lts)

624 where

636 where

625− recJsonParse initSize obj =

637+ recJsonParse options initSize obj = do

626− do

627− let lbl :: FldProxy l

638+ let lbl :: FldProxy l

628− lbl = FldProxy

639+ lbl = FldProxy

629− rest <- recJsonParse initSize obj

640+ rest <- recJsonParse options initSize obj

630− (v :: t) <- obj .: T.pack (symbolVal lbl)

641+ (v :: t) <- obj .: T.pack (fieldTransform options (symbolVal lbl))

631− pure $ unsafeRCons (lbl := v) rest

642+ pure $ unsafeRCons (lbl := v) rest

632

643

633-- | Machinery for NFData

644-- | Machinery for NFData

634class RecNfData (lts :: [*]) (rts :: [*]) where

645class RecNfData (lts :: [*]) (rts :: [*]) where

@@ -744,7 +755,7 @@ class NoConstraint x

744instance NoConstraint x

755instance NoConstraint x

745

756

746-- | Convert a record into a list of fields.

757-- | Convert a record into a list of fields.

747−--

758+--

748-- | Not present in original superrecord

759-- | Not present in original superrecord

749getFields :: RecApply fields fields NoConstraint => Rec fields -> [Any]

760getFields :: RecApply fields fields NoConstraint => Rec fields -> [Any]

750getFields =

761getFields =