% 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 Control.Monad;
> import Data.Typeable;
> import Language.Haskell.TH;

\: 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