> module Haskore.General.LoopTreeRecursiveGen where

> import qualified Haskore.General.LoopTreeTaggedGen as LTTG
> import qualified Haskore.General.TagDictionary as Dict

> import Data.Traversable(Traversable)
> import qualified Data.Traversable as Traversable

> import Control.Monad.State(MonadState, evalState, liftM, put, get)

The Loop constructor should not be used by users.
It is only necessary for interim results of 'toTagged'.
With the type \code{data ListTree a b = ListTree a [b]},
a \type{LoopTreeRecursiveGen.T (ListTree a)}
is isomoprhic to \type{LoopTreeRecursive.T a}.
'Tag' is a fixed type instead of a type variable
since it is only needed for internal issues.

> data T coll =
>      Branch (coll (T coll))
>    | Recurse (Fix (T coll)) -- function with a fix-point
>    | Loop Tag               -- tag needed for resolving Recurse by 'unwind'
>
> type Fix a = a -> a
> type Tag   = Int

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

> toTagged :: (Functor coll) => Tag -> T coll -> LTTG.T Tag coll
> toTagged n branch =
>    case branch of
>       Branch x      ->  LTTG.Branch (fmap (toTagged n) x)
>       Recurse fe  ->  LTTG.Tag n (toTagged (succ n) (fe (Loop n)))
>       Loop m      ->  LTTG.Loop m

> toTaggedUnique :: (Traversable coll) => Tag -> T coll -> LTTG.T Tag coll
> toTaggedUnique n branch = evalState (toTaggedState branch) n

> toTaggedState :: (Traversable coll, Enum tag, MonadState tag m) =>
>    T coll -> m (LTTG.T tag coll)
> toTaggedState branch =
>    case branch of
>       Branch x      ->  liftM LTTG.Branch (Traversable.mapM toTaggedState x)
>       Recurse fe  ->  do n <- get
>                          put (succ n)
>                          liftM (LTTG.Tag n)
>                                (toTaggedState (fe (Loop $ fromEnum n)))
>       Loop m      ->  return (LTTG.Loop $ toEnum m)

> fromTagged :: (Functor coll) => LTTG.T Tag coll -> T coll
> fromTagged =
>    let conv tags branch =
>           case branch of
>              LTTG.Branch x     ->  Branch (fmap (conv tags) x)
>              LTTG.Tag tag x  ->  Recurse (\y -> conv
>                                            (Dict.insert tag y tags) x)
>              LTTG.Loop tag   ->  Dict.lookup tags tag
>    in  conv Dict.empty


> instance (Functor coll, LTTG.CollEq coll) => Eq (T coll) where
>   x == y  =  toTagged 0 x == toTagged 0 y
>
> instance (Functor coll, LTTG.CollShow coll) => Show (T coll) where
>   showsPrec p x  =  showString "fromTagged " .
>                     showParen (p>10) (showsPrec 11 (toTagged 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 (Loop _)      = error "unwind: no loop allowed in a tree"