git.iko.soy/jrec
on master help sign in
Implement insertOrSet
commit02deba92622bfdd4bdf31f7539ec713050101189 authorSridhar Ratnakumar <srid@srid.ca> dateFri 28 Aug 2020, 17:07 (6 years ago) parented195a6
3 files changed+65−28
compare with master
unifiedsplit
src/JRec.hs+17−14 src/JRec/Internal.hs+41−7 test/JRecSpec.hs+7−7
src/JRec.hs+17−14
@@ -10,6 +10,7 @@ module JRec
1010 append,
1111 union,
1212 insert,
13+ insertOrSet
1314 )
1415where
1516
@@ -95,21 +96,23 @@ insert ::
9596 Rec lts -> Rec res
9697insert = R.combine . Rec
9798
98−--insertOrSet ::
99−-- forall label value rhs res.
100−-- ( KnownNat (R.RecSize rhs),
101−-- KnownNat (R.RecTyIdxH 0 label res),
102−-- KnownNat (1 + R.RecSize rhs),
103−-- KnownSymbol label,
104−-- res ~ R.Union '[label := value] rhs,
105−-- value ~ R.RecTy label res,
106−-- R.RecCopy rhs rhs res
107−-- ) =>
108−-- label := value ->
109−-- Rec rhs ->
110−-- Rec res
111−--insertOrSet = union . Rec
99+-- | Insert a field into a record. Set it if it already exists
112100--
101+-- O(n) type check complexity.
102+insertOrSet ::
103+ forall label value rhs res.
104+ ( KnownNat (R.RecSize rhs),
105+ KnownNat (R.RecSize res),
106+ KnownNat (R.RecTyIdxH 0 label res),
107+ KnownSymbol label,
108+ value ~ R.RecTy label res,
109+ R.Reverse (R.Insert (label := value) (R.Reverse rhs)) ~ res,
110+ R.RecCopy rhs rhs res
111+ ) =>
112+ label := value ->
113+ Rec rhs ->
114+ Rec res
115+insertOrSet = R.insert
113116
114117----------------------------------------------------------------------------
115118-- Generic
src/JRec/Internal.hs+41−7
@@ -222,18 +222,23 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
222222 )
223223 KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts
224224
225+type family Reverse (xs :: [*]) where
226+ Reverse '[] = '[]
227+ Reverse (x ': xs) = RecAppend (Reverse xs) '[x]
228+
225229type family Insert (a :: *) (xs :: [*]) where
226− Insert (a := t) '[] = a := t ': '[]
227− Insert (a := t1) (a := t2 ': xs) = a := t1 ': xs
228− Insert (a := t1) (x := t2 ': xs) = x := t2 ': Insert (a := t1) xs
230+ Insert x '[] = x ': '[]
231+ Insert (a := v) (a := _ ': xs) = a := v ': xs
232+ Insert a (x ': xs) = x ': Insert a xs
229233
230234type family Union xs ys where
231235 Union xs '[] = xs
232236 Union xs (y := t ': ys) = Union (Insert (y := t) xs) ys
233237
238+-- TODO: Rename to `Append`, because it just deals with general type list?
234239type family RecAppend lhs rhs where
235240 RecAppend '[] rhs = rhs
236− RecAppend (x := t ': xs) rhs = x := t ': RecAppend xs rhs
241+ RecAppend (x ': xs) rhs = x ': RecAppend xs rhs
237242
238243type family RecSize (lts :: [*]) :: Nat where
239244 RecSize '[] = 0
@@ -394,9 +399,7 @@ combine lts rts =
394399 (# s''''#, a# #) -> (# s''''#, MkRec a# #)
395400{-# INLINE combine #-}
396401
397−-- | Union two records
398−--
399−-- NOTE: changed from original superrecord to not require a 'Sort'
402+-- | Union two records (left-biased)
400403union ::
401404 forall lhs rhs res.
402405 ( KnownNat (RecSize lhs),
@@ -426,6 +429,37 @@ union lts rts =
426429 (# s''''#, a# #) -> (# s''''#, MkRec a# #)
427430{-# INLINE union #-}
428431
432+-- | Insert a field
433+--
434+-- Insert at beginning, unless the field already exists, in which case set it
435+-- directly.
436+insert ::
437+ forall l v rhs res.
438+ ( KnownNat (RecSize rhs),
439+ KnownNat (RecSize res),
440+ res ~ Reverse (Insert (l := v) (Reverse rhs)),
441+ RecCopy '[l := v] '[l := v] res,
442+ RecCopy rhs rhs res
443+ ) =>
444+ l := v ->
445+ Rec rhs ->
446+ Rec res
447+insert (l := v) rts =
448+ let !(I# size#) =
449+ fromIntegral $ natVal' (proxy# :: Proxy# (RecSize res))
450+ in runST' $
451+ ST $ \s# ->
452+ case newSmallArray# size# (error "No value") s# of
453+ (# s'#, arr# #) ->
454+ case recCopyInto (Proxy :: Proxy rhs) rts (Proxy :: Proxy res) arr# s'# of
455+ s''# ->
456+ case recCopyInto (Proxy :: Proxy '[l := v]) (unsafeRCons (l := v) $ unsafeRNil 1) (Proxy :: Proxy res) arr# s''# of
457+ s'''# ->
458+ case unsafeFreezeSmallArray# arr# s'''# of
459+ (# s''''#, a# #) -> (# s''''#, MkRec a# #)
460+{-# INLINE insert #-}
461+
462+
429463
430464-- | Alias for 'combine'
431465(++:) ::
test/JRecSpec.hs+7−7
@@ -77,10 +77,10 @@ spec = do
7777 -- `shouldBe` Rec (#a := 1, #b := 2, #a := 0, #c := 3)
7878 it "duplicate insert should be disallowed" $ do
7979 pendingWith "TODO"
80−-- describe "insertOrSet" $ do
81−-- it "distinct" $ do
82−-- insertOrSet (#a := 1) (Rec (#b := 2, #c := 3))
83−-- `shouldBe` Rec (#a := 1, #b := 2, #c := 3)
84−-- it "overwrite" $ do
85−-- insertOrSet (#c := 1) (Rec (#b := 2, #c := 3))
86−-- `shouldBe` Rec (#b := 2, #c := 1)
80+ describe "insertOrSet" $ do
81+ it "distinct" $ do
82+ insertOrSet (#a := 1) (Rec (#b := 2, #c := 3))
83+ `shouldBe` Rec (#a := 1, #b := 2, #c := 3)
84+ it "overwrite" $ do
85+ insertOrSet (#c := 1) (Rec (#b := 2, #c := 3))
86+ `shouldBe` Rec (#b := 2, #c := 1)