explicit-sharing 0.1 → 0.2

raw patch · 10 files changed

+146/−58 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Monad/Sharing.hs +6/−1
• Control/Monad/Sharing/Lazy.hs +0/−2
• Control/Monad/Sharing/Lazy/ContReader.hs +34/−5
• Control/Monad/Sharing/Lazy/ContReaderNoThunks.hs +45/−8
• Control/Monad/Sharing/Lazy/ContReaderNoThunksInlined.hs +16/−19
• Control/Monad/Sharing/Lazy/Simple.hs +23/−0
• Control/Monad/Sharing/Lazy/State.hs +0/−16
• Control/Monad/Sharing/Memoization.hs +18/−5
• Control/Monad/Trans/ContT.hs +2/−0
• explicit-sharing.cabal +2/−2

@@ -3,7 +3,12 @@      Rank2Types   #-} -module Control.Monad.Sharing where+module Control.Monad.Sharing (++  module Control.Monad, +  module Control.Monad.Sharing++ ) where  import Control.Monad 

@@ -4,12 +4,10 @@    Lazy, runLazy, evalLazy, -  module Control.Monad,   module Control.Monad.Sharing   ) where -import Control.Monad import Control.Monad.Sharing import Control.Monad.Sharing.Lazy.ContReaderNoThunksInlined 

@@ -1,18 +1,47 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+ module Control.Monad.Sharing.Lazy.ContReader where  import Control.Monad.Trans.ContT import Control.Monad.State import Control.Monad.Reader+import Control.Monad.Writer import Control.Monad.Sharing import Control.Monad.Sharing.Memoization -newtype Lazy m a = Lazy { fromLazy :: ContT (ReaderT ThunkStore m) a }- deriving (Monad, MonadPlus, MonadState ThunkStore)+type Env = (ThunkStore, Shared) +newtype Lazy m a = Lazy { fromLazy :: ContT (ReaderT Env m) a }+ deriving MonadPlus++instance Monad m => Monad (Lazy m)+ where+  return x = Lazy (return x)+  m >>= k  = Lazy (do x <- fromLazy m+                      modify (\ (ts,_) -> (ts,Shared False))+                      fromLazy (k x))++instance Monad m => MonadState ThunkStore (Lazy m)+ where+  get    = Lazy (liftM fst get)+  put ts = Lazy (modify (\ (_,s) -> (ts,s)))++instance Monad m => MonadWriter Shared (Lazy m)+ where+  tell s   = Lazy (modify (\ (ts,_) -> (ts,s)))+  listen m = Lazy (do x <- fromLazy m+                      s <- gets snd+                      return (x,s))+  pass m   = Lazy (do (x,f) <- fromLazy m+                      (ts,s) <- get+                      put (ts,f s)+                      return x)+ runLazy :: Monad m => Lazy m a -> m a-runLazy m = runReaderT (runContT (fromLazy m)) emptyThunkStore+runLazy m = runReaderT (runContT (fromLazy m)) (emptyThunkStore, Shared False)  instance MonadPlus m => Sharing (Lazy m)  where-  share a = memo (a >>= mapNondet share)-+  share a = memo $ do (x,s) <- listen a+                      if isShared s then shared (return x)+                       else mapNondet share x

