{-# LINE 1 "Generic.lhs" #-}
#line 1 "Generic.lhs"







{-# OPTIONS -XRankNTypes -XDeriveFunctor -XDeriveTraversable -XDeriveFoldable  -XTypeOperators -fwarn-incomplete-patterns  -XNoMonomorphismRestriction -XFlexibleInstances #-}

module Generic where

import Control.Applicative
import Data.Foldable hiding (concat, all, concatMap, foldl, fold, toList, and)
import Data.Traversable hiding (mapM, sequence)
import Control.Monad
import Control.Monad.Identity hiding (mfix, fix)


main = do
  putStr $ showGraph $ myTree
  putStr $ showGraph $ gmap modify $ myTree

myTree :: Graph (TreeF String)
myTree = Hide (Mu (\(~(t1:t2:t3:t4:_)) -> [
   Fork "Add" ((In (Fork "Sub" (Var t2) (In Empty)))) (Var t3),
   Fork "Mul" (Var t3) (Var t3),
   Fork "40"   (In Empty) (In Empty),
   Fork "X"   (In Empty) (In Empty)
   ]))

modify :: String -> String
modify "40" = "42"
modify x = x









instance Monad m => Monad (WrappedMonad m) where
  return x = WrapMonad (return x)
  (WrapMonad x) >>= f = WrapMonad (x >>= (unwrapMonad . f))

fix f = f (fix f)






















data Rec f a =
    Var a
 |  Mu ([a] -> [f (Rec f a)])
 |  In (f (Rec f a))

newtype Graph f = Hide {reveal :: forall a . Rec f a}











data StreamF a r = Cons a r
  deriving (Functor, Foldable, Traversable)

type Stream a = Graph (StreamF a)






onetwo = Hide (Mu (\(~(s:_)) ->
  [Cons 1 (In (Cons 2 (Var s)))]))




















data S a = C a (S a)

toS :: Stream a -> S a
toS = ptoS . reveal  where
  ptoS :: Rec (StreamF a) (S a) -> S a
  ptoS   (Var x)     = x
  ptoS   (Mu g)      = head $ fix (map ptoS' . g)
  ptoS   (In r)      = ptoS' r
  ptoS'  (Cons x xs)  = C x (ptoS xs)






data TreeF a r = Empty | Fork a r r
  deriving (Functor, Foldable, Traversable)

instance BiFunctor TreeF where
  bimap f g Empty = Empty
  bimap f g (Fork a r1 r2) = Fork (f a) (g r1) (g r2)

type Tree a = Graph (TreeF a)



















































gfold ::  Functor f =>  (t -> c) -> (([t] -> [c]) -> c) ->
                        (f c -> c) -> Graph f -> c
gfold v l f = trans . reveal where
  trans (Var x)   = v x
  trans (Mu g)    = l (map (f . fmap trans) . g)
  trans (In fa)   = f (fmap trans fa)

fold :: Functor f => (f c -> c) -> c -> Graph f -> c
fold alg k = gfold id (\g -> head (g (repeat k))) alg

cfold :: Functor f => (f t -> t) -> Graph f -> t
cfold = gfold id (head . fix)

sfold :: (Eq t, Functor f) => (f t -> t) -> t -> Graph f -> t
sfold alg k = gfold id (head . fixVal (repeat k)) alg

fixVal :: Eq a => a -> (a -> a) -> a
fixVal v f = if v==v' then v else fixVal v' f
    where v' = f v






































elems :: Stream a -> [a]
elems = fold streamf2list []

toList :: Stream a -> [a]
toList = cfold streamf2list

streamf2list :: StreamF a [a] -> [a]
streamf2list (Cons x xs) = x : xs














type f :-> g = forall a . f a -> g a

transform ::  (Functor f, Functor g) =>
              (f :-> g) -> Graph f -> Graph g
transform f x = Hide (hmap (reveal x)) where
   hmap (Var x)    = Var x
   hmap (Mu g)     = Mu (map (f . fmap hmap) . g)
   hmap (In x)     = In (f (fmap hmap x))



class BiFunctor f where
  bimap :: (a -> c) -> (b -> d) -> f a b -> f c d

gmap ::  (BiFunctor f, Functor (f a), Functor (f b)) =>
          (a -> b) -> Graph (f a) -> Graph (f b)
gmap f = transform (bimap f id)



pjoin :: Functor f => Rec f (Rec f a) -> Rec f a
pjoin (Var x)  = x
pjoin (Mu g)   = Mu (map (fmap pjoin) . g . map Var)
pjoin (In r)   = In (fmap pjoin r)



unrollGraph :: Functor f => Graph f -> Graph f
unrollGraph g = Hide (pjoin (unroll (reveal g)))

unroll :: Functor f => Rec f (Rec f a) -> Rec f (Rec f a)
unroll (Mu g)  = In (head (g (repeat (pjoin (Mu g)))))
unroll (In r)  = In (fmap unroll r)
unroll _       = undefined


















data VGraphF a = VNode String [a]
  deriving (Show, Functor, Foldable, Traversable)

type VGraph = Graph VGraphF

btree2vgraph :: Show a => Tree a -> VGraph
btree2vgraph = transform trans where
  trans Empty         = VNode "" []
  trans (Fork x l r)  = VNode (show x) [l,r]






















instance BiFunctor StreamF where
  bimap f g (Cons x y) = Cons (f x) (g y)



smap :: (a -> b) -> Stream a -> Stream b
smap f g = transform (mapStream f) g where
  mapStream :: (a -> b) -> StreamF a v -> StreamF b v
  mapStream f (Cons x xs) = Cons (f x) xs



hmapM :: (Monad m, Traversable f, Applicative m) => (forall a . m a -> a) -> (forall a . f a -> m (g a)) -> Rec f a -> m (Rec g a)
hmapM runM f (Var x) = return (Var x)
hmapM runM f (Mu g)  = return (Mu (runM . sequence . map (join . liftM f . traverse (hmapM runM f)) . g))
hmapM runM f (In x)  = (join $ liftM f $ traverse (hmapM runM f) x) >>= return . In

hmapM2 :: (Monad m, Traversable f, Applicative m) => (forall a . m a -> a) -> (f (Rec g a) -> m (g (Rec g a))) -> Rec f a -> m (Rec g a)
hmapM2 runM f (Var x) = return (Var x)
hmapM2 runM f (Mu g)  = return (Mu (runM . sequence . map (join . liftM f . traverse (hmapM2 runM f)) . g))
hmapM2 runM f (In x)  = (join $ liftM f $ traverse (hmapM2 runM f) x) >>= return . In




































eqGraph :: EqF f => Graph f -> Graph f -> Bool
eqGraph g1 g2 = eqRec 0 (reveal g1) (reveal g2)

eqRec :: EqF f => Int -> Rec f Int -> Rec f Int -> Bool
eqRec _  (Var x)  (Var y)  = x == y
eqRec n  (Mu g)   (Mu h)   =
  let  a      = g (iterate succ n)
       b      = h (iterate succ n)
  in and $ zipWith (eqF (eqRec (n + length a))) a b
eqRec n  (In x)   (In y)   = eqF (eqRec n) x y
eqRec _  _        _        = False





class Functor f => EqF f where
  eqF :: (r -> r -> Bool) -> f r -> f r -> Bool








instance Eq a => EqF (StreamF a) where
   eqF eq (Cons x xs) (Cons y ys) = x == y && eq xs ys







instance Eq a => EqF (TreeF a) where
   eqF eq Empty Empty                      = True
   eqF eq (Fork x1 l1 r1) (Fork x2 l2 r2)  = x1 == x2 && eq l1 l2 && eq r1 r2
   eqF eq _ _                              = False








showGraph :: ShowF f => Graph f -> String
showGraph g = showRec (iterate succ 'a') (reveal g)

showRec :: ShowF f => [Char] -> Rec f Char -> String
showRec _ (Var c)     = [c]
showRec seed (Mu f)   =
  let r            = f seed
      (fr, s')     = splitAt (length r) seed
  in "Mu (\n" ++ concat
     ["  "  ++ [a] ++ " => " ++ v ++ "\n" | (a,v) <-
            zip fr (map (showF (showRec s')) r)] ++ ")\n"
showRec seed (In fa)  = showF (showRec seed) fa







class Functor f => ShowF f where
  showF :: (r -> String) -> f r -> String








instance Show a => ShowF (StreamF a) where
  showF sh (Cons x xs) = show x ++ " : " ++ sh xs



instance Show a => ShowF (TreeF a) where
  showF sh Empty         = "Empty"
  showF sh (Fork x l r)  = "Fork " ++ show x ++
     "(" ++ sh l ++ ") (" ++ sh r ++ ")"





pp' :: Show a => TreeF a (Int -> String) -> Int -> String
pp' Empty = const "Empty"
pp' (Fork x l r) = \n-> if n==0 then "<...>" else "Fork " ++ show x ++ " (" ++ l (n-1) ++ ") (" ++ r (n-1) ++ ")"

pp :: Show a => Graph (TreeF a) -> String
pp = flip (cfold pp') 5



gcombine :: Functor f => (f a -> a) -> (f b -> b) -> f (a,b) -> (a,b)
gcombine alg1 alg2 x = (alg1 (fmap fst x), alg2 (fmap snd x))