From c00e933f582e3fb8d209f6cece91d464faf09082 Mon Sep 17 00:00:00 2001 From: Philip Patsch Date: Wed, 18 May 2022 12:58:31 +0200 Subject: [PATCH 1/2] Make compatible with aeson >2.0 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds a bit more ifdef zoo to be compatible with the breaking change in aeson. Tested manually against GHC 8.10.7 and GHC 9.0.2. Might want to update the CI as well, but I don’t have the time to touch CircleCI yaml. --- src/SuperRecord.hs | 25 ++++++++++++++++++++----- src/SuperRecord/Variant/Tagged.hs | 19 +++++++++++++++++-- 2 files changed, 37 insertions(+), 7 deletions(-) diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs index 5cd8290..f43ecea 100644 --- a/src/SuperRecord.hs +++ b/src/SuperRecord.hs @@ -86,7 +86,6 @@ import GHC.Generics import GHC.Exts import GHC.TypeLits import qualified Control.Monad.State as S -import qualified Data.Text as T import Data.Semigroup as Sem (Semigroup(..)) #ifdef JS_RECORD @@ -98,6 +97,22 @@ import qualified JavaScript.Object.Internal as JS import GHC.ST ( ST(..) , runST) #endif +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#else +import qualified Data.Text as T +#endif + +#if MIN_VERSION_aeson(2, 0, 0) +jsonKey :: String -> Key.Key +jsonKey = Key.fromString +#else +jsonKey :: String -> Text +jsonKey = T.pack +#endif +{-# INLINE jsonKey #-} + + -- | Sort a list of fields using merge sort, alias to 'FieldListSort' type Sort xs = FieldListSort xs @@ -696,10 +711,10 @@ showRec :: forall lts. (RecApply lts lts (ConstC Show)) => Rec lts -> [(String, showRec = reflectRec @(ConstC Show) (\(_ :: FldProxy lbl) v -> (symbolVal' (proxy# :: Proxy# lbl), show v)) recToValue :: forall lts. (RecApply lts lts (ConstC ToJSON)) => Rec lts -> Value -recToValue r = object $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (T.pack $ symbolVal' (proxy# :: Proxy# lbl), toJSON v)) r +recToValue r = object $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (jsonKey $ symbolVal' (proxy# :: Proxy# lbl), toJSON v)) r recToEncoding :: forall lts. (RecApply lts lts (ConstC ToJSON)) => Rec lts -> Encoding -recToEncoding r = pairs $ mconcat $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (T.pack (symbolVal' (proxy# :: Proxy# lbl)) .= v)) r +recToEncoding r = pairs $ mconcat $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (jsonKey (symbolVal' (proxy# :: Proxy# lbl))) .= v) r recJsonParser :: forall lts s. (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => Value -> Parser (Rec lts) recJsonParser = @@ -762,7 +777,7 @@ instance TraversalCHelper bs as bs c => TraversalC c as bs where -- -- Effects are performed in the same order as the fields. traverseC :: - forall c f as bs. ( TraversalC c as bs, Applicative f ) => + forall c f as bs. ( TraversalC c as bs, Applicative f ) => ( forall (l :: Symbol) a b. (KnownSymbol l, c l a b) => FldProxy l -> a -> f b ) -> Rec as -> f ( Rec bs ) traverseC = traversalCHelper @bs @as @bs @c @f @@ -835,7 +850,7 @@ instance do let lbl :: FldProxy l lbl = FldProxy rest <- recJsonParse initSize obj - (v :: t) <- obj .: T.pack (symbolVal lbl) + (v :: t) <- obj .: jsonKey (symbolVal lbl) pure $ unsafeRCons (lbl := v) rest -- | Conversion helper to bring a Haskell type to a record. Note that the diff --git a/src/SuperRecord/Variant/Tagged.hs b/src/SuperRecord/Variant/Tagged.hs index ba47fe4..e2a0673 100644 --- a/src/SuperRecord/Variant/Tagged.hs +++ b/src/SuperRecord/Variant/Tagged.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -22,7 +23,21 @@ import Data.Aeson import Data.Aeson.Types (Parser) import Data.Maybe import GHC.TypeLits + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#else import qualified Data.Text as T +#endif + +#if MIN_VERSION_aeson(2, 0, 0) +jsonKey :: String -> Key.Key +jsonKey = Key.fromString +#else +jsonKey :: String -> Text +jsonKey = T.pack +#endif +{-# INLINE jsonKey #-} -- | Just a type alias vor 'Variant' type TaggedVariant opts = Variant opts @@ -40,7 +55,7 @@ instance (KnownSymbol lbl, ToJSON t, ToJSON (JsonTaggedVariant ts)) => ToJSON (J toJSON (JsonTaggedVariant v1) = let w1 :: Maybe t w1 = fromTaggedVariant (FldProxy :: FldProxy lbl) v1 - tag = T.pack $ symbolVal (FldProxy :: FldProxy lbl) + tag = jsonKey $ symbolVal (FldProxy :: FldProxy lbl) in let val = fromMaybe (toJSON $ JsonTaggedVariant $ shrinkVariant v1) $ (\x -> object [tag .= x]) <$> w1 @@ -55,7 +70,7 @@ instance ( FromJSON t, FromJSON (JsonTaggedVariant ts) , KnownSymbol lbl ) => FromJSON (JsonTaggedVariant (lbl := t ': ts)) where parseJSON r = - do let tag = T.pack $ symbolVal (FldProxy :: FldProxy lbl) + do let tag = jsonKey $ symbolVal (FldProxy :: FldProxy lbl) myParser :: Parser t myParser = withObject ("Tagged " ++ show tag) (\o -> o .: tag) r myPackedParser :: Parser (JsonTaggedVariant (lbl := t ': ts)) From 6997b1427045d31994ee2e49a796170d8094a3f4 Mon Sep 17 00:00:00 2001 From: Philip Patsch Date: Wed, 18 May 2022 13:05:19 +0200 Subject: [PATCH 2/2] Use Data.Kind.Type instead of the * syntax GHC 9 warns that `*` will be removed soon. Tested against 8.10.7 and 9, might not work with some old `base` versions. --- src/SuperRecord.hs | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs index f43ecea..814005c 100644 --- a/src/SuperRecord.hs +++ b/src/SuperRecord.hs @@ -99,6 +99,7 @@ import GHC.ST ( ST(..) , runST) #if MIN_VERSION_aeson(2, 0, 0) import qualified Data.Aeson.Key as Key +import Data.Kind (Type) #else import qualified Data.Text as T #endif @@ -123,7 +124,7 @@ type Record lts = Rec (Sort lts) -- | Internal record type. When manually writing an explicit type signature for -- a record, use 'Record' instead. For abstract type signatures 'Rec' will work -- well. -data Rec (lts :: [*]) +data Rec (lts :: [Type]) = Rec { #ifndef JS_RECORD @@ -256,7 +257,7 @@ rcons (lbl := val) (Rec obj) = infixr 5 `rcons` -class RecCopy (pts :: [*]) (lts :: [*]) (rts :: [*]) where +class RecCopy (pts :: [Type]) (lts :: [Type]) (rts :: [Type]) where recCopyInto :: Proxy pts -> Rec lts -> Proxy rts -> SmallMutableArray# s Any @@ -340,7 +341,7 @@ type family RecAll (c :: u -> Constraint) (rs :: [u]) :: Constraint where RecAll c '[] = () RecAll c (r ': rs) = (c r, RecAll c rs) -type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where +type family KeyDoesNotExist (l :: Symbol) (lts :: [Type]) :: Constraint where KeyDoesNotExist l '[] = 'True ~ 'True KeyDoesNotExist l (l := t ': lts) = TypeError @@ -350,27 +351,27 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where type RecAppend lhs rhs = RecAppendH lhs rhs rhs '[] -type family ListConcat (xs :: [*]) (ys :: [*]) :: [*] where +type family ListConcat (xs :: [Type]) (ys :: [Type]) :: [Type] where ListConcat '[] ys = ys ListConcat xs '[] = xs ListConcat (x ': xs) ys = x ': (ListConcat xs ys) -type family ListReverse (xs :: [*]) :: [*] where +type family ListReverse (xs :: [Type]) :: [Type] where ListReverse (x ': xs) = ListConcat (ListReverse xs) '[x] ListReverse '[] = '[] -type family RecAppendH (lhs ::[*]) (rhs :: [*]) (rhsall :: [*]) (accum :: [*]) :: [*] where +type family RecAppendH (lhs ::[Type]) (rhs :: [Type]) (rhsall :: [Type]) (accum :: [Type]) :: [Type] where RecAppendH (l := t ': lhs) (m := u ': rhs) rhsall acc = RecAppendH (l := t ': lhs) rhs rhsall acc RecAppendH (l := t ': lhs) '[] rhsall acc = RecAppendH lhs rhsall rhsall (l := t ': acc) RecAppendH '[] rhs rhsall acc = ListConcat (ListReverse acc) rhsall -type family RecSize (lts :: [*]) :: Nat where +type family RecSize (lts :: [Type]) :: Nat where RecSize '[] = 0 RecSize (l := t ': lts) = 1 + RecSize lts type RecVecIdxPos l lts = RecSize lts - RecTyIdxH 0 l lts - 1 -type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [*]) :: Nat where +type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [Type]) :: Nat where RecTyIdxH idx l (l := t ': lts) = idx RecTyIdxH idx m (l := t ': lts) = RecTyIdxH (1 + idx) m lts RecTyIdxH idx m '[] = @@ -379,13 +380,13 @@ type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [*]) :: Nat where ':<>: 'Text m ) -type family RecTy (l :: Symbol) (lts :: [*]) :: Maybe * where +type family RecTy (l :: Symbol) (lts :: [Type]) :: Maybe Type where RecTy l '[] = 'Nothing RecTy l (l := t ': lts) = 'Just t RecTy q (l := t ': lts) = RecTy q lts -- | Require a record to contain at least the listed labels -type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where +type family HasOf (req :: [Type]) (lts :: [Type]) :: Constraint where HasOf (l := t ': req) lts = (Has lts l t, HasOf req lts) HasOf '[] lts = 'True ~ 'True @@ -393,11 +394,11 @@ type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where -- -- Retains the order of fields in the *first* argument. -- Throw a type error if a label is associated with distinct types in each of the arguments. -type family Intersect (as :: [*]) (bs :: [*]) :: [*] where +type family Intersect (as :: [Type]) (bs :: [Type]) :: [Type] where Intersect '[] _ = '[] Intersect (k := a ': as) bs = IntersectHelper (RecTy k bs) k a as bs -type family IntersectHelper (lk :: Maybe *) (k :: Symbol) (a :: *) (as :: [*]) (bs :: [*]) :: [*] where +type family IntersectHelper (lk :: Maybe Type) (k :: Symbol) (a :: Type) (as :: [Type]) (bs :: [Type]) :: [Type] where IntersectHelper 'Nothing _ _ as bs = Intersect as bs IntersectHelper ( 'Just a ) k a as bs = ( k := a ) ': Intersect as bs IntersectHelper ( 'Just b ) k a _ bs = @@ -516,7 +517,7 @@ infixr 8 &:- fld :: FldProxy l -> FldProxy l fld = id -type family RecDeepTy (ps :: r) (lts :: [*]) :: * where +type family RecDeepTy (ps :: r) (lts :: [Type]) :: Type where RecDeepTy (l :& more) (l := Rec t ': lts) = RecDeepTy more t RecDeepTy (l :& more) (l := t ': lts) = t RecDeepTy (l :& more) (q := t ': lts) = RecDeepTy (l :& more) lts @@ -641,7 +642,7 @@ inject small class (a ~ b, Lookup kvs k a (RecTy k kvs)) => Inject kvs k a b where instance (a ~ b, Lookup kvs k a (RecTy k kvs)) => Inject kvs k a b where -class ( r ~ RecTy k kvs ) => Lookup (kvs :: [*]) (k :: Symbol) (a :: *) (r :: Maybe *) where +class ( r ~ RecTy k kvs ) => Lookup (kvs :: [Type]) (k :: Symbol) (a :: Type) (r :: Maybe Type) where lookupWithDefault :: FldProxy k -> a -> Rec kvs -> a instance (RecTy k kvs ~ 'Nothing) => Lookup kvs k a 'Nothing @@ -657,7 +658,7 @@ data RecFields (flds :: [Symbol]) where RFNil :: RecFields '[] RFCons :: KnownSymbol f => FldProxy f -> RecFields xs -> RecFields (f ': xs) -recKeys :: forall t (lts :: [*]). RecKeys lts => t lts -> [String] +recKeys :: forall t (lts :: [Type]). RecKeys lts => t lts -> [String] recKeys = recKeys' . recFields recKeys' :: RecFields lts -> [String] @@ -667,7 +668,7 @@ recKeys' x = RFCons q qs -> symbolVal q : recKeys' qs -- | Get keys of a record on value and type level -class RecKeys (lts :: [*]) where +class RecKeys (lts :: [Type]) where type RecKeysT lts :: [Symbol] recFields :: t lts -> RecFields (RecKeysT lts) @@ -724,7 +725,7 @@ recJsonParser = initSize = fromIntegral $ natVal' (proxy# :: Proxy# s) -- | Machinery needed to implement 'reflectRec' -class RecApply (rts :: [*]) (lts :: [*]) c where +class RecApply (rts :: [Type]) (lts :: [Type]) c where recApply :: (forall (l :: Symbol) a. (KnownSymbol l, c l a) => FldProxy l -> a -> b -> b) -> Rec rts -> b -> b instance RecApply rts '[] c where @@ -744,7 +745,7 @@ instance in recApply @rts @(RemoveAccessTo l lts) @c f r res -class ( KnownNat ( RecSize bs ) ) => TraversalCHelper (bs_acc ::[*]) (as :: [*]) (bs :: [*]) c where +class ( KnownNat ( RecSize bs ) ) => TraversalCHelper (bs_acc ::[Type]) (as :: [Type]) (bs :: [Type]) c where traversalCHelper :: forall f. Applicative f => ( forall (l :: Symbol) a b. (KnownSymbol l, c l a b) => FldProxy l -> a -> f b ) -> Rec as -> f ( Rec bs_acc ) instance ( RecSize bs ~ s, KnownNat s ) @@ -782,12 +783,12 @@ traverseC :: traverseC = traversalCHelper @bs @as @bs @c @f -type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where +type family RemoveAccessTo (l :: Symbol) (lts :: [Type]) :: [Type] where RemoveAccessTo l (l := t ': lts) = RemoveAccessTo l lts RemoveAccessTo q (l := t ': lts) = (l := t ': RemoveAccessTo l lts) RemoveAccessTo q '[] = '[] -class UnsafeRecBuild (rts :: [*]) (lts :: [*]) c where +class UnsafeRecBuild (rts :: [Type]) (lts :: [Type]) c where -- | Build a record from a constrained applicative function. -- -- Effects are performed in order of the given (potentially unsorted) fields. @@ -833,7 +834,7 @@ recBuildPure f = runIdentity $ recBuild @c @Identity @lts @sortedLts ( \ k v -> -- | Machinery to implement parseJSON -class RecJsonParse (lts :: [*]) where +class RecJsonParse (lts :: [Type]) where recJsonParse :: Int -> Object -> Parser (Rec lts) instance RecJsonParse '[] where