EDSL of lambda-calculus + mutable references

EDSL.hs

{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE EmptyDataDecls            #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE TupleSections             #-}
module EDSL where

import Data.IORef
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State hiding (fix)

data IntT
data BoolT
data UnitT
data Ref a
data a :-> b
infixr 5 :->

class EDSL exp where
     lam  :: (exp a -> exp b) -> exp (a :-> b)
     lam = lamS

     lamS :: (exp a -> exp b) -> exp (a :-> b)
     app  :: exp (a :-> b) -> exp a -> exp b

     int :: Int -> exp IntT
     add :: exp IntT -> exp IntT -> exp IntT
     sub :: exp IntT -> exp IntT -> exp IntT
     mul :: exp IntT -> exp IntT -> exp IntT

     bool :: Bool -> exp BoolT
     eq   :: exp IntT -> exp IntT -> exp BoolT
     lt   :: exp IntT -> exp IntT -> exp BoolT
     if_  :: exp BoolT -> exp a -> exp a -> exp a

     ref    :: exp a -> exp (Ref a)
     deref  :: exp (Ref a) -> exp a
     update :: exp (Ref a) -> exp a -> exp UnitT

instance EDSL exp => Num (exp IntT) where
  fromInteger = int . fromInteger
  (+)         = add
  (-)         = sub
  (*)         = mul
  abs         = undefined
  signum      = undefined


let_ x y   = (lam y) `app` x
letS_ x y  = (lamS y) `app` x
newvar x y = let_ (ref x) y
x >: y     = letS_ x (\_ -> y)

infixr 5 >:

fix = lam $ \p -> letS_ (ref (lam $ \x -> undefined)) (\z -> letS_ (update z (lam $ \x -> app (app p (deref z)) x)) (\_ -> deref z))

fibbo = app fix $ lam $ \fib ->
  lam $ \n ->
    newvar 0 $ \n1 ->
    newvar 0 $ \n2 ->
    newvar 0 $ \n3 ->
      update n1 n >:
      if_ (lt (deref n1) 2)
        1
        ( update n2 (app fib ((deref n1) - 1)) >:
          update n3 (app fib ((deref n1) - 2)) >:
          (deref n2) + (deref n3)
        )

fibbo5 = app fibbo (int 5)

type family Sem (m :: * -> *) a :: *
type instance Sem m IntT      = Int
type instance Sem m BoolT     = Bool
type instance Sem m UnitT     = ()
type instance Sem m (Ref a)   = IORef (String, Sem m a)
type instance Sem m (a :-> b) = m (Sem m a) -> m (Sem m b)

newtype S l m a = S { unS :: m (Sem m a) }

data Value

type EVState = StateT Int IO

instance EDSL (S Value EVState) where
  lamS f  = S . return $ (\x -> x >>= unS . f . S . return)
  app x y = S $ unS x >>= ($ (unS y))

  int     = S . return
  add x y = S $ do a <- unS x
                   b <- unS y
                   liftIO $ putStrLn "Adding"
                   return (a + b)
  sub x y = S $ do a <- unS x
                   b <- unS y
                   liftIO $ putStrLn "Substracting"
                   return (a - b)
  mul x y = S $ do a <- unS x
                   b <- unS y
                   liftIO $ putStrLn "Multiplying"
                   return (a * b)

  bool    = S . return
  eq x y  = S $ do a <- unS x
                   b <- unS y
                   liftIO $ putStrLn "Comparing (EQ)"
                   return (a == b)
  lt x y  = S $ do a <- unS x
                   b <- unS y
                   liftIO $ putStrLn "Comparing (LT)"
                   return (a < b)
  if_ be te ee = S $ do
                    bs <- unS be
                    if bs
                      then unS te
                      else unS ee

  ref   x      = S $ do
                   i <- getAndModify (+1)
                   let s' = show i
                   liftIO $ putStrLn $ "Creating reference: " ++ s'
                   unS x >>= (liftIO . newIORef . (s',))
  deref x      = S $ do
                    a <- unS x
                    (s,a') <- liftIO (readIORef a)
                    liftIO $ putStrLn $ "Dereferencing: " ++ s
                    return a'
  update x y   = S $ do
                  a <- unS x
                  (s,_) <- liftIO (readIORef a)
                  b <- unS y
                  liftIO $ putStrLn $ "Updating reference: " ++ s
                  liftIO (modifyIORef a (\(s,_) -> (s,b)))

runValue :: S Value m a -> m (Sem m a)
runValue x = unS x

getAndModify f = do
  a <- get
  modify f
  return a

runExpr :: S Value EVState IntT -> IO ()
runExpr e = evalStateT (runValue e) (0 :: Int) >>= print