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

{-# LANGUAGE TypeFamilies #-}

module Lambda where

import qualified Data.Supply as S
import qualified Data.Char as C
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef (newIORef, readIORef, writeIORef)

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

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

eval :: Q a -> a
eval = unQ

{-
 - show interpreter
 -}
showVar :: Int -> String -> String
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

-- unS :: Value supply -> Precedence -> ShowS
newtype S a = S { unS :: S.Supply Int -> Int -> ShowS }

instance Lambda S where
    lit a = S (\_ p -> showsPrec p a)
    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 :: S a -> IO ShowS
ast a = do
    s <- S.newSupply 0 (+1)
    return $ unS a s 0

printAst :: S a -> IO ()
printAst l = ast l >>= (\s -> putStrLn $ s "")


type family Sem (m :: * -> *) a :: *
type instance Sem m Int      = Int
type instance Sem m (a -> b) = m (Sem m a) -> m (Sem m b)

newtype R m a = R { unR :: m (Sem m a) }

share :: (MonadIO m) => m a -> m (m a)
share f = do
    mem <- liftIO $ newIORef (False, f)
    return $ do
        (evald, thunk) <- liftIO $ readIORef mem
        if evald then thunk
        else do
          value <- thunk
          liftIO $ writeIORef mem (True, return value)
          return value

instance (MonadIO m) => Lambda (R m) where 
    app x y = R $ unR x >>= ($ (unR y))
    lit = R . return
    lam f   = R . return $ (\x -> share x >>= unR . f . R)