@@ -1,17 +1,22 @@+{-# LANGUAGE+     GeneralizedNewtypeDeriving, +     MultiParamTypeClasses, +     FlexibleContexts+  #-}+ module Control.Monad.Sharing.Lazy.ContReaderNoThunks where  import Control.Monad.Trans.ContT import Control.Monad.State import Control.Monad.Reader+import Control.Monad.Writer import Control.Monad.Sharing-import Control.Monad.Sharing.Memoization ( Untyped(..), typed )+import Control.Monad.Sharing.Memoization+ ( Untyped(..), typed, Shared(..), shared )  import qualified Data.IntMap as M -newtype Lazy m a = Lazy { fromLazy :: ContT (ReaderT Store m) a }- deriving (Monad, MonadPlus, MonadState Store) - data Store = Store Int (M.IntMap Untyped)  getFreshKey :: MonadState Store m => m Int@@ -30,17 +35,49 @@   Store next heap <- get   put (Store next (M.insert key (Untyped val) heap)) ++type Env = (Store, Shared)++newtype Lazy m a = Lazy { fromLazy :: ContT (ReaderT Env m) a }+ deriving MonadPlus+ runLazy :: Monad m => Lazy m a -> m a-runLazy m = runReaderT (runContT (fromLazy m)) (Store 1 M.empty)+runLazy m = runReaderT (runContT (fromLazy m)) (Store 1 M.empty, Shared False) ++instance Monad m => Monad (Lazy m)+ where+  return x = Lazy (return x)+  m >>= k  = Lazy (do x <- fromLazy m+                      modify (\ (ts,_) -> (ts, Shared False))+                      fromLazy (k x))++instance Monad m => MonadState Store (Lazy m)+ where+  get    = Lazy (liftM fst get)+  put ts = Lazy (modify (\ (_,s) -> (ts,s)))++instance Monad m => MonadWriter Shared (Lazy m)+ where+  tell s   = Lazy (modify (\ (ts,_) -> (ts,s)))+  listen m = Lazy (do x <- fromLazy m+                      s <- gets snd+                      return (x,s))+  pass m   = Lazy (do (x,f) <- fromLazy m+                      (ts,s) <- get+                      put (ts,f s)+                      return x)+ instance MonadPlus m => Sharing (Lazy m)  where-  share a = memo (a >>= mapNondet share)+  share a = memo $ do (x,s) <- listen a+                      if isShared s then shared (return x)+                       else mapNondet share x -memo :: MonadState Store m => m a -> m (m a)+memo :: (MonadState Store m, MonadWriter Shared m) => m a -> m (m a) memo a = do   key <- getFreshKey-  return $ do+  return . shared $ do     thunk <- lookupHNF key     case thunk of       Just x  -> return x

@@ -6,49 +6,46 @@  module Control.Monad.Sharing.Lazy.ContReaderNoThunksInlined where -import Control.Monad.State import Control.Monad.Sharing import Control.Monad.Sharing.Memoization ( Untyped(..), typed )  import qualified Data.IntMap as M  newtype Lazy m a = Lazy {-  fromLazy :: forall w . (a -> Store -> m w) -> Store -> m w+  fromLazy :: forall w . (a -> Bool -> Store -> m w) -> Bool -> Store -> m w  }  data Store = Store Int (M.IntMap Untyped)  runLazy :: Monad m => Lazy m a -> m a-runLazy m = fromLazy m (\a _ -> return a) (Store 1 M.empty)+runLazy m = fromLazy m (\x _ _ -> return x) False (Store 1 M.empty)  instance Monad m => Monad (Lazy m)  where   return x = Lazy (\c -> c x)-  a >>=  k = Lazy (\c s -> fromLazy a (\x -> fromLazy (k x) c) s)-  fail str = Lazy (\_ _ -> fail str)+  a >>=  k = Lazy (\c -> fromLazy a (\x _ -> fromLazy (k x) c False))+  fail str = Lazy (\_ _ _ -> fail str)  instance MonadPlus m => MonadPlus (Lazy m)  where-  mzero = Lazy (\_ _ -> mzero)--  a `mplus` b = Lazy (\c s -> fromLazy a c s `mplus` fromLazy b c s)+  mzero = Lazy (\_ _ _ -> mzero) -instance Monad m => MonadState Store (Lazy m)- where-  get   = Lazy (\c s -> c s s)-  put s = Lazy (\c _ -> c () s)+  x `mplus` y = Lazy (\c b s -> fromLazy x c b s `mplus` fromLazy y c b s)  instance MonadPlus m => Sharing (Lazy m)  where-  share a = memo (a >>= mapNondet share)+  share a = memo (Lazy (\c -> +            fromLazy a (\x b -> +            if b then c x True+                 else fromLazy (mapNondet share x) c False)))  memo :: Lazy m a -> Lazy m (Lazy m a)-memo a = Lazy (\c (Store key heap) ->-      c (Lazy (\c s@(Store _ heap) -> +memo a = Lazy (\c b (Store key heap) ->+      c (Lazy (\c b s@(Store _ heap) ->           case M.lookup key heap of-          Just x  -> c (typed x) s+          Just x  -> c (typed x) True s           Nothing -> fromLazy a-           (\x (Store other heap) -> -              c x (Store other (M.insert key (Untyped x) heap))) s))-        (Store (succ key) heap))+           (\x _ (Store other heap) -> +              c x True (Store other (M.insert key (Untyped x) heap))) b s))+        b (Store (succ key) heap)) 

@@ -0,0 +1,23 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++module Control.Monad.Sharing.Lazy.Simple where++import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Sharing+import Control.Monad.Sharing.Memoization++newtype Lazy m a = Lazy {+  fromLazy :: WriterT Shared (StateT ThunkStore m) a+ } deriving (Monad, MonadPlus, MonadState ThunkStore, MonadWriter Shared)++runLazy :: Monad m => Lazy m a -> m a+runLazy m = do ((x,_),_) <- runStateT (runWriterT (fromLazy m)) emptyThunkStore+               return x++instance MonadPlus m => Sharing (Lazy m)+ where+  share a = memo $ do (x,s) <- listen a+                      if isShared s then shared (return x)+                       else mapNondet share x+

@@ -1,16 +0,0 @@-module Control.Monad.Sharing.Lazy.State where--import Control.Monad.State-import Control.Monad.Sharing-import Control.Monad.Sharing.Memoization--newtype Lazy m a = Lazy { fromLazy :: StateT ThunkStore m a }- deriving (Monad, MonadPlus, MonadState ThunkStore)--runLazy :: Monad m => Lazy m a -> m a-runLazy m = evalStateT (fromLazy m) emptyThunkStore--instance MonadPlus m => Sharing (Lazy m)- where-  share a = memo (a >>= mapNondet share)-

@@ -7,14 +7,18 @@    Untyped(..), typed, -  ThunkStore, emptyThunkStore, memo+  ThunkStore(..), emptyThunkStore, Shared(..), shared, memo   ) where  import qualified Data.IntMap as M++import Data.Monoid ()+ import Control.Monad.State-import Unsafe.Coerce+import Control.Monad.Writer +import Unsafe.Coerce  data Untyped = forall a . Untyped a @@ -26,7 +30,6 @@  data Thunk m a = Uneval (m a) | Eval !a - emptyThunkStore :: ThunkStore emptyThunkStore = ThunkStore { freshKey = 1, thunks = M.empty } @@ -44,11 +47,21 @@ lookupThunk key = liftM (typed . M.findWithDefault err key) (gets thunks)  where err = error $ "lookupThunk: unbound key " ++ show key -memo :: MonadState ThunkStore m => m a -> m (m a)++newtype Shared = Shared { isShared :: Bool }++instance Monoid Shared+ where mempty  = Shared False+       mappend = flip const++shared :: MonadWriter Shared m => m a -> m a+shared = censor (const (Shared True))++memo :: (MonadState ThunkStore m, MonadWriter Shared m) => m a -> m (m a) memo a = do   key <- getFreshKey   insertThunk key (Uneval a)-  return $ do+  return . shared $ do     thunk <- lookupThunk key     case thunk of       Eval x   -> return x

@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}+ module Control.Monad.Trans.ContT where  import Control.Monad.State

@@ -1,5 +1,5 @@ Name:          explicit-sharing-Version:       0.1+Version:       0.2 Cabal-Version: >= 1.6 Synopsis:      Explicit Sharing of Monadic Effects Description:   @@ -23,7 +23,7 @@   Exposed-Modules:  Control.Monad.Trans.ContT,                     Control.Monad.Sharing,                     Control.Monad.Sharing.Lazy-                    Control.Monad.Sharing.Lazy.State,+                    Control.Monad.Sharing.Lazy.Simple,                     Control.Monad.Sharing.Lazy.ContReader,                     Control.Monad.Sharing.Lazy.ContReaderNoThunks,                     Control.Monad.Sharing.Lazy.ContReaderNoThunksInlined