@@ -221,6 +221,15 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
221221 )
222222 KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts
223223
224+type family Insert (a :: *) (xs :: [*]) where
225+ Insert (a := t) '[] = a := t ': '[]
226+ Insert (a := t1) (a := t2 ': xs) = a := t1 ': xs
227+ Insert (a := t1) (x := t2 ': xs) = x := t2 ': Insert (a := t1) xs
228+
229+type family Union xs ys where
230+ Union xs '[] = xs
231+ Union xs (y := t ': ys) = Union (Insert (y := t) xs) ys
232+
224233type family RecAppend lhs rhs where
225234 RecAppend '[] rhs = rhs
226235 RecAppend (x := t ': xs) rhs = x := t ': RecAppend xs rhs
@@ -384,6 +393,39 @@ combine lts rts =
384393 (# s''''#, a# #) -> (# s''''#, MkRec a# #)
385394{-# INLINE combine #-}
386395
396+-- | Union two records
397+--
398+-- NOTE: changed from original superrecord to not require a 'Sort'
399+union ::
400+ forall lhs rhs res.
401+ ( KnownNat (RecSize lhs),
402+ KnownNat (RecSize rhs),
403+ KnownNat (RecSize lhs + RecSize rhs),
404+ res ~ Union lhs rhs,
405+ RecCopy lhs lhs res,
406+ RecCopy rhs rhs res
407+ ) =>
408+ Rec lhs ->
409+ Rec rhs ->
410+ Rec res
411+union lts rts =
412+ let !(I# size#) =
413+ fromIntegral $ natVal' (proxy# :: Proxy# (RecSize lhs + RecSize rhs))
414+ in runST' $
415+ ST $ \s# ->
416+ case newSmallArray# size# (error "No value") s# of
417+ (# s'#, arr# #) ->
418+ -- Copy rhs first, so that lhs can override later so as to retain
419+ -- the left-biased semantics of union.
420+ case recCopyInto (Proxy :: Proxy rhs) rts (Proxy :: Proxy res) arr# s'# of
421+ s''# ->
422+ case recCopyInto (Proxy :: Proxy lhs) lts (Proxy :: Proxy res) arr# s''# of
423+ s'''# ->
424+ case unsafeFreezeSmallArray# arr# s'''# of
425+ (# s''''#, a# #) -> (# s''''#, MkRec a# #)
426+{-# INLINE union #-}
427+
428+
387429-- | Alias for 'combine'
388430(++:) ::
389431 forall lhs rhs res.