Changeset 25 for sizechecking/branches/macs/Lambda.hs

Timestamp:

May 4, 2014, 6:57:47 PM (11 years ago)

Author:

gobi

Message:

monad for observable sharing

File:

• sizechecking/branches/macs/Lambda.hs (modified) (3 diffs)

sizechecking/branches/macs/Lambda.hs

@@ -1 @@
-{-# LANGUAGE FlexibleContexts,FlexibleInstances #-}
+{-# 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)
 
 {-
@@ -9 +12 @@
  -}
 class Lambda l where
-    lam   :: (l a -> l b) -> l (a -> b)
-    app   :: l (a -> b) -> l a -> l b
+    lam :: (l a -> l b) -> l (a -> b)
+    app :: l (a -> b) -> l a -> l b
     lit :: Int -> l Int
 
@@ -54 +57 @@
 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)