module Data.HList.RecordP where
import Data.HList.FakePrelude
import Data.HList.HListPrelude
import Data.HList.Record
import Data.HList.HArray
newtype RecordP ls vs = RecordP vs
mkRecordP :: (HSameLength ls vs, HLabelSet ls) => ls -> vs -> RecordP ls vs
mkRecordP _ vs = RecordP vs
class HSameLength l1 l2
instance HSameLength HNil HNil
instance HSameLength l1 l2 => HSameLength (HCons e1 l1) (HCons e2 l2)
emptyRecordP :: RecordP HNil HNil
emptyRecordP = mkRecordP HNil HNil
class HRLabelSet r => RecordR2P r ls vs | r -> ls vs, ls vs -> r where
record_r2p :: Record r -> RecordP ls vs
record_p2r :: RecordP ls vs -> Record r
instance RecordR2P HNil HNil HNil where
record_r2p _ = emptyRecordP
record_p2r _ = emptyRecord
instance (RecordR2P r ls vs, HRLabelSet (HCons (LVPair l v) r),
HLabelSet (HCons l ls), HSameLength ls vs)
=> RecordR2P (HCons (LVPair l v) r) (HCons l ls) (HCons v vs) where
record_r2p (Record (HCons f r)) = hExtend f (record_r2p (Record r))
record_p2r (RecordP (HCons v r)) = hExtend (LVPair v) (record_p2r (RecordP r))
labels_of_recordp :: RecordP ls vs -> ls
labels_of_recordp = undefined
instance (RecordR2P r ls vs, ShowComponents r, HRLabelSet r) =>
Show (RecordP ls vs) where show rp = show $ record_p2r rp
instance (HLabelSet (HCons l ls), HSameLength ls vs)
=> HExtend (LVPair l v) (RecordP ls vs) (RecordP (HCons l ls) (HCons v vs))
where
hExtend (LVPair v) (RecordP vs) = mkRecordP undefined (HCons v vs)
instance ( HLabelSet ls''
, HAppend ls ls' ls''
, HAppend vs vs' vs''
, HSameLength ls'' vs''
)
=> HAppend (RecordP ls vs) (RecordP ls' vs') (RecordP ls'' vs'')
where
hAppend (RecordP vs) (RecordP vs') = mkRecordP undefined (hAppend vs vs')
instance (HEq l l' b, HasFieldP' b l (RecordP (HCons l' ls) vs) v)
=> HasField l (RecordP (HCons l' ls) vs) v where
hLookupByLabel = hLookupByLabelP' (undefined::b)
class HasFieldP' b l r v | b l r -> v where
hLookupByLabelP' :: b -> l -> r -> v
instance HasFieldP' HTrue l (RecordP (HCons l ls) (HCons v vs)) v where
hLookupByLabelP' _ _ (RecordP (HCons v _)) = v
instance HasField l (RecordP ls vs) v
=> HasFieldP' HFalse l (RecordP (HCons l' ls) (HCons v' vs)) v where
hLookupByLabelP' _ l (RecordP (HCons _ vs)) =
hLookupByLabel l ((RecordP vs)::RecordP ls vs)
hDeleteAtLabelP :: HProjectByLabelP l ls vs lso v vso =>
l -> RecordP ls vs -> RecordP lso vso
hDeleteAtLabelP l r = snd $ h2ProjectByLabelP l r
hUpdateAtLabelP :: (HUpdateAtHNat n e1 t1 l', HFind e t n) => e -> e1 -> RecordP t t1 -> RecordP ls l'
hUpdateAtLabelP l v rp@(RecordP vs) = RecordP (hUpdateAtHNat n v vs)
where
n = hFind l (labels_of_recordp rp)
class HProjectByLabelP l ls vs lso v vso | l ls vs -> lso v vso where
h2ProjectByLabelP :: l -> RecordP ls vs -> (v,RecordP lso vso)
instance (HEq l l' b, HProjectByLabelP' b l (HCons l' ls) vs lso v vso)
=> HProjectByLabelP l (HCons l' ls) vs lso v vso where
h2ProjectByLabelP = h2ProjectByLabelP' (undefined::b)
class HProjectByLabelP' b l ls vs lso v vso | b l ls vs -> lso v vso where
h2ProjectByLabelP' :: b -> l -> RecordP ls vs -> (v,RecordP lso vso)
instance HProjectByLabelP' HTrue l (HCons l ls) (HCons v vs) ls v vs where
h2ProjectByLabelP' _ _ (RecordP (HCons v vs)) = (v,RecordP vs)
instance (HProjectByLabelP l ls vs lso' v vso')
=> HProjectByLabelP' HFalse l (HCons l' ls) (HCons v' vs)
(HCons l' lso') v (HCons v' vso') where
h2ProjectByLabelP' _ l (RecordP (HCons v' vs)) =
let (v,RecordP vso) = h2ProjectByLabelP l ((RecordP vs)::RecordP ls vs)
in (v, RecordP (HCons v' vso))
instance H2ProjectByLabels (HCons l ls)
(RecordP HNil HNil) (RecordP HNil HNil)
(RecordP HNil HNil)
where
h2projectByLabels _ _ = (emptyRecordP,emptyRecordP)
instance (HMember l' ls b,
H2ProjectByLabels' b ls (RecordP (HCons l' ls') vs') rin rout)
=> H2ProjectByLabels ls (RecordP (HCons l' ls') vs') rin rout where
h2projectByLabels = h2projectByLabels' (undefined::b)
instance H2ProjectByLabels ls (RecordP ls' vs') (RecordP lin vin) rout =>
H2ProjectByLabels' HTrue ls (RecordP (HCons l' ls') (HCons v' vs'))
(RecordP (HCons l' lin) (HCons v' vin)) rout where
h2projectByLabels' _ ls (RecordP (HCons v' vs')) =
(RecordP (HCons v' vin), rout)
where (RecordP vin,rout) =
h2projectByLabels ls ((RecordP vs')::RecordP ls' vs')
instance H2ProjectByLabels ls (RecordP ls' vs') rin (RecordP lo vo) =>
H2ProjectByLabels' HFalse ls (RecordP (HCons l' ls') (HCons v' vs'))
rin (RecordP (HCons l' lo) (HCons v' vo)) where
h2projectByLabels' _ ls (RecordP (HCons v' vs')) =
(rin, RecordP (HCons v' vo))
where (rin,RecordP vo) =
h2projectByLabels ls ((RecordP vs')::RecordP ls' vs')
instance H2ProjectByLabels ls' (RecordP ls vs) (RecordP ls' vs') rout
=> SubType (RecordP ls vs) (RecordP ls' vs')