> 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))
> | Loop Tag
>
> 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"