{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,
FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-}{-# OPTIONS_GHC -fno-warn-missing-signatures #-}{-
The HList library
(C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke
Extensible records
The are different models of labels that go with this module;
see the files Label?.hs.
-}moduleData.HList.RecordwhereimportData.HList.FakePreludeimportData.HList.HListPreludeimportData.HList.HArray{-----------------------------------------------------------------------------}-- Record types as label-value pairs, where label is purely phantom.-- Thus the run-time representation of a field is the same as that of-- its value, and the record, at run-time, is indistinguishable from-- the HList of field values. At run-time, all information about the-- labels is erased.-- Field of label l with value type vnewtypeLVPairlv=LVPair{valueLVPair::v}derivingEq-- Label accessorlabelLVPair::LVPairlv->llabelLVPair=undefinednewLVPair::l->v->LVPairlvnewLVPair_=LVPairnewtypeRecordr=RecordrderivingEq-- Build a recordmkRecord::HRLabelSetr=>r->RecordrmkRecord=Record-- Build an empty recordemptyRecord::RecordHNilemptyRecord=mkRecordHNil-- Propery of a proper label set for a record: no duplication of labelsclassHRLabelSetpsinstanceHRLabelSetHNilinstanceHRLabelSet(HConsxHNil)instance(HEql1l2leq,HRLabelSet'l1v1l2v2leqr)=>HRLabelSet(HCons(LVPairl1v1)(HCons(LVPairl2v2)r))classHRLabelSet'l1v1l2v2leqrinstance(HRLabelSet(HCons(LVPairl2v2)r),HRLabelSet(HCons(LVPairl1v1)r))=>HRLabelSet'l1v1l2v2HFalserinstance(Fail(DuplicatedLabell1))=>HRLabelSet'l1v1l2v2HTruer{-
instance (HZip ls vs ps, HLabelSet ls) => HRLabelSet ps
-}classHLabelSetlsinstanceHLabelSetHNilinstance(HMemberxlsxmem,HLabelSet'xlsxmem)=>HLabelSet(HConsxls)classHLabelSet'xlsxmeminstanceHLabelSetls=>HLabelSet'xlsHFalsedataDuplicatedLabell=DuplicatedLabellinstanceFail(DuplicatedLabelx)=>HLabelSet'xlsHTrue-- Construct the (phantom) list of labels of the record.-- This is a purely type-level function.classRecordLabelsrls|r->lsinstanceRecordLabelsHNilHNilinstanceRecordLabelsr'ls=>RecordLabels(HCons(LVPairlv)r')(HConslls)recordLabels'::RecordLabelsrls=>r->lsrecordLabels'r=undefinedrecordLabels::RecordLabelsrls=>Recordr->lsrecordLabels(Recordr)=recordLabels'r-- Construct the list of values of the record.classRecordValuesrls|r->lswhererecordValues'::r->lsinstanceRecordValuesHNilHNilwhererecordValues'_=HNilinstanceRecordValuesr'vs=>RecordValues(HCons(LVPairlv)r')(HConsvvs)whererecordValues'~(HCons(LVPairv)r')=HConsv(recordValues'r')recordValues::RecordValuesrvs=>Recordr->vsrecordValues(Recordr)=recordValues'r{-----------------------------------------------------------------------------}-- A Show instance to appeal to normal recordsinstanceShowComponentsr=>Show(Recordr)whereshow(Recordr)="Record{"++showComponents""r++"}"classShowComponentslwhereshowComponents::String->l->StringinstanceShowComponentsHNilwhereshowComponents_HNil=""instance(ShowLabell,Showv,ShowComponentsr)=>ShowComponents(HCons(LVPairlv)r)whereshowComponentscomma(HConsf@(LVPairv)r)=comma++showLabel(labelLVPairf)++"="++showv++showComponents","rclassShowLabellwhereshowLabel::l->String{-----------------------------------------------------------------------------}-- Extension for recordsinstanceHRLabelSet(HCons(LVPairlv)r)=>HExtend(LVPairlv)(Recordr)(Record(HCons(LVPairlv)r))wherehExtendf(Recordr)=mkRecord(HConsfr){-----------------------------------------------------------------------------}-- Record concatenationinstance(HRLabelSetr'',HAppendrr'r'')=>HAppend(Recordr)(Recordr')(Recordr'')wherehAppend(Recordr)(Recordr')=mkRecord(hAppendrr'){-----------------------------------------------------------------------------}-- Lookup operation-- This is a baseline implementation.-- We use a helper class, HasField, to abstract from the implementation.classHasFieldlrv|lr->vwherehLookupByLabel::l->r->v{-
instance ( RecordLabels r ls
, HFind l ls n
, HLookupByHNat n r (LVPair l v)
) => HasField l (Record r) v
where
hLookupByLabel l (Record r) = v
where
ls = recordLabels' r
n = hFind l ls
(LVPair v) = hLookupByHNat n r
-}-- Because hLookupByLabel is so frequent and important, we implement-- it separately, more efficiently. The algorithm is familiar assq, only-- the comparison operation is done at compile-timeinstanceHasFieldlrv=>HasFieldl(Recordr)vwherehLookupByLabell(Recordr)=hLookupByLabellrclassHasField'blrv|blr->vwherehLookupByLabel'::b->l->r->vinstance(HEqll'b,HasField'bl(HCons(LVPairl'v')r)v)=>HasFieldl(HCons(LVPairl'v')r)vwherehLookupByLabellr@(HConsf'_)=hLookupByLabel'(hEql(labelLVPairf'))lrinstanceHasField'HTruel(HCons(LVPairlv)r)vwherehLookupByLabel'__(HCons(LVPairv)_)=vinstanceHasFieldlrv=>HasField'HFalsel(HConsfldr)vwherehLookupByLabel'_l(HCons_r)=hLookupByLabellr{-----------------------------------------------------------------------------}-- Delete operationhDeleteAtLabell(Recordr)=Recordr'where(_,r')=h2projectByLabels(HConslHNil)r{-----------------------------------------------------------------------------}-- Update operationhUpdateAtLabellv(Recordr)=Recordr'wheren=hFindl(recordLabels'r)r'=hUpdateAtHNatn(newLVPairlv)r{-----------------------------------------------------------------------------}-- Projection for records-- It is also an important operation: the basis of many-- deconstructors -- so we try to implement it efficiently.hProjectByLabels::(HRLabelSeta,H2ProjectByLabelslstab)=>ls->Recordt->RecordahProjectByLabelsls(Recordr)=mkRecord(fst$h2projectByLabelslsr)hProjectByLabels2ls(Recordr)=(mkRecordrin,mkRecordrout)where(rin,rout)=h2projectByLabelslsr-- Invariant: r = rin `disjoint-union` rout-- labels(rin) = lsclassH2ProjectByLabelslsrrinrout|lsr->rinroutwhereh2projectByLabels::ls->r->(rin,rout)instanceH2ProjectByLabelsHNilrHNilrwhereh2projectByLabels_r=(HNil,r)instanceH2ProjectByLabels(HConslls)HNilHNilHNilwhereh2projectByLabels__=(HNil,HNil)instance(HMemberMl'(HConslls)b,H2ProjectByLabels'b(HConslls)(HCons(LVPairl'v')r')rinrout)=>H2ProjectByLabels(HConslls)(HCons(LVPairl'v')r')rinroutwhere-- h2projectByLabels = h2projectByLabels' (undefined::b)-- The latter is solely for the Hugs benefith2projectByLabelslsr@(HCons__)=h2projectByLabels'(undefined::b)lsr-- where b = hMember (labelLVPair f') lsclassH2ProjectByLabels'blsrrinrout|blsr->rinroutwhereh2projectByLabels'::b->ls->r->(rin,rout)instanceH2ProjectByLabelsls'r'rinrout=>H2ProjectByLabels'(HJustls')ls(HConsf'r')(HConsf'rin)routwhereh2projectByLabels'__(HConsxr)=(HConsxrin,rout)where(rin,rout)=h2projectByLabels(undefined::ls')rinstanceH2ProjectByLabelslsr'rinrout=>H2ProjectByLabels'HNothingls(HConsf'r')rin(HConsf'rout)whereh2projectByLabels'_ls(HConsxr)=(rin,HConsxrout)where(rin,rout)=h2projectByLabelslsr{-----------------------------------------------------------------------------}-- Rename the label of recordhRenameLabelll'r=r''wherev=hLookupByLabellrr'=hDeleteAtLabellrr''=hExtend(newLVPairl'v)r'{-----------------------------------------------------------------------------}-- A variation on update: type-preserving update.hTPupdateAtLabellvr=hUpdateAtLabellvrwherete::a->a->()te__=()_=tev(hLookupByLabellr){-
-- We could also say:
hTPupdateAtLabel l v r = hUpdateAtLabel l v r `asTypeOf` r
-- Then we were taking a dependency on Haskell's type equivalence.
-- This would also constrain the actual implementation of hUpdateAtLabel.
-}{-----------------------------------------------------------------------------}-- Subtyping for recordsinstance(RecordLabelsr'ls,H2ProjectByLabelslsrr'rout)=>SubType(Recordr)(Recordr'){-----------------------------------------------------------------------------}classHLeftUnionrr'r''|rr'->r''wherehLeftUnion::r->r'->r''instanceHLeftUnionr(RecordHNil)rwherehLeftUnionr_=rinstance(RecordLabelsrls,HMemberllsb,HLeftUnionBoolbr(LVPairlv)r''',HLeftUnion(Recordr''')(Recordr')r'')=>HLeftUnion(Recordr)(Record(HCons(LVPairlv)r'))r''wherehLeftUnion(Recordr)(Record(HConsfr'))=r''whereb=hMember(labelLVPairf)(recordLabels'r)r'''=hLeftUnionBoolbrfr''=hLeftUnion(Recordr''')(Recordr')classHLeftUnionBoolbrfr'|brf->r'wherehLeftUnionBool::b->r->f->r'instanceHLeftUnionBoolHTruerfrwherehLeftUnionBool_r_=rinstanceHLeftUnionBoolHFalserf(HConsfr)wherehLeftUnionBool_rf=HConsfr{-----------------------------------------------------------------------------}-- Compute the symmetric union of two records r1 and r2 and-- return the pair of records injected into the union (ru1, ru2).-- To be more precise, we compute the symmetric union _type_ ru-- of two record _types_ r1 and r2. The emphasis on types is important.-- The two records (ru1,ru2) in the result of unionSR have the same-- type ru, but they are generally different values.-- Here the simple example: suppose-- r1 = (Label .=. True) .*. emptyRecord-- r2 = (Label .=. False) .*. emptyRecord-- Then unionSR r1 r2 will return (r1,r2). Both components of the result-- are different records of the same type.-- To project from the union ru, use hProjectByLabels.-- It is possible to project from the union obtaining a record-- that was not used at all when creating the union.-- We do assure however that if (unionSR r1 r2) gave (r1u,r2u),-- then projecting r1u onto the type of r1 gives the _value_ identical-- to r1. Ditto for r2.classUnionSymRecr1r2ru|r1r2->ruwhereunionSR::r1->r2->(ru,ru)instanceUnionSymRecr1(RecordHNil)r1whereunionSRr1_=(r1,r1)instance(RecordLabelsr1ls,HMemberllsb,UnionSymRec'b(Recordr1)(LVPairlv)(Recordr2')ru)=>UnionSymRec(Recordr1)(Record(HCons(LVPairlv)r2'))ruwhereunionSRr1(Record(HConsfr2'))=unionSR'(undefined::b)r1f(Recordr2')classUnionSymRec'br1f2r2'ru|br1f2r2'->ruwhereunionSR'::b->r1->f2->r2'->(ru,ru)-- Field f2 is already in r1, so it will be in the union of r1-- with the rest of r2.-- To inject (HCons f2 r2) in that union, we should replace the-- field f2instance(UnionSymRecr1r2'(Recordru),HasFieldl2ruv2,HUpdateAtHNatn(LVPairl2v2)ruru,RecordLabelsruls,HFindl2lsn)=>UnionSymRec'HTruer1(LVPairl2v2)r2'(Recordru)whereunionSR'_r1(LVPairv2)r2'=(ul,ur')where(ul,ur)=unionSRr1r2'ur'=hTPupdateAtLabel(undefined::l2)v2urinstance(UnionSymRecr1r2'(Recordru),HExtendf2(Recordru)(Record(HConsf2ru)))=>UnionSymRec'HFalser1f2r2'(Record(HConsf2ru))whereunionSR'_r1f2r2'=(ul',ur')where(ul,ur)=unionSRr1r2'ul'=hExtendf2ulur'=hExtendf2ur{-----------------------------------------------------------------------------}-- Rearranges a record by labels. Returns the record r, rearranged such that-- the labels are in the order given by ls. (recordLabels r) must be a-- permutation of ls.hRearrange::(HLabelSetls,HRearrangelsrr')=>ls->Recordr->Recordr'hRearrangels(Recordr)=Record$hRearrange2lsr-- Helper class for hRearrangeclassHRearrangelsrr'|lsr->r'wherehRearrange2::ls->r->r'instanceHRearrangeHNilHNilHNilwherehRearrange2__=HNilinstance(H2ProjectByLabels(HConslHNil)rrinrout,HRearrange'llsrinroutr')=>HRearrange(HConslls)rr'wherehRearrange2~(HConslls)r=hRearrange2'llsrinroutwhere(rin,rout)=h2projectByLabels(HConslHNil)r-- Helper class 2 for hRearrangeclassHRearrange'llsrinroutr'|llsrinrout->r'wherehRearrange2'::l->ls->rin->rout->r'instanceHRearrangelsroutr'=>HRearrange'lls(HCons(LVPairlv)HNil)rout(HCons(LVPairlv)r')wherehRearrange2'_ls(HConslv@(LVPairv)HNil)rout=HCons(LVPairv`asTypeOf`lv)(hRearrange2lsrout)dataExtraFieldl=ExtraFielddataFieldNotFoundl=FieldNotFoundinstanceFail(FieldNotFoundl)=>HRearrange'llsHNilrout(FieldNotFoundl)wherehRearrange2'____=FieldNotFoundinstanceFail(ExtraFieldl)=>HRearrangeHNil(HCons(LVPairlv)a)(ExtraFieldl)wherehRearrange2__=ExtraField