{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTSyntax, 
             KindSignatures, InstanceSigs #-}
{-# OPTIONS -Wall #-}
module RecTypes where
    

-- The initial algebra
type Mu (f :: * -> *) = forall a. (f a -> a) -> a

-- A list of integers
-- ListF k = 1 + (Int * k)
data ListF k where
    NilF :: ListF k
    ConsF :: Int -> k -> ListF k
type List = Mu ListF

nil :: List
nil x = x NilF 

cons :: Int -> List -> List
cons i l x = x (ConsF i (l x))

-- add10 :: List -> List
add10 :: forall a. List -> (ListF a -> a) -> a
add10 l x = l x'
   where    -- Note:  x  :: ListF a -> a
   x' :: ListF a -> a
   x' NilF = x NilF
   x' (ConsF i l2) = x (ConsF (i+10) l2)

             
-----------------------------
-- A list, again

type List2 = forall a. a -> (Int -> a -> a) -> a

nil2 :: List2
nil2 n _c = n

cons2 :: Int -> List2 -> List2
cons2 i l n c = c i (l n c)

-- A function which adds 10 to every list element
-- c  1 (c  2 (c  3 n ))
--  ==>
-- c' 1 (c' 2 (c' 3 n'))
--   where n' = n , c' i l2 = c (i+10) l2
add10bis :: List2 -> List2
add10bis l n c = l n' c'
   where
   n' = n
   c' i l2 = c (i+10) l2

-- Exercises:
-- 1) define an encoding for the tree-of-integers type
-- 2) define a function which adds 10 to every integer in the tree
-- 3) define a function which "flips" the left and right subtrees, at any
--    point in the tree

-- A conversion to the built-in Haskell lists
toHaskellList :: List2 -> [Int]
toHaskellList l = l [] (:)

-- List3 is isomorphic to List2
newtype List3 = List3 List2

instance Show List3 where
    show (List3 l) = show (toHaskellList l)
    
-- A "tail" function
--  List -> 1 + (Int * List)
--  ~ List -> Maybe (Int * List)
-- tail nil        = inl ()
-- tail (cons i l) = inr (i,l)
tailList :: List3 -> Maybe (Int, List3)
tailList (List3 l) = l n c
   where
   n :: Maybe (Int, List3)
   n = Nothing
   c :: Int -> Maybe (Int, List3) -> Maybe (Int, List3)
   c i Nothing              = Just (i, List3 nil2)
   c i (Just (j, List3 l2)) = Just (i, List3 (cons2 j l2))

--------------------------------------------------------------------
--------------------------------------------------------------------

-- A type isomorphic to Mu f
newtype Mu2 f = Mu2 (Mu f)

-- The isomorphism is Mu2 :: Mu f -> Mu2 f 
-- which has inverse
unMu2 :: Mu2 f -> Mu f
unMu2 (Mu2 x) = x

-- We now write the isomorphism
--    f (Mu f) -> Mu f
--    Mu f -> f (Mu f)

iso :: Functor f => f (Mu2 f) -> Mu2 f
iso x = Mu2 (\g -> g (fmap (\y -> unMu2 y g) x))

osi :: Functor f => Mu2 f -> f (Mu2 f)
osi x = unMu2 x (fmap iso)

-------------------------------------------------------------------
-------------------------------------------------------------------

-- Constructing a fixed point combinator from contravariant type-level
-- recursion.

-- R a ~= (R a -> a)
data R a where
    R :: (R a -> a) -> R a

-- The isomorphism is R :: (R a -> a) -> R a
-- with inverse
unR :: R a -> (R a -> a)
unR (R x) = x

-- We start by defining a sel-apply operator, similar to
--   \x . x x
-- in the untyped lambda calculus
selfApply :: R a -> a
selfApply x = unR x x

-- We can now construct Church's Y combinator
--   \f. (\w . f (w w)) (\w . f (w w))
churchY :: forall a. (a -> a) -> a
churchY f = selfApply g
   where
   g :: R a
   g = R (\w -> f (selfApply w))

-- Let's check that it works!
fact :: Int -> Int
fact = churchY f
   where
   f :: (Int -> Int) -> (Int -> Int)
   f h = \n -> if n==0 then 1 else n * h (n-1)