{-# LANGUAGE ScopedTypeVariables, GADTSyntax #-}
{-# OPTIONS -Wall #-}

module RecTypes where

-- A product type
data TProd where
    K :: Int -> String -> TProd

testTProd :: TProd
testTProd = K 42 "asd"

test2TProd :: TProd -> Int
test2TProd (K i _s) = i
                 
-- A sum type
data TSum where
    K1 :: Int -> TSum
    K2 :: String -> TSum

testTSum :: TSum
testTSum = K1 42

test2TSum :: TSum -> Int
test2TSum (K1 i) = i
test2TSum (K2 s) = length s

test3TSum :: TSum -> Int
test3TSum x = case x of
                K1 i -> i
                K2 s -> length s
                        
-- Recursive types

-- Nat ~= 1 + Nat
data Nat where
    O :: Nat
    S :: Nat -> Nat

testNat :: Nat
testNat = S (S O) -- 2

test2Nat :: Nat -> Int
test2Nat O     = 0
test2Nat (S n) = 1 + test2Nat n

-- ListInt ~= 1 + (Int * ListInt)                 
data ListInt where
    Nil  :: ListInt
    Cons :: Int -> ListInt -> ListInt

testListInt :: ListInt
testListInt = Cons 3 (Cons 2 (Cons 12 Nil))

-- Sum all the list elements
sumListInt :: ListInt -> Int
sumListInt Nil = 0
sumListInt (Cons n ns) = n + sumListInt ns

-- 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)

sum2ListInt :: ListInt -> Int
sum2ListInt xs = foldList (+) 0 xs

-- TreeInt ~= 1 + (Int * TreeInt * TreeInt)
data TreeInt where
    Leaf :: TreeInt
    Branch :: Int -> TreeInt -> TreeInt -> TreeInt

--             4
--            / \
--           5   *
--          / \
--         *   *
testTreeInt :: TreeInt
testTreeInt = Branch 4 (Branch 5 Leaf Leaf) Leaf

-- Sum all the tree elements
sumTreeInt :: TreeInt -> Int
sumTreeInt Leaf = 0
sumTreeInt (Branch n l r) = n + sumTreeInt l + sumTreeInt r

-- foldTree f a (Branch x1 (...) Nil)
--            = (f      x1 (...) a  )
foldTree :: (Int -> t -> t -> t) -> t -> TreeInt -> t
foldTree _ a Leaf = a
foldTree f a (Branch n l r) = f n (foldTree f a l) (foldTree f a r)

sum2TreeInt :: TreeInt -> Int
sum2TreeInt tree = foldTree f 0 tree
   where f :: Int -> Int -> Int -> Int
         f x y z = x + y + z
                              
----------------------------------------------------------------

-- Term fixed points

fact :: Int -> Int
fact n = if n==0 then 1 else n * fact (n-1)

-- A fixed point combinator (like Church's Y)
fix :: (a -> a) -> a
fix f = f (fix f)

-- Defining fact in terms of fixed points
factFix :: Int -> Int
factFix = fix f
   where f :: (Int -> Int) -> (Int -> Int)
         f g = \n -> if n==0 then 1 else n * g (n-1)

-- Type fixed points

-- See e.g. Nat as defined before

-- A parametric type: Pair a ~= (a*a)
-- Here, "a" is a type parameter
data Pair a where
    P :: a -> a -> Pair a

-- Note: in Haskell, we write
--   Nat :: *             "Nat is a type"
--   Pair Nat :: *        "Pair Nat is a type"
--   Pair :: * -> *       "Pair is a parametric type,
--                         a function from types to types)

-- A fixed point combinator .. on types!
newtype Fix f where
    Fix :: (f (Fix f)) -> Fix f
-- it is customary, in Haskell, to name the newtype isomorphism constructor
-- with the same name as the type

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

-- We now recreate Nat uing fixed points
--   Nat = Fix NatF
--     where NatF a ~= 1 + a
data NatF a where
    OF :: NatF a
    SF :: a -> NatF a
type NatFix = Fix NatF

testNatFix :: NatFix
testNatFix = Fix (SF (Fix (SF (Fix OF)))) -- 2

natFixToInt :: NatFix -> Int
natFixToInt (Fix OF) = 0
natFixToInt (Fix (SF n)) = 1 + natFixToInt n