> 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.RWS (RWS, evalRWS, liftM, put, get, tell)

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

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

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

> 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)

> 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)
