source: sizechecking/branches/macs/Lambda.hs @ 19

{-# LANGUAGE FlexibleContexts,FlexibleInstances #-}
module Lambda where

import qualified Data.Supply as S
import qualified Data.Char as C

{-
 - Lambda calculus beagyazas
 -}
class Lambda l where
    lam   :: (l a -> l b) -> l (a -> b)
    app   :: l (a -> b) -> l a -> l b
    const :: Int -> l Int


{-
 - eval interpreter
 -}
newtype Q a = Q { unQ :: a }
instance Lambda Q where
    const = Q
    lam a = Q (unQ.a.Q)
    app a b = Q $ (unQ a) (unQ b)

eval = unQ

instance Num a => Num (Q a) where
    (Q a) + (Q b) = Q (a+b)
    (Q a) - (Q b) = Q (a-b)
    (Q a) * (Q b) = Q (a*b)
    abs (Q a) = Q (abs a)


{-
 - show interpreter
 -}
showVar x = if x>28 
    then showVar (x `div` 29) . showChar (C.chr $ C.ord 'a' + (x `mod` 29))
    else showChar $ C.chr $ C.ord 'a' + x

newtype S a = S { unS :: S.Supply Int -> Int -> ShowS }
instance Lambda S where
    const a = S (\s p -> flip showsPrec a p)
    app (S fun) (S arg) = S (\s p -> 
        let (s1, s2) = S.split2 s 
        in showParen (p>6) $ fun s1 6 . showChar ' ' . arg s2 7)
    lam fun = S (\s p -> 
        let (s1, s2) = S.split2 s
            v        = S.supplyValue s1
            showV = S $ \_ _ -> showVar v
        in showParen (p>0) $ showChar 'λ' . showVar v . showChar '.' . unS (fun showV) s2 0)

ast a = do
    s <- S.newSupply 0 (+1)
    return $ unS a s 0

printAst a = ast a >>= (\a -> putStrLn $ a "")