    {-# 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.
    --
    --
    -----------------------------------------------------------
    module Database.HaskellDB.HDBRec
        (
        -- * Record types
        RecNil(..), RecCons(..), Record
        -- * Record construction
        , emptyRecord, (.=.), ( # )
        -- * Labels
        , FieldTag(..)
        -- * Record predicates and operations
        , HasField, Select(..), SetField, setField
        , RecCat(..)
        -- * Showing and reading records
        , ShowLabels(..), ShowRecRow(..), ReadRecRow(..)
        ) where

    import Data.List

    infixr  5 #
    infix   6 .=.

    -- | The empty record.
    data RecNil = RecNil deriving (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.
    data RecCons f a b = RecCons a b deriving (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.
    type Record r = RecNil -> r

    -- * Record construction

    -- | Creates one-field record from a label and a value
    ( .=. ) :: l f a         -- ^ Label
           -> a              -- ^ Value
           -> Record (RecCons f a RecNil)  -- ^ New record
    _ .=. x = RecCons x

    -- | Adds the field from a one-field record to another record.
    ( # ) :: Record (RecCons f a RecNil) -- ^ Field to add
          -> (b -> c)                    -- ^ Rest of record
          -> (b -> RecCons f a c)        -- ^ New record
    f # r = let RecCons x _ = f RecNil in RecCons x . r

    -- | The empty record
    emptyRecord :: Record RecNil
    emptyRecord = id

    -- * Class definitions.

    -- | Class for field labels.
    class FieldTag f where
        -- | 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@.
    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)

    -- * Record concatenation

    class RecCat r1 r2 r3 | r1 r2 -> r3 where
        -- | Concatenates two records.
        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)

    -- * Field selection

    infix   9 !

    class Select f r a | f r -> a where
        -- | Field selection operator. It is overloaded so that
        --   users (read HaskellDB) can redefine it for things
        --   with phantom record types.
        (!) :: 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 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 instaces
    class SelectField f r a where
        -- | Gets the value of a field from a record.
        selectField :: f -- ^ Field label
    		-> r -- ^ Record
    		-> a -- ^ Field value

    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)

    -- * Field update

    setField :: SetField f r a => l f a -> a -> r -> r
    setField l = setField_ (labelType l)

    class SetField f r a where
        -- | Sets the value of a field in a record.
        setField_ :: f -- ^ Field label
    	     -> a -- ^ New field value
    	     -> r -- ^ Record
    	     -> r -- ^ New record

    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)

    -- * Equality and ordering

    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

    -- * Showing labels

    -- | Get the label name of a record entry.
    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)

    -- * Showing rows

    -- | Convert a record to a list of label names and field values.
    class ShowRecRow r where
        showRecRow :: r -> [(String,ShowS)]

    -- Last entry in each record will terminate the ShowrecRow recursion.
    instance ShowRecRow RecNil where
        showRecRow _ = []

    -- Recurse a record and produce a showable tuple.
    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)

    -- probably not terribly efficient
    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

    -- * Reading rows

    class ReadRecRow r where
        -- | Convert a list of labels and strins representating values
        --   to a record.
        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   -- ^ Dummy to get return type right
    	     -> [(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