container for different types, avoiding boiler plate

oleg@pobox.com oleg@pobox.com
Thu, 21 Aug 2003 18:52:54 -0700 (PDT)


You might also wish to look at the typed heaps, which have been
discussed here on many occasions. Given the constant piece of code in
the appendix (which does *not* depend on user types and can be put
into a separate, constant module) you can write

> data Gender = Masc | Fem | Neutr   deriving (Show)
> data Number = First | Second | Third deriving (Show)
>
> attrs = Cons Masc $ Cons Second $ Nil
>
> ggender attrs = (fetch undefined attrs) :: Gender
> gnumber attrs = (fetch undefined attrs) :: Number

As you can see, functions ggender and gnumber are so trivial that
hardly need to be declared at all. You can just use fetch
directly. There is no need for Maybe. In fact, if you attempt to fetch
a type that you didn't put into the attrs, you get a _compile-time_
error.

*Main> ggender attrs
Masc
*Main> gnumber attrs
Second

Updates are allowed as well:

*Main> let attrs' = alter Neutr attrs in (ggender attrs', gnumber attrs')
(Neutr,Second)


Appendix: the constant part of the code.
Flags used:
-fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances

> data Nil t r  = Nil
> data Cons t r = Cons t r
>
> class PList ntype vtype cdrtype where
>     cdr::   ntype vtype cdrtype -> cdrtype
>     empty:: ntype vtype cdrtype -> Bool
>     value:: ntype vtype cdrtype -> vtype
>   
> instance PList Nil vtype cdrtype where
>     empty = const True
>
> instance (PList n v r) => PList Cons v' (n v r) where
>      empty = const False
>      value (Cons v r) = v
>      cdr   (Cons v r) = r
>
> class TypeSeq t s where
>     type_index:: t -> s -> Int
>     fetch:: t -> s -> t
>     alter:: t -> s -> s
>   
> instance (PList Cons t r) => TypeSeq t (Cons t r) where
>     type_index _ _ = 0
>     fetch _ (Cons v _) = v
>     alter newv (Cons v r)  = Cons newv r
>   
> instance (PList Cons t' r', TypeSeq t r') => TypeSeq t (Cons t' r') where
>     type_index v s = 1 + (type_index v $ cdr s)
>     fetch v s = fetch v $ cdr s
>     alter newv (Cons v' r') = Cons v' $ alter newv r'