Changeset 25 for sizechecking/branches/macs

Timestamp:

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

Author:

gobi

Message:

monad for observable sharing

Location:

sizechecking/branches/macs

Files:

• LICENSE (added)
• Lambda.hs (modified) (3 diffs)
• Ops.hs (modified) (2 diffs)
• Size.hs (modified) (3 diffs)
• Tests (moved) (moved from sizechecking/branches/macs/tests)
• sizechecking.cabal (added)

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)

sizechecking/branches/macs/Ops.hs

@@ -1 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, KindSignatures #-}
 
 module Ops where
@@ -8 +8 @@
 import Lambda
 
+-- infix operatorok, ezek beagyazasa picit necces, lasd a type family kesobb
 class (Lambda l) => LOps l where
-    infixop :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
+    infixop  :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
     infixopr :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
     infixopl :: String -> Int -> (a -> b -> c) -> l a -> l b -> l c
-    fun :: String -> a -> l a
+    fun ::  String -> a -> l a
 
-    (+) :: l Int -> l Int -> l Int
-    (+) = infixopl "+" 6 (Prelude.+)
+(+) :: (LOps l) => l Int -> l Int -> l Int
+(+) = infixopl "+" 6 (Prelude.+)
 
-    (-) :: l Int -> l Int -> l Int
-    (-) = infixopl "-" 6 (Prelude.-)
+(-) :: (LOps l) => l Int -> l Int -> l Int
+(-) = infixopl "-" 6 (Prelude.-)
 
-    (*) :: l Int -> l Int -> l Int
-    (*) = infixopl "*" 7 (Prelude.*)
+(*) :: (LOps l) => l Int -> l Int -> l Int
+(*) = infixopl "*" 7 (Prelude.*)
+
 
 

sizechecking/branches/macs/Size.hs

@@ +1 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 module Size where
 
@@ -13 +17 @@
     unsized :: l Unsized
     bottom :: l a
+
 
 instance Size S where
@@ -46 +51 @@
         . showChar ' '
         . unS e2 s3 2
+