diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -94,14 +94,15 @@ , bench "native" $ nf n_f2 r1N ] , bgroup "get nested" - [ bench "superrecord" $ nf (get #f41 . get #f4) r1 + [ bench "superrecord get" $ nf (get #f41 . get #f4) r1 + , bench "superrecord getPath" $ nf (getPath (#f4 &:- #f41)) r1 , bench "labels" $ nf (L.get #f41 . L.get #f4) r1L , bench "bookkeeper" $ nf (\r -> r B.?: #f4 B.?: #f41) r1B , bench "native" $ nf (n_f41 . n_f4) r1N ] , bgroup "set nested" [ bench "superrecord" $ - nf (\r -> (setPath (#f4 &: #f41 &: snil) "Hello" r) &. #f4 &. #f41) r1 + nf (\r -> (setPath (#f4 &:- #f41) "Hello" r) &. #f4 &. #f41) r1 , bench "labels" $ nf (\r -> L.get #f41 . L.get #f4 $ L.modify #f4 (L.set #f41 "Hello") r) r1L , bench "bookkeeper" $ @@ -118,6 +119,9 @@ , bgroup "set rec" [ bench "superrecord" $ nf (set #f2 123) r1 , bench "native" $ nf (\r -> r { n_f2 = 123 }) r1N + ] + , bgroup "combine rec" + [ bench "superrecord" $ nf (\r -> r ++: (#foo := True & rnil)) r1 ] , bgroup "json" [ bench "superrecord" $ nf @[Rec Ex1] (throwOnNone . decode' . encode) $ replicate 50 r1 diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs --- a/src/SuperRecord.hs +++ b/src/SuperRecord.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-} @@ -15,18 +16,32 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} module SuperRecord ( -- * Basics (:=)(..) , Rec, rnil, rcons, (&) - , Has + , fld + , Has, HasOf , get, (&.) - , set, SetPath(..), SPath(..), (&:), snil + , set + , modify + , getPath, setPath, modifyPath, RecApplyPath, (:&), (&:), (&:-) + , combine, (++:), RecAppend -- * Reflection , reflectRec, RecApply(..) + -- * Native type interop + , FromNative, fromNative + , ToNative, toNative + -- * MTL interop + , asksR, asksRP + , getsR, setsR, modifiesR + , getsRP, setsRP, modifiesRP + -- * Lens interop + , lens -- * Machinery - , RecTyIdxH, RecIdxTyH + , RecTyIdxH , showRec, RecKeys(..) , RecEq(..) , recToValue, recToEncoding @@ -39,16 +54,20 @@ where import Control.DeepSeq +import Control.Monad.Reader import Data.Aeson import Data.Aeson.Types (Parser) import Data.Constraint import Data.Proxy import Data.Typeable +import GHC.Base (Int(..)) +import GHC.Generics +import GHC.IO ( IO(..) ) import GHC.OverloadedLabels import GHC.Prim import GHC.TypeLits import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Primitive.Array as A +import qualified Control.Monad.State as S import qualified Data.Text as T -- | Field named @l@ labels value of type @t@ adapted from the awesome /labels/ package. @@ -81,8 +100,8 @@ fromLabel _ = FldProxy -- | The core record type. -newtype Rec (lts :: [*]) - = Rec { _unRec :: (A.Array Any) } +data Rec (lts :: [*]) + = Rec { _unRec :: SmallArray# Any } -- Note that the values are physically in reverse order instance (RecApply lts lts Show) => Show (Rec lts) where show = show . showRec @@ -108,10 +127,18 @@ rnil = unsafeRnil 0 {-# INLINE rnil #-} +-- newByteArray# :: Int# -> State# s -> (#State# s, MutableByteArray# s#) + -- | An empty record with an initial size for the record unsafeRnil :: Int -> Rec '[] -unsafeRnil initSize = - Rec $ unsafePerformIO (A.newArray initSize (error "No Value") >>= A.unsafeFreezeArray) +unsafeRnil (I# n#) = + unsafePerformIO $! IO $ \s# -> + case newSmallArray# n# (error "No Value") s# of + (# s'#, arr# #) -> + case unsafeFreezeSmallArray# arr# s'# of + (# s''#, a# #) -> (# s''# , Rec a# #) + + -- (A.newArray initSize (error "No Value") >>= A.unsafeFreezeArray) {-# INLINE unsafeRnil #-} -- | Prepend a record entry to a record 'Rec' @@ -119,14 +146,19 @@ forall l t lts s. (RecSize lts ~ s, KnownNat s, KeyDoesNotExist l lts) => l := t -> Rec lts -> Rec (l := t ': lts) -rcons (_ := val) (Rec vec) = - Rec $ - unsafePerformIO $! - do m2 <- A.newArray (size + 1) (error "No Value") - A.copyArray m2 0 vec 0 size - A.writeArray m2 size (unsafeCoerce# val) - A.unsafeFreezeArray m2 +rcons (_ := val) (Rec vec#) = + unsafePerformIO $! IO $ \s# -> + case newSmallArray# newSize# (error "No value") s# of + (# s'#, arr# #) -> + case copySmallArray# vec# 0# arr# 0# size# s'# of + s''# -> + case writeSmallArray# arr# size# (unsafeCoerce# val) s''# of + s'''# -> + case unsafeFreezeSmallArray# arr# s'''# of + (# s''''#, a# #) -> (# s''''#, Rec a# #) where + !(I# newSize#) = size + 1 + !(I# size#) = size size = fromIntegral $ natVal' (proxy# :: Proxy# s) {-# INLINE rcons #-} @@ -137,14 +169,16 @@ forall l t lts s. (RecSize lts ~ s, KnownNat s, KeyDoesNotExist l lts) => l := t -> Rec lts -> Rec (l := t ': lts) -unsafeRCons (_ := val) (Rec vec) = - Rec $ - unsafePerformIO $! - do m2 <- A.unsafeThawArray vec - A.writeArray m2 size (unsafeCoerce# val) - A.unsafeFreezeArray m2 +unsafeRCons (_ := val) (Rec vec#) = + unsafePerformIO $! IO $ \s# -> + case unsafeThawSmallArray# vec# s# of + (# s'#, arr# #) -> + case writeSmallArray# arr# size# (unsafeCoerce# val) s'# of + s''# -> + case unsafeFreezeSmallArray# arr# s''# of + (# s'''#, a# #) -> (# s'''#, Rec a# #) where - size = fromIntegral $ natVal' (proxy# :: Proxy# s) + !(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# s) {-# INLINE unsafeRCons #-} -- | Alias for 'rcons' @@ -165,10 +199,28 @@ ) KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts +type RecAppend lhs rhs = RecAppendH lhs rhs rhs '[] + +type family ListConcat (xs :: [*]) (ys :: [*]) :: [*] where + ListConcat '[] ys = ys + ListConcat xs '[] = xs + ListConcat (x ': xs) ys = x ': (ListConcat xs ys) + +type family ListReverse (xs :: [*]) :: [*] where + ListReverse (x ': xs) = ListConcat (ListReverse xs) '[x] + ListReverse '[] = '[] + +type family RecAppendH (lhs ::[*]) (rhs :: [*]) (rhsall :: [*]) (accum :: [*]) :: [*] 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 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 RecTyIdxH idx l (l := t ': lts) = idx RecTyIdxH idx m (l := t ': lts) = RecTyIdxH (1 + idx) m lts @@ -178,98 +230,183 @@ ':<>: 'Text m ) -type family RecIdxTyH (i :: Nat) (r :: Nat) (lts :: [*]) :: * where - RecIdxTyH idx idx (l := t ': lts) = t - RecIdxTyH idx other (l := t ': lts) = RecIdxTyH idx (other + 1) lts - RecIdxTyH idx other '[] = - TypeError ('Text "Could not find index " ':<>: 'ShowType idx) +type family RecTy (l :: Symbol) (lts :: [*]) :: k where + RecTy l (l := t ': lts) = t + RecTy q (l := t ': lts) = RecTy q lts --- | State that a record contains a label. Leave idx an s free variables, used internally -type Has l lts idx s v = - ( RecTyIdxH 0 l lts ~ idx - , RecIdxTyH idx 0 lts ~ v - , KnownNat idx - , RecSize lts ~ s, KnownNat s +-- | Require a record to contain at least the listed labels +type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where + HasOf (l := t ': req) lts = (Has l lts t, HasOf req lts) + HasOf '[] lts = 'True ~ 'True + +-- | Require a record to contain a label +type Has l lts v = + ( RecTy l lts ~ v + , KnownNat (RecSize lts) + , KnownNat (RecVecIdxPos l lts) ) -- | Get an existing record field -get :: forall l v lts idx s. (Has l lts idx s v) => FldProxy l -> Rec lts -> v -get _ (Rec vec) = - let !size = fromIntegral $ natVal' (proxy# :: Proxy# s) - !readAt = size - fromIntegral (natVal' (proxy# :: Proxy# idx)) - 1 +get :: + forall l v lts. + ( Has l lts v ) + => FldProxy l -> Rec lts -> v +get _ (Rec vec#) = + let !(I# readAt#) = + fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l lts))) anyVal :: Any - anyVal = A.indexArray vec readAt + anyVal = + case indexSmallArray# vec# readAt# of + (# a# #) -> a# in unsafeCoerce# anyVal {-# INLINE get #-} -- | Alias for 'get' -(&.) :: forall l v lts idx s. (Has l lts idx s v) => Rec lts -> FldProxy l -> v +(&.) :: forall l v lts. (Has l lts v) => Rec lts -> FldProxy l -> v (&.) = flip get infixl 3 &. -- | Update an existing record field set :: - forall l v lts idx s. - (Has l lts idx s v) + forall l v lts. + (Has l lts v) => FldProxy l -> v -> Rec lts -> Rec lts -set _ !val (Rec vec) = - let !size = fromIntegral $ natVal' (proxy# :: Proxy# s) - !setAt = size - fromIntegral (natVal' (proxy# :: Proxy# idx)) - 1 - dynVal = unsafeCoerce# val +set _ !val (Rec vec#) = + let !(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# (RecSize lts)) + !(I# setAt#) = fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l lts))) + dynVal :: Any + !dynVal = unsafeCoerce# val r2 = - unsafePerformIO $! - do m2 <- A.newArray size (error "No Value") - A.copyArray m2 0 vec 0 size - A.writeArray m2 setAt dynVal - Rec <$> A.unsafeFreezeArray m2 + unsafePerformIO $! IO $ \s# -> + case newSmallArray# size# (error "No value") s# of + (# s'#, arr# #) -> + case copySmallArray# vec# 0# arr# 0# size# s'# of + s''# -> + case writeSmallArray# arr# setAt# dynVal s''# of + s'''# -> + case unsafeFreezeSmallArray# arr# s'''# of + (# s''''#, a# #) -> (# s''''#, Rec a# #) in r2 {-# INLINE set #-} --- | Path to the key that should be updated -data SPath (t :: [Symbol]) where - SCons :: FldProxy l -> SPath ls -> SPath (l ': ls) - SNil :: SPath '[] +-- | Update an existing record field +modify :: + forall l v lts. + (Has l lts v) + => FldProxy l -> (v -> v) -> Rec lts -> Rec lts +modify lbl fun r = set lbl (fun $ get lbl r) r +{-# INLINE modify #-} --- | Alias for 'SNil' -snil :: SPath '[] -snil = SNil +-- | Constructor for field accessor paths +data lbl :& more = FldProxy lbl :& more +infixr 8 :& -{-# INLINE snil #-} +-- | Constructor for field accessor paths +(&:) :: FldProxy q -> more -> q :& more +(&:) = (:&) +{-# INLINE (&:) #-} --- | Alias for 'SCons' -(&:) :: FldProxy l -> SPath ls -> SPath (l ': ls) -(&:) = SCons infixr 8 &: -{-# INLINE (&:) #-} +-- | Specialized version of (&:) to help writing the last piece of the path w/o +-- confusing the type checker +(&:-) :: FldProxy q -> FldProxy r -> q :& FldProxy r +(&:-) = (:&) +{-# INLINE (&:-) #-} -type family RecDeepTy (ls :: [Symbol]) (lts :: k) :: * where - RecDeepTy (l ': more) (Rec q) = RecDeepTy (l ': more) q - 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 - RecDeepTy '[] v = v +infixr 8 &:- -class SetPath k x where +-- | Helper function to allow to clearing specify unknown 'IsLabel' cases +fld :: FldProxy l -> FldProxy l +fld = id + +type family RecDeepTy (ps :: r) (lts :: [*]) :: * 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 + RecDeepTy (FldProxy l) '[l := t] = t + RecDeepTy l '[l := t] = t + +class RecApplyPath p x where -- | Perform a deep update, setting the key along the path to the -- desired value - setPath :: SPath k -> RecDeepTy k x -> x -> x + setPath' :: p -> (RecDeepTy p x -> RecDeepTy p x) -> Rec x -> Rec x -instance SetPath '[] v where - setPath _ v _ = v - {-# INLINE setPath #-} + -- | Perform a deep read + getPath' :: p -> Rec x -> RecDeepTy p x +instance (Has l lts t, t ~ RecDeepTy (FldProxy l) lts) => RecApplyPath (FldProxy l) lts where + setPath' = modify + {-# INLINE setPath' #-} + + getPath' = get + {-# INLINE getPath' #-} + instance - ( SetPath more v - , Has l lts idx s v - , RecDeepTy (l ': more) (Rec lts) ~ RecDeepTy more v - ) => SetPath (l ': more) (Rec lts) - where - setPath (SCons k more) v r = - let innerVal = get k r - in set k (setPath more v innerVal) r - {-# INLINE setPath #-} + ( RecDeepTy (l :& more) lts ~ RecDeepTy more rts + , RecTy l lts ~ Rec rts + , Has l lts v + , v ~ Rec rts + , RecApplyPath more rts + ) => RecApplyPath (l :& more) lts where + setPath' (x :& more) v r = + let innerVal :: Rec rts + innerVal = get x r + in set x (setPath' more v innerVal) r + {-# INLINE setPath' #-} + getPath' (x :& more) r = getPath' more (get x r) + {-# INLINE getPath' #-} + +-- | Perform a deep update, setting the key along the path to the +-- desired value +setPath :: RecApplyPath k x => k -> RecDeepTy k x -> Rec x -> Rec x +setPath s v = setPath' s (const v) +{-# INLINE setPath #-} + +-- | Perform a deep update, transforming the value at the final key +modifyPath :: RecApplyPath k x => k -> (RecDeepTy k x -> RecDeepTy k x) -> Rec x -> Rec x +modifyPath = setPath' +{-# INLINE modifyPath #-} + +-- | Perform a deep read. This is somewhat similar to using (&.), but is useful +-- when you want to share a 'RecPath' between 'getPath', 'modifyPath' and/or 'setPath' +getPath :: RecApplyPath k x => k -> Rec x -> RecDeepTy k x +getPath = getPath' +{-# INLINE getPath #-} + +-- | Combine two records +combine :: + forall lhs rhs. + (KnownNat (RecSize lhs), KnownNat (RecSize rhs), KnownNat (RecSize lhs + RecSize rhs)) + => Rec lhs + -> Rec rhs + -> Rec (RecAppend lhs rhs) +combine (Rec l#) (Rec r#) = + let !(I# sizeL#) = fromIntegral $ natVal' (proxy# :: Proxy# (RecSize lhs)) + !(I# sizeR#) = fromIntegral $ natVal' (proxy# :: Proxy# (RecSize rhs)) + !(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# (RecSize lhs + RecSize rhs)) + in unsafePerformIO $! IO $ \s# -> + case newSmallArray# size# (error "No value") s# of + (# s'#, arr# #) -> + case copySmallArray# r# 0# arr# 0# sizeR# s'# of + s''# -> + case copySmallArray# l# 0# arr# sizeR# sizeL# s''# of + s'''# -> + case unsafeFreezeSmallArray# arr# s'''# of + (# s''''#, a# #) -> (# s''''#, Rec a# #) +{-# INLINE combine #-} + +-- | Alias for 'combine' +(++:) :: + forall lhs rhs. + (KnownNat (RecSize lhs), KnownNat (RecSize rhs), KnownNat (RecSize lhs + RecSize rhs)) + => Rec lhs + -> Rec rhs + -> Rec (RecAppend lhs rhs) +(++:) = combine +{-# INLINE (++:) #-} + -- | Get keys of a record on value and type level class RecKeys (lts :: [*]) where type RecKeysT lts :: [Symbol] @@ -326,7 +463,7 @@ instance ( KnownSymbol l , RecApply rts (RemoveAccessTo l lts) c - , Has l rts idx s v + , Has l rts v , c v ) => RecApply rts (l := t ': lts) c where recApply f r (_ :: Proxy (l := t ': lts)) = @@ -347,7 +484,7 @@ instance ( RecEq rts (RemoveAccessTo l lts) - , Has l rts idx s v + , Has l rts v , Eq v ) => RecEq rts (l := t ': lts) where recEq r1 r2 (_ :: Proxy (l := t ': lts)) = @@ -391,7 +528,7 @@ recNfData _ _ = () instance - ( Has l rts idx s v + ( Has l rts v , NFData v , RecNfData (RemoveAccessTo l lts) rts ) => RecNfData (l := t ': lts) rts where @@ -400,3 +537,118 @@ pNext :: Proxy (RemoveAccessTo l (l := t ': lts)) pNext = Proxy in deepseq v (recNfData pNext r) + +-- | Conversion helper to bring a Haskell type to a record. Note that the +-- native Haskell type must be an instance of 'Generic' +class FromNative a lts | a -> lts where + fromNative' :: a x -> Rec lts + +instance FromNative cs lts => FromNative (D1 m cs) lts where + fromNative' (M1 xs) = fromNative' xs + +instance FromNative cs lts => FromNative (C1 m cs) lts where + fromNative' (M1 xs) = fromNative' xs + +instance + KnownSymbol name + => FromNative (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) '[name := t] + where + fromNative' (M1 (K1 t)) = (FldProxy :: FldProxy name) := t & rnil + +instance + ( FromNative l lhs + , FromNative r rhs + , lts ~ RecAppend lhs rhs + , KnownNat (RecSize lhs) + , KnownNat (RecSize rhs) + , KnownNat (RecSize lhs + RecSize rhs) + ) + => FromNative (l :*: r) lts where + fromNative' (l :*: r) = fromNative' l ++: fromNative' r + +-- | Convert a native Haskell type to a record +fromNative :: (Generic a, FromNative (Rep a) lts) => a -> Rec lts +fromNative = fromNative' . from +{-# INLINE fromNative #-} + +-- | Conversion helper to bring a record back into a Haskell type. Note that the +-- native Haskell type must be an instance of 'Generic' +class ToNative a lts | a -> lts where + toNative' :: Rec lts -> a x + +instance ToNative cs lts => ToNative (D1 m cs) lts where + toNative' xs = M1 $ toNative' xs + +instance ToNative cs lts => ToNative (C1 m cs) lts where + toNative' xs = M1 $ toNative' xs + +instance + (Has name lts t) + => ToNative (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) lts + where + toNative' r = + M1 $ K1 (get (FldProxy :: FldProxy name) r) + +instance + ( ToNative l lts + , ToNative r lts + ) + => ToNative (l :*: r) lts where + toNative' r = toNative' r :*: toNative' r + +-- | Convert a record to a native Haskell type +toNative :: (Generic a, ToNative (Rep a) lts) => Rec lts -> a +toNative = to . toNative' +{-# INLINE toNative #-} + +-- | Like 'asks' for 'MonadReader', but you provide a record field you would like +-- to read from your environment +asksR :: (Has lbl lts v, MonadReader (Rec lts) m) => FldProxy lbl -> m v +asksR f = asks (get f) +{-# INLINE asksR #-} + +-- | Like 'asks' for 'MonadReader', but you provide a record field you would like +-- to read from your environment +asksRP :: (RecApplyPath k x, MonadReader (Rec x) m) => k -> m (RecDeepTy k x) +asksRP p = asks (getPath p) +{-# INLINE asksRP #-} + +-- | Like 'gets' for 'MonadState', but you provide a record field you would like +-- to read from your environment +getsR :: (Has lbl lts v, S.MonadState (Rec lts) m) => FldProxy lbl -> m v +getsR f = S.gets (get f) +{-# INLINE getsR #-} + +-- | Similar to 'put' for 'MonadState', but you only set a single record field +setsR :: (Has lbl lts v, S.MonadState (Rec lts) m) => FldProxy lbl -> v -> m () +setsR f v = S.modify (set f v) +{-# INLINE setsR #-} + +-- | Similar to 'modify' for 'MonadState', but you update a single record field +modifiesR :: (Has lbl lts v, S.MonadState (Rec lts) m) => FldProxy lbl -> (v -> v) -> m () +modifiesR f go = S.modify (modify f go) +{-# INLINE modifiesR #-} + +-- | Similar to 'gets' for 'MonadState', but allows getting a value along a 'RecPath' +getsRP :: (RecApplyPath k x, S.MonadState (Rec x) m) => k -> m (RecDeepTy k x) +getsRP p = S.gets (getPath p) +{-# INLINE getsRP #-} + +-- | Similar to 'put' for 'MonadState', but you only set a single record field +setsRP :: (RecApplyPath k x, S.MonadState (Rec x) m) => k -> RecDeepTy k x -> m () +setsRP p v = S.modify (setPath p v) +{-# INLINE setsRP #-} + +-- | Similar to 'modify' for 'MonadState', but you update a single record field +modifiesRP ::(RecApplyPath k x, S.MonadState (Rec x) m) => k -> (RecDeepTy k x -> RecDeepTy k x) -> m () +modifiesRP p go = S.modify (modifyPath p go) +{-# INLINE modifiesRP #-} + +type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t) + +-- | Convert a field label to a lens +lens :: + Has l lts v => FldProxy l -> Lens (Rec lts) (Rec lts) v v +lens lbl f r = + fmap (\v -> set lbl v r) (f (get lbl r)) +{-# INLINE lens #-} diff --git a/superrecord.cabal b/superrecord.cabal --- a/superrecord.cabal +++ b/superrecord.cabal @@ -1,5 +1,5 @@ name: superrecord -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Supercharged anonymous records description: Anonymous records with various useful utilities homepage: https://github.com/agrafix/superrecord#readme @@ -17,12 +17,12 @@ hs-source-dirs: src exposed-modules: SuperRecord build-depends: base >= 4.9 && < 5 - , primitive >= 0.6 , constraints , aeson >= 1.0 , text >= 1.2 , deepseq >= 1.4 , ghc-prim >= 0.5 + , mtl >= 2.1 default-language: Haskell2010 ghc-options: -Wall -O2 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,14 +1,32 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +module Main where + import SuperRecord import Data.Aeson +import GHC.Generics (Generic) import Test.Hspec +data V1 +data V2 +data V3 + +type TestRecAppend = + RecAppend '["f1" := V1, "f2" := V2] '["f3" := V3] ~ '["f1" := V1, "f2" := V2, "f3" := V3] + +data SomeType + = SomeType + { st_foo :: !String + , st_bar :: !Int + } deriving (Show, Eq, Generic) + type Ex1 = '["foo" := String, "int" := Int] @@ -21,14 +39,18 @@ r2 :: Rec '["foo" := String] r2 = #foo := "He" & rnil -polyFun :: Has "foo" lts idx s String => Rec lts -> String +polyFun :: Has "foo" lts String => Rec lts -> String polyFun = get #foo +polyFun2 :: HasOf '["foo" := String, "bar" := Bool] lts => Rec lts -> String +polyFun2 r = + get #foo r ++ " -> " ++ show (get #bar r) + rNested :: Rec '["foo" := Rec '["bar" := Int] ] rNested = #foo := (#bar := 213 & rnil) & rnil -main :: IO () +main :: TestRecAppend => IO () main = hspec $ do it "getter works" $ do get #foo r1 `shouldBe` "Hi" @@ -37,17 +59,52 @@ polyFun r2 `shouldBe` "He" get #bar (get #foo rNested) `shouldBe` 213 rNested &. #foo &. #bar `shouldBe` 213 + getPath (#foo &:- #bar) rNested `shouldBe` 213 + it "hasOf workds" $ + polyFun2 (#foo := "123" & #bar := True & #bim := False & rnil) `shouldBe` "123 -> True" it "setter works" $ do let r1u = set #foo "Hey" r1 get #foo r1 `shouldBe` "Hi" get #foo r1u `shouldBe` "Hey" get #int (set #int 123 r1) `shouldBe` 123 set #int 213 (set #int 123 r1) `shouldBe` r1 - setPath (#foo &: #bar &: snil) 123 rNested + setPath (#foo &:- #bar) 123 rNested `shouldBe` (#foo := (#bar := 123 & rnil) & rnil) + modifyPath (#foo &:- #bar) (+1) rNested + `shouldBe` (#foo := (#bar := 214 & rnil) & rnil) + it "modify works" $ + do let r1u = modify #foo (\x -> x ++ "!") r1 + get #foo r1 `shouldBe` "Hi" + get #foo r1u `shouldBe` "Hi!" it "getting record keys works" $ do let vals = recKeys r1 vals `shouldBe` ["foo", "int"] + it "fromNative works" $ + do let r = fromNative (SomeType "hello" 123) + get #st_foo r `shouldBe` "hello" + get #st_bar r `shouldBe` 123 + it "toNative works" $ + do let ra = (#st_foo := "hello" & #st_bar := 123 & rnil) + toNative ra `shouldBe` SomeType "hello" 123 + let rb = (#st_bar := 123 & #st_foo := "hello" & rnil) + toNative rb `shouldBe` SomeType "hello" 123 + let rc = (#other := True & #st_bar := 123 & #st_foo := "hello" & rnil) + toNative rc `shouldBe` SomeType "hello" 123 + it "combine works" $ + do let rc = r1 ++: (#bar := True & rnil) + rc &. #foo `shouldBe` "Hi" + rc &. #int `shouldBe` 213 + rc &. #bar `shouldBe` True + rc `shouldBe` (#foo := "Hi" & #int := 213 & #bar := True & rnil) + it "combine works 2" $ + do let rc = r1 ++: (#bim := 123 & #fizz := "Hoy" & #bar := True & rnil) + rc &. #foo `shouldBe` "Hi" + rc &. #int `shouldBe` 213 + rc &. #bar `shouldBe` True + rc &. #fizz `shouldBe` ("Hoy" :: String) + rc &. #bim `shouldBe` (123 :: Int) + rc `shouldBe` + (#foo := "Hi" & #int := 213 & #bim := 123 & #fizz := "Hoy" & #bar := True & rnil) it "showRec words" $ do let vals = showRec r1 vals `shouldBe` [("foo", "\"Hi\""), ("int", "213")]