% Extensible trees % [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 compile-time trees. Each node has a key, and the key of each node is of a different type. All nodes have the same type for the value of the nodes, however. In addition, the values of the nodes can depend on the value of the key.
> {-# LANGUAGE MultiParamTypeClasses, GADTs, TemplateHaskell #-}
> {-# LANGUAGE FunctionalDependencies #-}

> module Data.Extensible.Tree (
>   ExtTreeData(..), ExtTree(..), traceExtTree, normalParent, makeExtRoot,
>   ExtTreeNode(..), extAncestor, extAncestorAny
> ) where {

> import Control.Applicative;
> import Data.Typeable;

\: Utility Function.
> bool :: x -> x -> Bool -> x;
> bool x _ False = x;
> bool _ x True = x;

\: Implementation. The first thing is a datatype used for the class which is defined below. Due to the GADT, it requires that the parent of a node also has a parent; if it is the root node you set it to its own parent.
> data ExtTreeData v p c where {
>   ExtRoot :: ExtTree v p p => ExtTreeData v p p;
>   ExtNode :: ExtTree v pp p => (c -> (v, p)) -> ExtTreeData v p c;
> };

In this class, {\tt v} is the type of values in the tree, {\tt p} is the parent of this node, and {\tt c} (for child'') is the current node. The first method is used for traversing the tree from child to parent, and the second method is used for traversing the tree from parent to child.
> class Typeable c => ExtTree v p c | c -> p, p -> v where {
>   treeData :: ExtTreeData v p c;
>   normalChild :: p -> c;
> };

For the root node, the instance should always be:
> {-
>   treeData = ExtRoot;
>   normalChild = id;
> -}

The next section contains a Template Haskell code to automatically create the instance for the root node. There is then a datatype which holds any key for a single node of a tree.
> data ExtTreeNode v where {
>   ExtTreeNode :: ExtTree v p c => c -> ExtTreeNode v;
> };

But, notice that there can be multiple roots, and a root does not even have to be exposed from a module which defines it, as long as there is some node which eventually leads to it. \: Functions. {\tt traceExtTree}: Make a list of values from a single node to the root.
> traceExtTree :: ExtTree v p c => c -> [v];
> traceExtTree c = case treeData of {
>   ExtRoot -> [];
>   ExtNode f -> (\(v, p) -> v : traceExtTree p) $f c; > };  {\tt normalParent}: Given a value of a key for one node of the tree, get the corresponding value of the type of key for the parent node. > normalParent :: ExtTree v p c => c -> p; > normalParent c = case treeData of { > ExtRoot -> c; > ExtNode f -> snd (f c); > };  {\tt extAncestor}: Find the key of an ancestor of a specified node. > extAncestor :: (Typeable p, ExtTree v pp c) => c -> Maybe p; > extAncestor c = cast c <|> case treeData of { > ExtRoot -> Nothing; > ExtNode f -> extAncestor$ snd (f c);
> };

{\tt extAncestorAny}: Like the above function, but in a container storing a key of any node.
> extAncestorAny :: Typeable p => ExtTreeNode v -> Maybe p;
> extAncestorAny (ExtTreeNode c) = extAncestor c;

Here is a Template Haskell macro to create the instance for the root node. Due to some fault with parsing of Template Haskell quotations, this won't compile unless both {\tt FlexibleInstances} and {\tt UndecidableInstances} extensions are enabled in this module. (You do not need to enable those extensions in the module using this function.)
> makeExtRoot :: Q Type -> Q Type -> Q [Dec];
> makeExtRoot = liftM2 $\v p -> [InstanceD [] ( > AppT (AppT (AppT (ConT ''ExtTree) v) p) p > ) [ > ValD (VarP 'treeData) (NormalB$ ConE 'ExtRoot) [],
>   ValD (VarP 'normalChild) (NormalB \$ VarE 'id) []
> ]];

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