Lambda calculus for Demo on TryPurescript

LambdaCalculus.hs

module Demo where

import Prelude hiding (succ, pred)

class LambdaCalc repr where

  lam :: (repr a -> repr b) -> repr (a -> b)
  app :: repr (a -> b) -> repr a -> repr b
  fix :: (repr a -> repr a) -> repr a

class LambdaInts repr where
    zero :: repr Int
    pred :: repr Int -> repr Int
    succ :: repr Int -> repr Int

class LambdaBool repr where
    tf :: Bool -> repr Bool
    bLeq :: repr Int -> repr Int -> repr Bool
    bIf :: repr Bool -> repr a -> repr a -> repr a

class LambdaMult repr where
    mult :: repr Int -> repr Int -> repr Int

newtype Eval a = Eval a
unwrap :: Eval a -> a
unwrap (Eval a) = a


instance LambdaCalc Eval where
  lam f = Eval $ unwrap . f . Eval
  app (Eval f) = \(Eval a) -> Eval (f a)
  fix f = Eval $ dupe (unwrap . f . Eval)
    where dupe fx = fx (dupe fx)

instance LambdaInts Eval where
    zero = Eval 0
    pred (Eval 0) = Eval 0
    pred (Eval n) = Eval (n - 1)
    succ (Eval n) = Eval (n + 1)

instance LambdaBool Eval where
    tf = Eval
    bLeq l r = Eval $ unwrap l <= unwrap r
    bIf pred true false = if unwrap pred then true else false

eval :: Show a => Eval a -> String
eval = show . unwrap

instance LambdaMult Eval where
    mult l r = Eval $ unwrap l * unwrap r

--
-- Terms
--
one :: Eval Int
one = succ zero

seven :: Eval Int
seven = succ (succ ( succ ( succ ( succ ( succ ( succ zero))))))

awkwardTwo :: Eval Int
awkwardTwo = app (lam (\(Eval a) -> succ (Eval a))) (succ zero)

{-
add ::
    Eval (Eval Int -> Eval Int -> Eval Int)
add = fix (\self ->
    lam (\x ->
        lam (\n ->
            bIf (bLeq n zero)
                zero
                (app self (lam (\y -> (succ x) (pred n))))
            ))

-}

tpow :: Eval (Int -> Int -> Int)
tpow = lam (\x -> fix (\self -> lam (\n ->
    bIf (bLeq n zero)
        one
        (mult x (app self (pred n))))
    ))

toThe7th :: Eval (Int -> Int)
toThe7th = lam (\x -> app (app tpow x) seven)

twoToThe7th :: Eval  Int
twoToThe7th = app toThe7th awkwardTwo