-- Functions for separate. Patrik Jansson, July 18, 1999
--  (a self-contained polytypic example)
import PolyLib.Prelude
{-
The default starting point for code generation in a PolyP file is the
  value main. Everything possibly reachable from main is instantiated.
  In this case we choose to test separate on a list, a tree and a rose
  tree.
-}
main = print ( separate "1738"
             , separate (Leaf 'a')
             , separate (Fork True [Fork False [],Fork True []])
             )

{-

The triple printed by main is equal to answer.

-}

answer = ( ([(),(),(),()],"1738")
         , (Leaf (),"a")
         , (Fork () [Fork () [],Fork () []],[True,False,True])
         )

{-
User defined (and pre-defined) regular datatypes with one type
  parameter can be used as arguments to polytypic functions.
-}
data Tree a = Leaf a | Bin (Tree a) (Tree a) deriving Show
data Rose a = Fork a [Rose a] deriving Show
{-
Function separate takes an element of a regular datatype (of type d a)
  and generates a pair. The first component of the pair is just the
  structure of the datatype without the contents (of type d ()) and
  the second component is just the contents without the structure (of
  type [a]).
-}
separate :: Regular d => d a -> (d (), [a])
separate x = (pmap (const ()) x,flatten x)
{-
The definition of pmap is taken from ../polylib/Base.phs.
-}
pmap :: Regular d => (a -> b) -> d a -> d b
pmap f   = inn . fmap2 f  (pmap f)   . out

polytypic fmap2 :: (a -> c) -> (b -> d) -> f a b -> f c d
  = \p r -> case f of
              g + h   ->  (fmap2 p r) -+- (fmap2 p r)
              g * h   ->  (fmap2 p r) -*- (fmap2 p r)
              Empty   ->  \EmptyF -> EmptyF
              Par     ->  ParF . p . unParF
              Rec     ->  RecF . r . unRecF
              d @ g   ->  CompF . pmap (fmap2 p r) . unCompF
              Const t ->  \(ConstF x) -> ConstF x

{-
The definition of flatten is taken from ../polylib/Flatten.phs.
-}
flatten :: Regular d => d a -> [a]
flatten  =  fflatten . fmap2 singleton flatten . out

{-
-- Alternative deinition in terms of a catamorphism:
flatten  =  cata (fflatten . fmap2 singleton id)
cata :: Regular d => (FunctorOf d a b -> b) -> (d a -> b)
cata i   = i   . fmap2 id (cata i  ) . out
-}

polytypic fflatten :: f [a] [a] -> [a]
  = case f of
      g + h     ->  fflatten `foldSum` fflatten
      g * h     ->  \(x :*: y) -> fflatten x ++ fflatten y
      Empty     ->  nil
      Par       ->  unParF
      Rec       ->  unRecF
      d @ g     ->  concat . flatten . pmap fflatten . unCompF
      Const t   ->  nil

{- Help functions for lists -}

singleton :: a -> [a]
singleton    x =  [x]
nil :: a -> [b]
nil    x =  []