module Database.HaskellDB.HDBRec
(
RecNil(..), RecCons(..), Record
, emptyRecord, (.=.), ( # )
, FieldTag(..)
, HasField, Select(..), SetField, setField
, RecCat(..)
, ShowLabels(..), ShowRecRow(..), ReadRecRow(..)
) where
import Data.List
infixr 5 #
infix 6 .=.
data RecNil = RecNil deriving (Eq, Ord)
data RecCons f a b = RecCons a b deriving (Eq, Ord)
type Record r = RecNil -> r
( .=. ) :: l f a
-> a
-> Record (RecCons f a RecNil)
_ .=. x = RecCons x
( # ) :: Record (RecCons f a RecNil)
-> (b -> c)
-> (b -> RecCons f a c)
f # r = let RecCons x _ = f RecNil in RecCons x . r
emptyRecord :: Record RecNil
emptyRecord = id
class FieldTag f where
fieldName :: f -> String
class HasField f r
instance HasField f (RecCons f a r)
instance HasField f r => HasField f (RecCons g a r)
instance HasField f r => HasField f (Record r)
class RecCat r1 r2 r3 | r1 r2 -> r3 where
recCat :: r1 -> r2 -> r3
instance RecCat RecNil r r where
recCat ~RecNil r = r
instance RecCat r1 r2 r3 => RecCat (RecCons f a r1) r2 (RecCons f a r3) where
recCat ~(RecCons x r1) r2 = RecCons x (recCat r1 r2)
instance RecCat r1 r2 r3 => RecCat (Record r1) (Record r2) (Record r3) where
recCat r1 r2 = \n -> recCat (r1 n) (r2 n)
infix 9 !
class Select f r a | f r -> a where
(!) :: r -> f -> a
instance SelectField f r a => Select (l f a) (Record r) a where
(!) r l = selectField (labelType l) r
labelType :: l f a -> f
labelType _ = undefined
class SelectField f r a where
selectField :: f
-> r
-> a
instance SelectField f (RecCons f a r) a where
selectField _ ~(RecCons x _) = x
instance SelectField f r a => SelectField f (RecCons g b r) a where
selectField f ~(RecCons _ r) = selectField f r
instance SelectField f r a => SelectField f (Record r) a where
selectField f r = selectField f (r RecNil)
setField :: SetField f r a => l f a -> a -> r -> r
setField l = setField_ (labelType l)
class SetField f r a where
setField_ :: f
-> a
-> r
-> r
instance SetField f (RecCons f a r) a where
setField_ _ y ~(RecCons _ r) = RecCons y r
instance SetField f r a => SetField f (RecCons g b r) a where
setField_ l y ~(RecCons f r) = RecCons f (setField_ l y r)
instance SetField f r a => SetField f (Record r) a where
setField_ f y r = \e -> setField_ f y (r e)
instance Eq r => Eq (Record r) where
r1 == r2 = r1 RecNil == r2 RecNil
instance Ord r => Ord (Record r) where
r1 <= r2 = r1 RecNil <= r2 RecNil
consFieldName :: FieldTag f => RecCons f a r -> String
consFieldName = fieldName . consFieldType
consFieldType :: RecCons f a r -> f
consFieldType _ = undefined
class ShowLabels r where
recordLabels :: r -> [String]
instance ShowLabels RecNil where
recordLabels _ = []
instance (FieldTag f,ShowLabels r) => ShowLabels (RecCons f a r) where
recordLabels ~x@(RecCons _ r) = consFieldName x : recordLabels r
instance ShowLabels r => ShowLabels (Record r) where
recordLabels r = recordLabels (r RecNil)
class ShowRecRow r where
showRecRow :: r -> [(String,ShowS)]
instance ShowRecRow RecNil where
showRecRow _ = []
instance (FieldTag a,
Show b,
ShowRecRow c) => ShowRecRow (RecCons a b c) where
showRecRow ~r@(RecCons x fs) = (consFieldName r, shows x) : showRecRow fs
instance ShowRecRow r => ShowRecRow (Record r) where
showRecRow r = showRecRow (r RecNil)
instance Show r => Show (Record r) where
showsPrec x r = showsPrec x (r RecNil)
showsShowRecRow :: ShowRecRow r => r -> ShowS
showsShowRecRow r = shows $ [(f,v "") | (f,v) <- showRecRow r]
instance Show RecNil where
showsPrec _ r = showsShowRecRow r
instance (FieldTag a, Show b, ShowRecRow c) => Show (RecCons a b c) where
showsPrec _ r = showsShowRecRow r
class ReadRecRow r where
readRecRow :: [(String,String)] -> [(r,[(String,String)])]
instance ReadRecRow RecNil where
readRecRow xs = [(RecNil,xs)]
instance (FieldTag a,
Read b,
ReadRecRow c) => ReadRecRow (RecCons a b c) where
readRecRow [] = []
readRecRow xs = let res = readRecEntry xs (fst $ head res) in res
readRecEntry :: (Read a, FieldTag f, ReadRecRow r) =>
[(String,String)]
-> RecCons f a r
-> [(RecCons f a r,[(String,String)])]
readRecEntry ((f,v):xs) r | f == consFieldName r = res
| otherwise = []
where
res = [(RecCons x r, xs') | (x,"") <- reads v,
(r,xs') <- readRecRow xs]
readsReadRecRow :: ReadRecRow r => ReadS r
readsReadRecRow s = [(r,leftOver) | (l,leftOver) <- reads s, (r,[]) <- readRecRow l]
instance ReadRecRow r => Read (Record r) where
readsPrec _ s = [(const r, rs) | (r,rs) <- readsReadRecRow s]
instance Read RecNil where
readsPrec _ = readsReadRecRow
instance (FieldTag a, Read b, ReadRecRow c) => Read (RecCons a b c) where
readsPrec _ s = readsReadRecRow s