% Extensible product types
% [Public domain]

\input birdstyle

\birdleftrule=1pt
\emergencystretch=1em

\def\hugebreak{\penalty-600\vskip 30pt plus 8pt minus 4pt\relax}
\newcount\chapno
\def\: #1.{\advance\chapno by 1\relax\hugebreak{\bf\S\the\chapno. #1. }}

\: Introduction. This module implements extensible product types, which
means you can have like a record, and add fields to this record even in
different modules. Dependent defaults are supported.

> {-# LANGUAGE FunctionalDependencies, GADTs, TypeFamilies #-}
> {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}

> module Data.Extensible.Product (
>   ExtProd, ExtProdC(..), ProdConstructor(..), emptyExtProd, getExtProd,
>   putExtProd, lensExtProd, constructExtProd
> ) where {

> import Control.Applicative;
> import Data.Hashable;
> import Data.HashMap.Lazy (HashMap);
> import qualified Data.HashMap.Lazy as H;
> import Data.Lens.Common;
> import Data.Typeable;
> import GHC.Exts (Any);
> import Unsafe.Coerce;

\: Implementation. It is implemented using a hash map, with types as keys.
For it to be extensible there has to be default values. It allows default
values to be based on a single value of the type that indexes the {\tt
ExtProd} type, which is used to tell what kind of record it is.

> data ExtProd p where {
>   ExtProd :: p -> HashMap FieldSelector Any -> ExtProd p;
> } deriving Typeable;

This implements hashable type representations in private, so that it will
not conflict with other modules.

> newtype FieldSelector = FieldSelector TypeRep deriving Eq;

> instance Hashable FieldSelector where {
>   hash (FieldSelector x) = hash (show x);
> };

Instances should ignore the value of the first parameter of the {\tt
defaultExtProd} method; it is used only for knowing the type (so it will
be OK to pass {\tt undefined} as the first parameter).

> class Typeable x => ExtProdC p x | x -> p where {
>   type ExtProdF x :: *;
>   defaultExtProd :: x -> p -> ExtProdF x;
> };

In addition, we will have a constructor-like datatype for extensible
products, which is similar to an extensible sum type, and can be used in
a list to construct a value of the type.

> data ProdConstructor p where {
>   (:*=) :: ExtProdC p x => x -> ExtProdF x -> ProdConstructor p;
> };

> infix 0 :*=;

\: Functions.

{\tt emptyExtProd}: Make a value of extensible product type with all
values set to the defaults.

> emptyExtProd :: p -> ExtProd p;
> emptyExtProd = flip ExtProd H.empty;

{\tt getExtProd}: Get the value of a field.

> getExtProd :: ExtProdC p x => ExtProd p -> x -> ExtProdF x;
> getExtProd (ExtProd p m) f = unsafeCoerce $ H.lookupDefault
>  (unsafeCoerce $ defaultExtProd f p) (FieldSelector $ typeOf f) m;

{\tt putExtProd}: Set the value of a field.

> putExtProd :: ExtProdC p x => ExtProd p -> x -> ExtProdF x -> ExtProd p;
> putExtProd (ExtProd p m) f v = ExtProd p $ H.insert
>  (FieldSelector $ typeOf f) (unsafeCoerce v) m;

{\tt lensExtProd}: Make a lens of an extensible product type.

> lensExtProd :: ExtProdC p x => x -> Lens (ExtProd p) (ExtProdF x);
> lensExtProd f = lens (flip getExtProd f) (\v x -> putExtProd x f v);

{\tt constructExtProd}: Construct a value of an extensible product type.

> constructExtProd :: p -> [ProdConstructor p] -> ExtProd p;
> constructExtProd p l = ExtProd p $ H.fromList (constructorToKV <$> l);

> constructorToKV :: ProdConstructor p -> (FieldSelector, Any);
> constructorToKV (k :*= v) = (FieldSelector $ typeOf k, unsafeCoerce v);

% End of document (final "}" is suppressed from printout)
\medskip\centerline{The End}
\toks0={{

> } -- }\bye