{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies
, TypeSynonymInstances, FlexibleInstances, UndecidableInstances
, OverlappingInstances #-}------------------------------------------------------------- |-- Module : HDBRec-- Copyright : HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net-- License : BSD-style-- -- Maintainer : haskelldb-users@lists.sourceforge.net-- Stability : experimental-- Portability : non-portable-- -- This is a replacement for some of TREX.---- -----------------------------------------------------------moduleDatabase.HaskellDB.HDBRec(-- * Record typesRecNil(..),RecCons(..),Record-- * Record construction,emptyRecord,(.=.),(#)-- * Labels,FieldTag(..)-- * Record predicates and operations,HasField,Select(..),SetField,setField,RecCat(..)-- * Showing and reading records,ShowLabels(..),ShowRecRow(..),ReadRecRow(..))whereimportData.Listinfixr5#infix6.=.-- | The empty record.dataRecNil=RecNilderiving(Eq,Ord)-- | Constructor that adds a field to a record.-- f is the field tag, a is the field value and b is the rest of the record.dataRecConsfab=RecConsabderiving(Eq,Ord)-- | The type used for records. This is a function-- that takes a 'RecNil' so that the user does not have to -- put a 'RecNil' at the end of every record.typeRecordr=RecNil->r-- * Record construction-- | Creates one-field record from a label and a value(.=.)::lfa-- ^ Label->a-- ^ Value->Record(RecConsfaRecNil)-- ^ New record_.=.x=RecConsx-- | Adds the field from a one-field record to another record.(#)::Record(RecConsfaRecNil)-- ^ Field to add->(b->c)-- ^ Rest of record->(b->RecConsfac)-- ^ New recordf#r=letRecConsx_=fRecNilinRecConsx.r-- | The empty recordemptyRecord::RecordRecNilemptyRecord=id-- * Class definitions.-- | Class for field labels.classFieldTagfwhere-- | Gets the name of the label.fieldName::f->String-- | The record @r@ has the field @f@ if there is an instance of-- @HasField f r@.classHasFieldfrinstanceHasFieldf(RecConsfar)instanceHasFieldfr=>HasFieldf(RecConsgar)instanceHasFieldfr=>HasFieldf(Recordr)-- * Record concatenationclassRecCatr1r2r3|r1r2->r3where-- | Concatenates two records.recCat::r1->r2->r3instanceRecCatRecNilrrwhererecCat~RecNilr=rinstanceRecCatr1r2r3=>RecCat(RecConsfar1)r2(RecConsfar3)whererecCat~(RecConsxr1)r2=RecConsx(recCatr1r2)instanceRecCatr1r2r3=>RecCat(Recordr1)(Recordr2)(Recordr3)whererecCatr1r2=\n->recCat(r1n)(r2n)-- * Field selectioninfix9!classSelectfra|fr->awhere-- | Field selection operator. It is overloaded so that-- users (read HaskellDB) can redefine it for things-- with phantom record types.(!)::r->f->ainstanceSelectFieldfra=>Select(lfa)(Recordr)awhere(!)rl=selectField(labelTypel)rlabelType::lfa->flabelType_=undefined-- | Class which does the actual work of -- getting the value of a field from a record.-- FIXME: would like the dependency f r -> a here, but-- that makes Hugs complain about conflicting instacesclassSelectFieldfrawhere-- | Gets the value of a field from a record.selectField::f-- ^ Field label->r-- ^ Record ->a-- ^ Field valueinstanceSelectFieldf(RecConsfar)awhereselectField_~(RecConsx_)=xinstanceSelectFieldfra=>SelectFieldf(RecConsgbr)awhereselectFieldf~(RecCons_r)=selectFieldfrinstanceSelectFieldfra=>SelectFieldf(Recordr)awhereselectFieldfr=selectFieldf(rRecNil)-- * Field updatesetField::SetFieldfra=>lfa->a->r->rsetFieldl=setField_(labelTypel)classSetFieldfrawhere-- | Sets the value of a field in a record.setField_::f-- ^ Field label->a-- ^ New field value->r-- ^ Record->r-- ^ New recordinstanceSetFieldf(RecConsfar)awheresetField__y~(RecCons_r)=RecConsyrinstanceSetFieldfra=>SetFieldf(RecConsgbr)awheresetField_ly~(RecConsfr)=RecConsf(setField_lyr)instanceSetFieldfra=>SetFieldf(Recordr)awheresetField_fyr=\e->setField_fy(re)-- * Equality and orderinginstanceEqr=>Eq(Recordr)wherer1==r2=r1RecNil==r2RecNilinstanceOrdr=>Ord(Recordr)wherer1<=r2=r1RecNil<=r2RecNil-- * Showing labels-- | Get the label name of a record entry.consFieldName::FieldTagf=>RecConsfar->StringconsFieldName=fieldName.consFieldTypeconsFieldType::RecConsfar->fconsFieldType_=undefinedclassShowLabelsrwhererecordLabels::r->[String]instanceShowLabelsRecNilwhererecordLabels_=[]instance(FieldTagf,ShowLabelsr)=>ShowLabels(RecConsfar)whererecordLabels~x@(RecCons_r)=consFieldNamex:recordLabelsrinstanceShowLabelsr=>ShowLabels(Recordr)whererecordLabelsr=recordLabels(rRecNil)-- * Showing rows -- | Convert a record to a list of label names and field values.classShowRecRowrwhereshowRecRow::r->[(String,ShowS)]-- Last entry in each record will terminate the ShowrecRow recursion.instanceShowRecRowRecNilwhereshowRecRow_=[]-- Recurse a record and produce a showable tuple.instance(FieldTaga,Showb,ShowRecRowc)=>ShowRecRow(RecConsabc)whereshowRecRow~r@(RecConsxfs)=(consFieldNamer,showsx):showRecRowfsinstanceShowRecRowr=>ShowRecRow(Recordr)whereshowRecRowr=showRecRow(rRecNil)instanceShowr=>Show(Recordr)whereshowsPrecxr=showsPrecx(rRecNil)-- probably not terribly efficientshowsShowRecRow::ShowRecRowr=>r->ShowSshowsShowRecRowr=shows$[(f,v"")|(f,v)<-showRecRowr]instanceShowRecNilwhereshowsPrec_r=showsShowRecRowrinstance(FieldTaga,Showb,ShowRecRowc)=>Show(RecConsabc)whereshowsPrec_r=showsShowRecRowr-- * Reading rowsclassReadRecRowrwhere-- | Convert a list of labels and strins representating values-- to a record.readRecRow::[(String,String)]->[(r,[(String,String)])]instanceReadRecRowRecNilwherereadRecRowxs=[(RecNil,xs)]instance(FieldTaga,Readb,ReadRecRowc)=>ReadRecRow(RecConsabc)wherereadRecRow[]=[]readRecRowxs=letres=readRecEntryxs(fst$headres)inresreadRecEntry::(Reada,FieldTagf,ReadRecRowr)=>[(String,String)]->RecConsfar-- ^ Dummy to get return type right->[(RecConsfar,[(String,String)])]readRecEntry((f,v):xs)r|f==consFieldNamer=res|otherwise=[]whereres=[(RecConsxr,xs')|(x,"")<-readsv,(r,xs')<-readRecRowxs]readsReadRecRow::ReadRecRowr=>ReadSrreadsReadRecRows=[(r,leftOver)|(l,leftOver)<-readss,(r,[])<-readRecRowl]instanceReadRecRowr=>Read(Recordr)wherereadsPrec_s=[(constr,rs)|(r,rs)<-readsReadRecRows]instanceReadRecNilwherereadsPrec_=readsReadRecRowinstance(FieldTaga,Readb,ReadRecRowc)=>Read(RecConsabc)wherereadsPrec_s=readsReadRecRows