    > module Haskore.General.GraphRecursiveGen where

    > import qualified Haskore.General.GraphTaggedGen as GTG
    > import qualified Haskore.General.TagDictionary as Dict
    > import Data.Traversable(Traversable)
    > import qualified Data.Traversable as Traversable

    > import Control.Monad.Trans.RWS (RWS, evalRWS, put, get, tell, )
    > import Control.Monad (liftM, )

This is a generalization of \module{Haskore.General.LoopTreeTaggedGen}. It adds a constructor for sharing interim results.

    > data T coll =
    >      Branch (coll (T coll))
    >    | Recurse (Fix (T coll)) -- function with a fix-point
    >    | Share (T coll) (T coll -> T coll)
    >                             -- share a sub-expression among deeper sub-expressions
    >    | Reference Tag          -- tag needed for resolving Recurse and Share by 'unwind'
    >
    > type Fix a = a -> a
    > type Tag   = Int

    > recourse :: Fix (T coll) -> T coll
    > recourse = Recurse

    > share :: (T coll) -> (T coll -> T coll) -> T coll
    > share = Share

Implement this one let x = f y y = g x in h x y with recursion, but without sharing: h (recourse (f . g)) (recourse (g . f)) with recursion of tuples: uncurry h $ recourse (\(x,y) -> (f y, g x)) with recursion and sharing: share (f y) (\x -> share (g x) (\y -> h x y)) -- wrong!

    > toTaggedUnique :: (Traversable coll) => Tag -> T coll -> GTG.T Tag coll
    > toTaggedUnique n branch = snd $ evalRWS (toTaggedState branch) () n

    > toTaggedState :: (Traversable coll) =>
    >    T coll -> RWS () (GTG.T Tag coll) Tag (GTG.Tree Tag coll)
    > toTaggedState branch =
    >    case branch of
    >       Branch x    ->  liftM GTG.Branch (Traversable.mapM toTaggedState x)
    >       Recurse fe  ->  do t <- get
    >                          put (succ t)
    >                          tree <- toTaggedState (fe (Reference t))
    >                          tell (Dict.singleton t tree)
    >                          return tree
    >       Share x fe  ->  do t <- get
    >                          put (succ t)
    >                          sharedTree <- toTaggedState x
    >                          tell (Dict.singleton t sharedTree)
    >                          toTaggedState (fe (Reference t))
    >       Reference t ->  return (GTG.Reference t)

    > {-
    > fromTagged :: (Eq tag, Functor coll) => GTG.T tag coll -> [T coll]
    > fromTagged =
    >    let aux branch =
    >           case branch of
    >              Branch x      -> Branch (fmap aux x)
    >              Reference tag -> fromMaybe
    >                                  (error ("unknown reference tag"))
    >                                  (lookup tag newDict)
    >        newDict = map (\(tag, tree) -> (tag, aux tree)) dict
    >    in  newDict

    >    let conv tags branch =
    >           case branch of
    >              GTG.Branch x   ->  Branch (fmap (conv tags) x)
    >              GTG.Tag tag x  ->  Recurse (\y -> conv
    >                                            (LTT.addUnique (tag,y) tags) x)
    >              GTG.Loop tag   ->  fromMaybe (error ("unknown loop tag"))
    >                                    (lookup tag tags)
    >    in  conv []
    > -}

    > instance (Traversable coll, GTG.CollEq coll) => Eq (T coll) where
    >   x == y  =  toTaggedUnique 0 x == toTaggedUnique 0 y
    >
    > instance (Traversable coll, GTG.CollShow coll) => Show (T coll) where
    >   showsPrec p x  =  showString "fromTagged " .
    >                     showParen (p>10) (showsPrec 11 (toTaggedUnique 0 x))

Unwinding, i.e. computing fixpoints:

    > unwind :: (Functor coll) => T coll -> T coll
    > unwind (Branch x)    = Branch (fmap unwind x)
    > unwind (Recurse fe)  = x where x = unwind (fe x)
    > unwind (Reference _) = error "unwind: no loop allowed in a tree"
    > unwind (Share x fe)  = fe (unwind x)