superrecord 0.1.1.0 → 0.2.0.0
raw patch · 4 files changed
+405/−92 lines, 4 filesdep +mtldep −primitive
Dependencies added: mtl
Dependencies removed: primitive
Files
- bench/Bench.hs +6/−2
- src/SuperRecord.hs +337/−85
- superrecord.cabal +2/−2
- test/Spec.hs +60/−3
bench/Bench.hs view
@@ -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
src/SuperRecord.hs view
@@ -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 #-}
superrecord.cabal view
@@ -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
test/Spec.hs view
@@ -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")]