diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs index 5cd8290..1491fb3 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,24 @@ import qualified JavaScript.Object.Internal as JS import GHC.ST ( ST(..) , runST) #endif +import Data.Kind (Type) + +#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 -> T.Text +jsonKey = T.pack +#endif +{-# INLINE jsonKey #-} + + -- | Sort a list of fields using merge sort, alias to 'FieldListSort' type Sort xs = FieldListSort xs @@ -108,7 +125,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 @@ -241,7 +258,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 @@ -325,7 +342,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 @@ -335,27 +352,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 '[] = @@ -364,13 +381,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 @@ -378,11 +395,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 = @@ -501,7 +518,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 @@ -626,7 +643,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 @@ -642,7 +659,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] @@ -652,7 +669,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) @@ -696,10 +713,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 = @@ -709,7 +726,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 @@ -729,7 +746,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 ) @@ -762,17 +779,17 @@ 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 -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. @@ -818,7 +835,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 @@ -835,7 +852,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.hs b/src/SuperRecord/Variant.hs index 372d4ef..6648138 100644 --- a/src/SuperRecord/Variant.hs +++ b/src/SuperRecord/Variant.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,16 +21,17 @@ where import Control.Applicative import Control.DeepSeq import Data.Aeson -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Parser, parseFail) import Data.Maybe import Data.Proxy +import Data.Kind (Type) import GHC.Base (Any) import GHC.TypeLits import Unsafe.Coerce -- | A variant is used to express that a values type is of any of -- the types tracked in the type level list. -data Variant (opts :: [*]) +data Variant (opts :: [Type]) = Variant {-# UNPACK #-} !Word Any type role Variant representational @@ -53,9 +55,8 @@ instance (ToJSON t, ToJSON (Variant ts)) => ToJSON (Variant (t ': ts)) where in fromMaybe (toJSON $ shrinkVariant v1) $ toJSON <$> w1 instance FromJSON (Variant '[]) where - parseJSON r = - do () <- parseJSON r - pure emptyVariant + parseJSON _ = + parseFail "There is no JSON value devoid of a value, so no way to represent an emptyVariant" instance ( FromJSON t, FromJSON (Variant ts) ) => FromJSON (Variant (t ': ts)) where diff --git a/src/SuperRecord/Variant/Tagged.hs b/src/SuperRecord/Variant/Tagged.hs index ba47fe4..34e9ef2 100644 --- a/src/SuperRecord/Variant/Tagged.hs +++ b/src/SuperRecord/Variant/Tagged.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,10 +21,24 @@ import SuperRecord.Variant import Control.Applicative import Data.Aeson -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Parser, parseFail) 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 -> T.Text +jsonKey = T.pack +#endif +{-# INLINE jsonKey #-} -- | Just a type alias vor 'Variant' type TaggedVariant opts = Variant opts @@ -40,22 +56,21 @@ 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 in val instance FromJSON (JsonTaggedVariant '[]) where - parseJSON r = - do () <- parseJSON r - pure $ JsonTaggedVariant emptyVariant + parseJSON _ = + parseFail "There is no JSON value devoid of a value, so no way to represent an emptyVariant" 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))