module Data.HList.Record where
import Data.HList.FakePrelude
import Data.HList.HListPrelude
import Data.HList.HArray
newtype LVPair l v = LVPair { valueLVPair :: v }
labelLVPair :: LVPair l v -> l
labelLVPair = undefined
newLVPair :: l -> v -> LVPair l v
newLVPair _ = LVPair
newtype Record r = Record r
mkRecord :: HRLabelSet r => r -> Record r
mkRecord = Record
emptyRecord :: Record HNil
emptyRecord = mkRecord HNil
class HRLabelSet ps
instance HRLabelSet HNil
instance HRLabelSet (HCons x HNil)
instance ( HEq l1 l2 HFalse
, HRLabelSet (HCons (LVPair l2 v2) r)
, HRLabelSet (HCons (LVPair l1 v1) r)
) => HRLabelSet (HCons (LVPair l1 v1) (HCons (LVPair l2 v2) r))
class HLabelSet ls
instance HLabelSet HNil
instance (HMember x ls HFalse, HLabelSet ls)
=> HLabelSet (HCons x ls)
class RecordLabels r ls | r -> ls
instance RecordLabels HNil HNil
instance RecordLabels r' ls
=> RecordLabels (HCons (LVPair l v) r') (HCons l ls)
recordLabels :: RecordLabels r ls => r -> ls
recordLabels = undefined
instance ShowComponents r => Show (Record r)
where
show (Record r) = "Record{"
++ showComponents "" r
++ "}"
class ShowComponents l
where
showComponents :: String -> l -> String
instance ShowComponents HNil
where
showComponents _ HNil = ""
instance ( ShowLabel l
, Show v
, ShowComponents r
)
=> ShowComponents (HCons (LVPair l v) r)
where
showComponents comma (HCons f@(LVPair v) r)
= comma
++ showLabel (labelLVPair f)
++ "="
++ show v
++ showComponents "," r
class ShowLabel l
where
showLabel :: l -> String
instance HRLabelSet (HCons (LVPair l v) r)
=> HExtend (LVPair l v) (Record r) (Record (HCons (LVPair l v) r))
where
hExtend f (Record r) = mkRecord (HCons f r)
instance ( HRLabelSet r''
, HAppend r r' r''
)
=> HAppend (Record r) (Record r') (Record r'')
where
hAppend (Record r) (Record r') = mkRecord (hAppend r r')
class HasField l r v | l r -> v
where
hLookupByLabel:: l -> r -> v
instance HasField l r v => HasField l (Record r) v where
hLookupByLabel l (Record r) = hLookupByLabel l r
class HasField' b l r v | b l r -> v where
hLookupByLabel':: b -> l -> r -> v
instance (HEq l l' b, HasField' b l (HCons (LVPair l' v') r) v)
=> HasField l (HCons (LVPair l' v') r) v where
hLookupByLabel l r@(HCons f' _) =
hLookupByLabel' (hEq l (labelLVPair f')) l r
instance HasField' HTrue l (HCons (LVPair l v) r) v where
hLookupByLabel' _ _ (HCons (LVPair v) _) = v
instance HasField l r v => HasField' HFalse l (HCons fld r) v where
hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l r
hDeleteAtLabel :: (H2ProjectByLabels (HCons e HNil) t t1 t2) => e -> Record t -> Record t2
hDeleteAtLabel l (Record r) = Record r'
where
(_,r') = h2projectByLabels (HCons l HNil) r
hUpdateAtLabel ::( RecordLabels t ls, HFind e ls n, HUpdateAtHNat n (LVPair e v) t l') =>
e -> v -> Record t -> Record l'
hUpdateAtLabel l v (Record r) = Record r'
where
n = hFind l (recordLabels r)
r' = hUpdateAtHNat n (newLVPair l v) r
hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) => ls -> Record t -> Record a
hProjectByLabels ls (Record r) = mkRecord (fst $ h2projectByLabels ls r)
hProjectByLabels2 :: (HRLabelSet t2, HRLabelSet t1, H2ProjectByLabels ls t t1 t2) =>
ls -> Record t -> (Record t1, Record t2)
hProjectByLabels2 ls (Record r) = (mkRecord rin, mkRecord rout)
where (rin,rout) = h2projectByLabels ls r
class H2ProjectByLabels ls r rin rout | ls r -> rin rout where
h2projectByLabels :: ls -> r -> (rin,rout)
instance H2ProjectByLabels HNil r HNil r where
h2projectByLabels _ r = (HNil,r)
instance H2ProjectByLabels (HCons l ls) HNil HNil HNil where
h2projectByLabels _ _ = (HNil,HNil)
instance (HMemberM l' (HCons l ls) b,
H2ProjectByLabels' b (HCons l ls) (HCons (LVPair l' v') r') rin rout)
=> H2ProjectByLabels (HCons l ls) (HCons (LVPair l' v') r') rin rout where
h2projectByLabels ls r@(HCons _ _) =h2projectByLabels' (undefined::b) ls r
class H2ProjectByLabels' b ls r rin rout | b ls r -> rin rout where
h2projectByLabels' :: b -> ls -> r -> (rin,rout)
instance H2ProjectByLabels ls' r' rin rout =>
H2ProjectByLabels' (HJust ls') ls (HCons f' r') (HCons f' rin) rout where
h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout)
where (rin,rout) = h2projectByLabels (undefined::ls') r
instance H2ProjectByLabels ls r' rin rout =>
H2ProjectByLabels' HNothing ls (HCons f' r') rin (HCons f' rout) where
h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout)
where (rin,rout) = h2projectByLabels ls r
hRenameLabel :: (H2ProjectByLabels (HCons e HNil) t t1 t2, HasField e t v,
HRLabelSet (HCons (LVPair l v) t2)) =>
e -> l -> Record t -> Record (HCons (LVPair l v) t2)
hRenameLabel l l' r = r''
where
v = hLookupByLabel l r
r' = hDeleteAtLabel l r
r'' = hExtend (newLVPair l' v) r'
hTPupdateAtLabel :: (HUpdateAtHNat n (LVPair l a) t l', HFind l ls n, RecordLabels t ls,
HasField l t a) =>
l -> a -> Record t -> Record l'
hTPupdateAtLabel l v r = hUpdateAtLabel l v r
where
te :: a -> a -> ()
te _ _ = ()
_ = te v (hLookupByLabel l r)
instance ( RecordLabels r' ls
, H2ProjectByLabels ls r r' rout
)
=> SubType (Record r) (Record r')
class HLeftUnion r r' r'' | r r' -> r''
where hLeftUnion :: r -> r' -> r''
instance HLeftUnion r (Record HNil) r
where hLeftUnion r _ = r
instance ( RecordLabels r ls
, HMember l ls b
, HLeftUnionBool b r (LVPair l v) r'''
, HLeftUnion (Record r''') (Record r') r''
)
=> HLeftUnion (Record r) (Record (HCons (LVPair l v) r')) r''
where
hLeftUnion (Record r) (Record (HCons f r')) = r''
where
b = hMember (labelLVPair f) (recordLabels r)
r''' = hLeftUnionBool b r f
r'' = hLeftUnion (Record r''') (Record r')
class HLeftUnionBool b r f r' | b r f -> r'
where hLeftUnionBool :: b -> r -> f -> r'
instance HLeftUnionBool HTrue r f r
where hLeftUnionBool _ r _ = r
instance HLeftUnionBool HFalse r f (HCons f r)
where hLeftUnionBool _ r f = HCons f r
class UnionSymRec r1 r2 ru | r1 r2 -> ru where
unionSR :: r1 -> r2 -> (ru, ru)
instance UnionSymRec r1 (Record HNil) r1 where
unionSR r1 _ = (r1, r1)
instance ( RecordLabels r1 ls
, HMember l ls b
, UnionSymRec' b (Record r1) (LVPair l v) (Record r2') ru
)
=> UnionSymRec (Record r1) (Record (HCons (LVPair l v) r2')) ru
where
unionSR r1 (Record (HCons f r2')) =
unionSR' (undefined::b) r1 f (Record r2')
class UnionSymRec' b r1 f2 r2' ru | b r1 f2 r2' -> ru where
unionSR' :: b -> r1 -> f2 -> r2' -> (ru, ru)
instance (UnionSymRec r1 r2' (Record ru),
HasField l2 ru v2,
HUpdateAtHNat n (LVPair l2 v2) ru ru,
RecordLabels ru ls,
HFind l2 ls n)
=> UnionSymRec' HTrue r1 (LVPair l2 v2) r2' (Record ru) where
unionSR' _ r1 (LVPair v2) r2' = (ul, ur')
where (ul,ur) = unionSR r1 r2'
ur' = hTPupdateAtLabel (undefined::l2) v2 ur
instance (UnionSymRec r1 r2' (Record ru),
HExtend f2 (Record ru) (Record (HCons f2 ru)))
=> UnionSymRec' HFalse r1 f2 r2' (Record (HCons f2 ru)) where
unionSR' _ r1 f2 r2' = (ul', ur')
where (ul,ur) = unionSR r1 r2'
ul' = hExtend f2 ul
ur' = hExtend f2 ur