superrecord 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+200/−57 lines, 5 files
Files
- README.md +2/−0
- bench/Bench.hs +55/−13
- src/SuperRecord.hs +129/−39
- superrecord.cabal +1/−1
- test/Spec.hs +13/−4
README.md view
@@ -3,3 +3,5 @@ [](https://circleci.com/gh/agrafix/superrecord) Supercharged anonymous records++For a full introduction and explication please read [this blog post](https://www.athiemann.net/2017/07/02/superrecord.html).
bench/Bench.hs view
@@ -1,14 +1,17 @@+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE BangPatterns #-} import Criterion import Criterion.Main import Control.DeepSeq import Data.Aeson import GHC.Generics+import GHC.TypeLits import SuperRecord import qualified Bookkeeper as B import qualified Labels as L@@ -16,7 +19,7 @@ data Nested = Nested { n_f41 :: String- } deriving (Generic)+ } deriving (Read, Generic) instance NFData Nested instance ToJSON Nested@@ -28,12 +31,48 @@ , n_f2 :: Int , n_f3 :: Bool , n_f4 :: Nested- } deriving (Generic)+ } deriving (Read, Generic) instance NFData Native instance ToJSON Native instance FromJSON Native +someIntList :: [Int]+someIntList =+ read "[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15]"++data CList a+ = CList+ { cl_list :: !(Maybe (a, CList a))+ } deriving (Show, Eq)++toCList :: [a] -> CList a+toCList [] = CList Nothing+toCList (x : xs) = CList (Just (x, toCList xs))++idxC :: Int -> CList a -> Maybe a+idxC !i c+ | i <= 0 = fst <$> cl_list c+ | otherwise =+ case cl_list c of+ Just (_, xs) -> idxC (i - 1) xs+ Nothing -> Nothing++newtype RList a+ = RList { unRlist :: Rec '[ "list" := Maybe (a, RList a) ] }++toRList :: [a] -> RList a+toRList [] = RList $ #list := Nothing & rnil+toRList (x : xs) = RList $ #list := Just (x, toRList xs) & rnil++idxR :: Int -> RList a -> Maybe a+idxR !i (RList r)+ | i <= 0 = fst <$> get #list r+ | otherwise =+ case get #list r of+ Just (_, xs) -> idxR (i - 1) xs+ Nothing -> Nothing+ type Ex1 = '[ "f1" := String , "f2" := Int@@ -49,6 +88,9 @@ & #f4 := (#f41 := "abc" & rnil) & rnil ++deriving instance (KnownSymbol a, Read b) => Read ((L.:=) a b )+ r1L :: ( "f1" L.:= String , "f2" L.:= Int@@ -56,11 +98,9 @@ , "f4" L.:= ("f41" L.:= String) ) r1L =- ( #f1 L.:= "Hi"- , #f2 L.:= 213- , #f3 L.:= True- , #f4 L.:= (#f41 L.:= "abc")- )+ -- needed to prevent unrealistic inlining (normally, data comes from the real world and is+ -- not statically known at compile time)+ read "(Proxy := \"Hi\", Proxy := 213, Proxy := True, Proxy := (Proxy := \"abc\"))" r1B :: B.Book@@ -76,13 +116,11 @@ B.& #f3 B.=: True B.& #f4 B.=: (B.emptyBook B.& #f41 B.=: "abc") +r1N :: Native r1N =- Native- { n_f1 = "Hi"- , n_f2 = 213- , n_f3 = True- , n_f4 = Nested "abc"- }+ -- needed to prevent unrealistic inlining (normally, data comes from the real world and is+ -- not statically known at compile time)+ read "Native { n_f1 = \"Hi\", n_f2 = 213, n_f3 = True, n_f4 = Nested { n_f41 = \"Hi\"} }" main :: IO () main =@@ -126,6 +164,10 @@ , bgroup "json" [ bench "superrecord" $ nf @[Rec Ex1] (throwOnNone . decode' . encode) $ replicate 50 r1 , bench "native" $ nf @[Native] (throwOnNone . decode' . encode) $ replicate 50 r1N+ ]+ , bgroup "dummy list"+ [ bench "superrecord" $ nf (idxR 9 . toRList) someIntList+ , bench "native" $ nf (idxC 9 . toCList) someIntList ] ]
src/SuperRecord.hs view
@@ -21,7 +21,7 @@ module SuperRecord ( -- * Basics (:=)(..)- , Rec, rnil, rcons, (&)+ , Record, rnil, rcons, (&) , fld , Has, HasOf , get, (&.)@@ -30,7 +30,7 @@ , getPath, setPath, modifyPath, RecApplyPath, (:&), (&:), (&:-) , combine, (++:), RecAppend -- * Reflection- , reflectRec, RecApply(..)+ , reflectRec, reflectRecFold, RecApply(..) -- * Native type interop , FromNative, fromNative , ToNative, toNative@@ -41,8 +41,10 @@ -- * Lens interop , lens -- * Machinery+ , Rec+ , RecCopy , RecTyIdxH- , showRec, RecKeys(..)+ , showRec, RecKeys(..), recKeys , RecEq(..) , recToValue, recToEncoding , recJsonParser, RecJsonParse(..)@@ -99,7 +101,13 @@ instance l ~ l' => IsLabel (l :: Symbol) (FldProxy l') where fromLabel _ = FldProxy --- | The core record type.+-- | The core record type. Prefer this type when manually writing type+-- signatures+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 :: [*]) = Rec { _unRec :: SmallArray# Any } -- Note that the values are physically in reverse order @@ -127,8 +135,6 @@ 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 (I# n#) =@@ -137,31 +143,61 @@ (# 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' rcons :: 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#) =+ ( RecSize lts ~ s+ , KnownNat s+ , KnownNat (RecVecIdxPos l (Sort (l := t ': lts)))+ , KeyDoesNotExist l lts+ , RecCopy lts lts (Sort (l := t ': lts))+ )+ => l := t -> Rec lts -> Rec (Sort (l := t ': lts))+rcons (_ := val) lts = unsafePerformIO $! IO $ \s# -> case newSmallArray# newSize# (error "No value") s# of (# s'#, arr# #) ->- case copySmallArray# vec# 0# arr# 0# size# s'# of+ case recCopyInto (Proxy :: Proxy lts) lts (Proxy :: Proxy (Sort (l := t ': lts))) arr# s'# of s''# ->- case writeSmallArray# arr# size# (unsafeCoerce# val) s''# of+ case writeSmallArray# arr# setAt# (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)+ !(I# setAt#) =+ fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l (Sort (l := t ': lts)))))+ newSize# = size# +# 1#+ !(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# s) {-# INLINE rcons #-} +class RecCopy (pts :: [*]) (lts :: [*]) (rts :: [*]) where+ recCopyInto ::+ Proxy pts -> Rec lts -> Proxy rts+ -> SmallMutableArray# RealWorld Any+ -> State# RealWorld+ -> State# RealWorld++instance RecCopy '[] lts rts where+ recCopyInto _ _ _ _ s# = s#++instance+ ( Has l rts t+ , Has l lts t+ , RecCopy (RemoveAccessTo l (l := t ': pts)) lts rts+ ) => RecCopy (l := t ': pts) lts rts where+ recCopyInto _ lts prxy tgt# s# =+ let lbl :: FldProxy l+ lbl = FldProxy+ val = get lbl lts+ pNext :: Proxy (RemoveAccessTo l (l := t ': pts))+ pNext = Proxy+ !(I# setAt#) =+ fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l rts)))+ in case writeSmallArray# tgt# setAt# (unsafeCoerce# val) s# of+ s'# -> recCopyInto pNext lts prxy tgt# s'#+ -- | Prepend a record entry to a record 'Rec'. Assumes that the record was created with -- 'unsafeRnil' and still has enough free slots, mutates the original 'Rec' which should -- not be reused after@@ -184,13 +220,30 @@ -- | Alias for 'rcons' (&) :: forall l t lts s.- (RecSize lts ~ s, KnownNat s, KeyDoesNotExist l lts)- => l := t -> Rec lts -> Rec (l := t ': lts)+ ( RecSize lts ~ s+ , KnownNat s+ , KnownNat (RecVecIdxPos l (Sort (l := t ': lts)))+ , KeyDoesNotExist l lts+ , RecCopy lts lts (Sort (l := t ': lts))+ )+ => l := t -> Rec lts -> Rec (Sort (l := t ': lts)) (&) = rcons {-# INLINE (&) #-} infixr 5 & +type family Sort (lts :: [*]) where+ Sort '[] = '[]+ Sort (x := t ': xs) = SortInsert (x := t) (Sort xs)++type family SortInsert (x :: *) (xs :: [*]) where+ SortInsert x '[] = x ': '[]+ SortInsert (x := t) ((y := u) ': ys) = SortInsert' (CmpSymbol x y) (x := t) (y := u) ys++type family SortInsert' (b :: Ordering) (x :: *) (y :: *) (ys :: [*]) where+ SortInsert' 'LT x y ys = x ': (y ': ys)+ SortInsert' _ x y ys = y ': SortInsert x ys+ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where KeyDoesNotExist l '[] = 'True ~ 'True KeyDoesNotExist l (l := t ': lts) =@@ -378,20 +431,24 @@ -- | Combine two records combine :: forall lhs rhs.- (KnownNat (RecSize lhs), KnownNat (RecSize rhs), KnownNat (RecSize lhs + RecSize rhs))+ ( KnownNat (RecSize lhs)+ , KnownNat (RecSize rhs)+ , KnownNat (RecSize lhs + RecSize rhs)+ , RecCopy lhs lhs (Sort (RecAppend lhs rhs))+ , RecCopy rhs rhs (Sort (RecAppend lhs 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))+ -> Rec (Sort (RecAppend lhs rhs))+combine lts rts =+ let !(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+ case recCopyInto (Proxy :: Proxy lhs) lts (Proxy :: Proxy (Sort (RecAppend lhs rhs))) arr# s'# of s''# ->- case copySmallArray# l# 0# arr# sizeR# sizeL# s''# of+ case recCopyInto (Proxy :: Proxy rhs) rts (Proxy :: Proxy (Sort (RecAppend lhs rhs))) arr# s''# of s'''# -> case unsafeFreezeSmallArray# arr# s'''# of (# s''''#, a# #) -> (# s''''#, Rec a# #)@@ -400,30 +457,48 @@ -- | Alias for 'combine' (++:) :: forall lhs rhs.- (KnownNat (RecSize lhs), KnownNat (RecSize rhs), KnownNat (RecSize lhs + RecSize rhs))+ ( KnownNat (RecSize lhs)+ , KnownNat (RecSize rhs)+ , KnownNat (RecSize lhs + RecSize rhs)+ , RecCopy lhs lhs (Sort (RecAppend lhs rhs))+ , RecCopy rhs rhs (Sort (RecAppend lhs rhs))+ ) => Rec lhs -> Rec rhs- -> Rec (RecAppend lhs rhs)+ -> Rec (Sort (RecAppend lhs rhs)) (++:) = combine {-# INLINE (++:) #-} +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 = recKeys' . recFields++recKeys' :: RecFields lts -> [String]+recKeys' x =+ case x of+ RFNil -> []+ RFCons q qs -> symbolVal q : recKeys' qs+ -- | Get keys of a record on value and type level class RecKeys (lts :: [*]) where type RecKeysT lts :: [Symbol]- recKeys :: t lts -> [String]+ recFields :: t lts -> RecFields (RecKeysT lts) instance RecKeys '[] where type RecKeysT '[] = '[]- recKeys _ = []+ recFields _ = RFNil instance (KnownSymbol l, RecKeys lts) => RecKeys (l := t ': lts) where type RecKeysT (l := t ': lts) = (l ': RecKeysT lts)- recKeys (_ :: f (l := t ': lts)) =+ recFields (_ :: f (l := t ': lts)) = let lbl :: FldProxy l lbl = FldProxy more :: Proxy lts more = Proxy- in (symbolVal lbl : recKeys more)+ in (lbl `RFCons` recFields more) -- | Apply a function to each key element pair for a record reflectRec ::@@ -433,9 +508,22 @@ -> Rec lts -> [r] reflectRec _ f r =- recApply (\(Dict :: Dict (c a)) s v -> f s v) r (Proxy :: Proxy lts)+ reverse $+ recApply (\(Dict :: Dict (c a)) s v xs -> (f s v : xs)) r (Proxy :: Proxy lts) [] {-# INLINE reflectRec #-} +-- | Fold over all elements of a record+reflectRecFold ::+ forall c r lts. (RecApply lts lts c)+ => Proxy c+ -> (forall a. c a => String -> a -> r -> r)+ -> Rec lts+ -> r+ -> r+reflectRecFold _ f r =+ recApply (\(Dict :: Dict (c a)) s v x -> f s v x) r (Proxy :: Proxy lts)+{-# INLINE reflectRecFold #-}+ -- | Convert all elements of a record to a 'String' showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)] showRec = reflectRec @Show Proxy (\k v -> (k, show v))@@ -455,10 +543,10 @@ -- | Machinery needed to implement 'reflectRec' class RecApply (rts :: [*]) (lts :: [*]) c where- recApply :: (forall a. Dict (c a) -> String -> a -> r) -> Rec rts -> Proxy lts -> [r]+ recApply :: (forall a. Dict (c a) -> String -> a -> b -> b) -> Rec rts -> Proxy lts -> b -> b instance RecApply rts '[] c where- recApply _ _ _ = []+ recApply _ _ _ b = b instance ( KnownSymbol l@@ -466,14 +554,14 @@ , Has l rts v , c v ) => RecApply rts (l := t ': lts) c where- recApply f r (_ :: Proxy (l := t ': lts)) =+ recApply f r (_ :: Proxy (l := t ': lts)) b = let lbl :: FldProxy l lbl = FldProxy val = get lbl r- res = f Dict (symbolVal lbl) val+ res = f Dict (symbolVal lbl) val b pNext :: Proxy (RemoveAccessTo l (l := t ': lts)) pNext = Proxy- in (res : recApply f r pNext)+ in recApply f r pNext res -- | Machinery to implement equality class RecEq (rts :: [*]) (lts :: [*]) where@@ -558,7 +646,9 @@ instance ( FromNative l lhs , FromNative r rhs- , lts ~ RecAppend lhs rhs+ , lts ~ Sort (RecAppend lhs rhs)+ , RecCopy lhs lhs lts+ , RecCopy rhs rhs lts , KnownNat (RecSize lhs) , KnownNat (RecSize rhs) , KnownNat (RecSize lhs + RecSize rhs)
superrecord.cabal view
@@ -1,5 +1,5 @@ name: superrecord-version: 0.2.0.0+version: 0.3.0.0 synopsis: Supercharged anonymous records description: Anonymous records with various useful utilities homepage: https://github.com/agrafix/superrecord#readme
test/Spec.hs view
@@ -30,13 +30,13 @@ type Ex1 = '["foo" := String, "int" := Int] -r1 :: Rec Ex1+r1 :: Record Ex1 r1 = #foo := "Hi" & #int := 213 & rnil -r2 :: Rec '["foo" := String]+r2 :: Record '["foo" := String] r2 = #foo := "He" & rnil polyFun :: Has "foo" lts String => Rec lts -> String@@ -46,7 +46,7 @@ polyFun2 r = get #foo r ++ " -> " ++ show (get #bar r) -rNested :: Rec '["foo" := Rec '["bar" := Int] ]+rNested :: Record '["foo" := Record '["bar" := Int] ] rNested = #foo := (#bar := 213 & rnil) & rnil @@ -60,7 +60,7 @@ get #bar (get #foo rNested) `shouldBe` 213 rNested &. #foo &. #bar `shouldBe` 213 getPath (#foo &:- #bar) rNested `shouldBe` 213- it "hasOf workds" $+ it "hasOf works" $ polyFun2 (#foo := "123" & #bar := True & #bim := False & rnil) `shouldBe` "123 -> True" it "setter works" $ do let r1u = set #foo "Hey" r1@@ -90,6 +90,15 @@ toNative rb `shouldBe` SomeType "hello" 123 let rc = (#other := True & #st_bar := 123 & #st_foo := "hello" & rnil) toNative rc `shouldBe` SomeType "hello" 123+ it "can be constructed in any order" $+ do let areEq =+ (#foo := True & #bar := False & rnil)+ == (#bar := False & #foo := True & rnil)+ areEq `shouldBe` True+ let areNotEq =+ (#foo := False & #bar := False & rnil)+ == (#bar := False & #foo := True & rnil)+ areNotEq `shouldBe` False it "combine works" $ do let rc = r1 ++: (#bar := True & rnil) rc &. #foo `shouldBe` "Hi"