{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTSyntax, 
             KindSignatures, InstanceSigs #-}
{-# OPTIONS -Wall #-}
module RecTypes where
    
data Exp where
    Lit :: Int -> Exp
    Plus :: Exp -> Exp -> Exp
    Minus :: Exp -> Exp -> Exp

-- The expression (2 + (10 - 7))             
testExp :: Exp
testExp = Plus (Lit 2) (Minus (Lit 10) (Lit 7))

-- The semantics of expressions               
semExp :: Exp -> Int
semExp (Lit n) = n
semExp (Plus e1 e2) = semExp e1 + semExp e2
semExp (Minus e1 e2) = semExp e1 - semExp e2

-- A fold for the Exp type                       
foldExp :: (Int -> a) -> (a -> a -> a) -> (a -> a -> a) -> Exp -> a
foldExp lit _plus _minus (Lit n) = lit n
foldExp lit plus minus (Plus e1 e2) =
    plus (foldExp lit plus minus e1) (foldExp lit plus minus e2)
foldExp lit plus minus (Minus e1 e2) =
    minus (foldExp lit plus minus e1) (foldExp lit plus minus e2)

-- The semantics, again, of expressions, now it terms of the fold     
semExp2 :: Exp -> Int
semExp2 e = foldExp id (+) (-) e
          
-------------------------------------------------------------------
          
-- The fixed point operator, on types.
-- Here, f is a "function from types to types"
newtype Fix (f :: * -> *) = Fix (f (Fix f))

-- Fix :: f (Fix f) -> Fix f
-- with inverse
unFix :: Fix f -> f (Fix f)
unFix (Fix x) = x

-- ExpF k = (Int + k*k + k*k)
-- is the type-level "function" over which we want to take the fixed point!
data ExpF :: * -> * where
    LitF :: Int -> ExpF k
    PlusF :: k -> k -> ExpF k
    MinusF :: k -> k -> ExpF k

instance Functor ExpF where
    fmap :: (a -> b) -> ExpF a -> ExpF b
    fmap _f (LitF n) = LitF n
    fmap f  (PlusF x1 x2) = PlusF (f x1) (f x2)
    fmap f  (MinusF x1 x2) = MinusF (f x1) (f x2)
              
type ExpFix = Fix ExpF

-- Again, (2 + (10 - 7))
testExpFix :: ExpFix
testExpFix = Fix (PlusF (Fix (LitF 2))
                        (Fix (MinusF (Fix (LitF 10)) (Fix (LitF 7)))))

-- The semantics of expressions ExpFix               
semExpFix :: ExpFix -> Int
semExpFix (Fix (LitF n)) = n
semExpFix (Fix (PlusF e1 e2)) = semExpFix e1 + semExpFix e2
semExpFix (Fix (MinusF e1 e2)) = semExpFix e1 - semExpFix e2
             
-- Exercise: write foldExpFix

-- For any algebra, construct the unique morphism from the
-- initial algebra (Fix f)
cata :: Functor f => (f a -> a) -> (Fix f -> a)
cata g = g . fmap (cata g) . unFix

semExpFix2 :: ExpFix -> Int
semExpFix2 e = cata g e
   where
   g :: ExpF Int -> Int
   g (LitF n) = n
   g (PlusF n1 n2)  = n1 + n2
   g (MinusF n1 n2) = n1 - n2

-- For the lists (of Int)
-- ListF k = 1 + Int * k
data ListF :: * -> * where
   NilF :: ListF k
   ConsF :: Int -> k -> ListF k
type ListFix = Fix ListF
            
instance Functor ListF where
    fmap :: (a -> b) -> ListF a -> ListF b
    fmap _f NilF = NilF
    fmap f  (ConsF n x) = ConsF n (f x)

-- foldList f a (Cons x1 (Cons x2 .... Nil))
--            = (f    x1 (f    x2 .... a  ))
-- foldList :: (Int -> t -> t) -> t -> ListInt -> t
-- foldList _ a Nil = a
-- foldList f a (Cons x xs) = f x (foldList f a xs)

foldList :: (ListF a -> a) -> ListFix -> a
foldList = cata
-- is the same fold we had before!
--
-- Indeed:
--   (ListF a -> a) -> ListFix -> a
-- ~ ((1 + Int * a) -> a) -> ListFix -> a
-- ~ ((1 -> a) * (Int * a -> a)) -> ListFix -> a
-- ~ (a * (Int -> a -> a)) -> ListFix -> a
-- ~ ((Int -> a -> a) * a) -> ListFix -> a
-- ~ (Int -> a -> a) -> a -> ListFix -> a
--
-- compare it with the previous type
--      foldList :: (Int -> t -> t) -> t -> ListInt -> t