module Data.HList.Record
(
LVPair(..),
labelLVPair,
newLVPair,
Record(..),
mkRecord,
emptyRecord,
RecordLabels,
recordLabels,
recordLabels',
RecordValues(..),
recordValues,
ShowComponents(..),
ShowLabel(..),
HasField(..),
HasField'(..),
hDeleteAtLabel,
hUpdateAtLabel,
hTPupdateAtLabel,
hRenameLabel,
hProjectByLabels,
hProjectByLabels2,
HLeftUnion(hLeftUnion),
HLeftUnionBool(hLeftUnionBool),
UnionSymRec(unionSR),
hRearrange,
DuplicatedLabel(..),
ExtraField(..),
FieldNotFound(..),
H2ProjectByLabels(h2projectByLabels),
H2ProjectByLabels'(h2projectByLabels'),
HLabelSet,
HLabelSet',
HRLabelSet,
HRLabelSet',
HRearrange(hRearrange2),
HRearrange'(hRearrange2'),
UnionSymRec'(..)
) where
import Data.HList.FakePrelude
import Data.HList.HListPrelude
import Data.HList.HArray
newtype LVPair l v = LVPair { valueLVPair :: v } deriving Eq
labelLVPair :: LVPair l v -> l
labelLVPair = undefined
newLVPair :: l -> v -> LVPair l v
newLVPair _ = LVPair
newtype Record r = Record r deriving Eq
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 leq
, HRLabelSet' l1 v1 l2 v2 leq r
) => HRLabelSet (HCons (LVPair l1 v1) (HCons (LVPair l2 v2) r))
class HRLabelSet' l1 v1 l2 v2 leq r
instance ( HRLabelSet (HCons (LVPair l2 v2) r)
, HRLabelSet (HCons (LVPair l1 v1) r)
) => HRLabelSet' l1 v1 l2 v2 HFalse r
instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 v1 l2 v2 HTrue r
class HLabelSet ls
instance HLabelSet HNil
instance (HMember x ls xmem, HLabelSet' x ls xmem) => HLabelSet (HCons x ls)
class HLabelSet' x ls xmem
instance HLabelSet ls => HLabelSet' x ls HFalse
data DuplicatedLabel l = DuplicatedLabel l
instance Fail (DuplicatedLabel x) => HLabelSet' x ls HTrue
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' r = undefined
recordLabels :: RecordLabels r ls => Record r -> ls
recordLabels (Record r) = recordLabels' r
class RecordValues r ls | r -> ls
where recordValues' :: r -> ls
instance RecordValues HNil HNil
where recordValues' _ = HNil
instance RecordValues r' vs
=> RecordValues (HCons (LVPair l v) r') (HCons v vs)
where recordValues' ~(HCons (LVPair v) r') = HCons v (recordValues' r')
recordValues :: RecordValues r vs => Record r -> vs
recordValues (Record r) = recordValues' r
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 :: (HUpdateAtHNat n (LVPair l v) t l',HFind l ls n,RecordLabels t ls) =>l -> 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 :: (H2ProjectByLabels ls t t1 t2, HRLabelSet t1, HRLabelSet 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 :: (HRLabelSet (HCons (LVPair l v) t2),HasField e t1 v,H2ProjectByLabels (HCons e HNil) t1 t t2) =>
e -> l -> Record t1 -> 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 :: (HasField l t a,HUpdateAtHNat n (LVPair l a) t l',HFind l ls n,RecordLabels t ls) =>
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
hRearrange :: (HLabelSet ls, HRearrange ls r r') => ls -> Record r -> Record r'
hRearrange ls (Record r) = Record $ hRearrange2 ls r
class HRearrange ls r r' | ls r -> r' where
hRearrange2 :: ls -> r -> r'
instance HRearrange HNil HNil HNil where
hRearrange2 _ _ = HNil
instance (H2ProjectByLabels (HCons l HNil) r rin rout,
HRearrange' l ls rin rout r') =>
HRearrange (HCons l ls) r r' where
hRearrange2 ~(HCons l ls) r = hRearrange2' l ls rin rout
where (rin, rout) = h2projectByLabels (HCons l HNil) r
class HRearrange' l ls rin rout r' | l ls rin rout -> r' where
hRearrange2' :: l -> ls -> rin -> rout -> r'
instance HRearrange ls rout r' =>
HRearrange' l ls (HCons (LVPair l v) HNil) rout (HCons (LVPair l v) r') where
hRearrange2' _ ls (HCons lv@(LVPair v) HNil) rout = HCons (LVPair v `asTypeOf` lv) (hRearrange2 ls rout)
data ExtraField l = ExtraField
data FieldNotFound l = FieldNotFound
instance Fail (FieldNotFound l) =>
HRearrange' l ls HNil rout (FieldNotFound l) where
hRearrange2' _ _ _ _ = FieldNotFound
instance Fail (ExtraField l) =>
HRearrange HNil (HCons (LVPair l v) a) (ExtraField l) where
hRearrange2 _ _ = ExtraField