packages feed

explicit-sharing (empty) → 0.1

raw patch · 13 files changed

+541/−0 lines, 13 filesdep +basedep +containersdep +mtlbuild-type:Customsetup-changed

Dependencies added: base, containers, mtl

Files

+ Control/Monad/Sharing.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE+     MultiParamTypeClasses,+     Rank2Types+  #-}++module Control.Monad.Sharing where++import Control.Monad++class MonadPlus m => Nondet m a+ where+  mapNondet :: (forall b . Nondet m b => m b -> m (m b)) -> a -> m a++eval :: Nondet m a => a -> m a+eval = mapNondet (\a -> a >>= eval >>= return . return)++class MonadPlus m => Sharing m+ where+  share :: Nondet m a => m a -> m (m a)++shareRec :: (Sharing m, Nondet m a) => (m a -> m a) -> m (m a)+shareRec f = let x = share (f (x >>= id)) in x+
+ Control/Monad/Sharing/Lazy.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleContexts #-}++module Control.Monad.Sharing.Lazy (++  Lazy, runLazy, evalLazy,++  module Control.Monad,+  module Control.Monad.Sharing++ ) where++import Control.Monad+import Control.Monad.Sharing+import Control.Monad.Sharing.Lazy.ContReaderNoThunksInlined++evalLazy :: Monad m => Nondet (Lazy m) a => Lazy m a -> m a+evalLazy m = runLazy (m >>= eval)+
+ Control/Monad/Sharing/Lazy/ContReader.hs view
@@ -0,0 +1,18 @@+module Control.Monad.Sharing.Lazy.ContReader where++import Control.Monad.Trans.ContT+import Control.Monad.State+import Control.Monad.Reader+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)++runLazy :: Monad m => Lazy m a -> m a+runLazy m = runReaderT (runContT (fromLazy m)) emptyThunkStore++instance MonadPlus m => Sharing (Lazy m)+ where+  share a = memo (a >>= mapNondet share)+
+ Control/Monad/Sharing/Lazy/ContReaderNoThunks.hs view
@@ -0,0 +1,50 @@+module Control.Monad.Sharing.Lazy.ContReaderNoThunks where++import Control.Monad.Trans.ContT+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Sharing+import Control.Monad.Sharing.Memoization ( Untyped(..), typed )++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+getFreshKey = do+  Store key heap <- get+  put (Store (succ key) heap)+  return key++lookupHNF :: MonadState Store m => Int -> m (Maybe a)+lookupHNF key = do+  Store _ heap <- get+  return (fmap typed (M.lookup key heap))++insertHNF :: MonadState Store m => Int -> a -> m ()+insertHNF key val = do+  Store next heap <- get+  put (Store next (M.insert key (Untyped val) heap))++runLazy :: Monad m => Lazy m a -> m a+runLazy m = runReaderT (runContT (fromLazy m)) (Store 1 M.empty)++instance MonadPlus m => Sharing (Lazy m)+ where+  share a = memo (a >>= mapNondet share)++memo :: MonadState Store m => m a -> m (m a)+memo a = do+  key <- getFreshKey+  return $ do+    thunk <- lookupHNF key+    case thunk of+      Just x  -> return x+      Nothing -> do+        x <- a+        insertHNF key x+        return x
+ Control/Monad/Sharing/Lazy/ContReaderNoThunksInlined.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE+     MultiParamTypeClasses,+     Rank2Types+  #-}++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+ }++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)++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)++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)++instance Monad m => MonadState Store (Lazy m)+ where+  get   = Lazy (\c s -> c s s)+  put s = Lazy (\c _ -> c () s)++instance MonadPlus m => Sharing (Lazy m)+ where+  share a = memo (a >>= mapNondet share)++memo :: Lazy m a -> Lazy m (Lazy m a)+memo a = Lazy (\c (Store key heap) ->+      c (Lazy (\c s@(Store _ heap) -> +         case M.lookup key heap of+          Just x  -> c (typed x) s+          Nothing -> fromLazy a+           (\x (Store other heap) -> +              c x (Store other (M.insert key (Untyped x) heap))) s))+        (Store (succ key) heap))+
+ Control/Monad/Sharing/Lazy/State.hs view
@@ -0,0 +1,16 @@+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)+
+ Control/Monad/Sharing/Memoization.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE+     ExistentialQuantification,+     FlexibleContexts+  #-}++module Control.Monad.Sharing.Memoization (++  Untyped(..), typed,++  ThunkStore, emptyThunkStore, memo++ ) where++import qualified Data.IntMap as M+import Control.Monad.State+import Unsafe.Coerce+++data Untyped = forall a . Untyped a++typed :: Untyped -> a+typed (Untyped x) = unsafeCoerce x+++data ThunkStore = ThunkStore { freshKey :: Int, thunks :: M.IntMap Untyped }++data Thunk m a = Uneval (m a) | Eval !a+++emptyThunkStore :: ThunkStore+emptyThunkStore = ThunkStore { freshKey = 1, thunks = M.empty }++getFreshKey :: MonadState ThunkStore m => m Int+getFreshKey = do+  key <- gets freshKey+  modify (\s -> s { freshKey = succ key })+  return key++insertThunk :: MonadState ThunkStore m => Int -> Thunk m a -> m ()+insertThunk key thunk =+  modify (\s -> s { thunks = M.insert key (Untyped thunk) (thunks s) })++lookupThunk :: MonadState ThunkStore m => Int -> m (Thunk m a)+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)+memo a = do+  key <- getFreshKey+  insertThunk key (Uneval a)+  return $ do+    thunk <- lookupThunk key+    case thunk of+      Eval x   -> return x+      Uneval b -> do+        x <- b+        insertThunk key (Eval x)+        return x
+ Control/Monad/Trans/ContT.hs view
@@ -0,0 +1,25 @@+module Control.Monad.Trans.ContT where++import Control.Monad.State+import Control.Monad.Reader++newtype ContT m a = ContT { unContT :: forall w . (a -> m w) -> m w }++runContT :: Monad m => ContT m a -> m a+runContT m = unContT m return++instance MonadTrans ContT where+  lift m = ContT (\c -> m >>= c)++instance Monad m => Monad (ContT m) where+  return x = lift (return x)+  m >>=  k = ContT (\c -> unContT m (\x -> unContT (k x) c))+  fail str = lift (fail str)++instance MonadPlus m => MonadPlus (ContT m) where+  mzero       = lift mzero+  a `mplus` b = ContT (\c -> unContT a c `mplus` unContT b c)++instance Monad m => MonadState s (ContT (ReaderT s m)) where+  get   = lift ask+  put s = ContT (\c -> local (const s) (c ()))
+ LICENSE view
@@ -0,0 +1,15 @@+ALL PUBLIC DOMAIN MATERIAL IS OFFERED AS-IS. NO REPRESENTATIONS OR+WARRANTIES OF ANY KIND ARE MADE CONCERNING THE MATERIALS, EXPRESS,+IMPLIED, STATUTORY OR OTHERWISE, INCLUDING, WITHOUT LIMITATION,+WARRANTIES OF TITLE, MERCHANTIBILITY, FITNESS FOR A PARTICULAR+PURPOSE, NONINFRINGEMENT, OR THE ABSENCE OF LATENT OR OTHER DEFECTS,+ACCURACY, OR THE PRESENCE OF ABSENCE OF ERRORS, WHETHER OR NOT+DISCOVERABLE.++IN NO EVENT WILL THE AUTHOR(S), PUBLISHER(S), OR PRESENTER(S) OF ANY+PUBLIC DOMAIN MATERIAL BE LIABLE TO YOU ON ANY LEGAL THEORY FOR ANY+SPECIAL, INCIDENTAL, CONSEQUENTIAL, PUNITIVE OR EXEMPLARY DAMAGES+ARISING OUT OF THIS LICENSE OR THE USE OF THE WORK, EVEN IF THE+AUTHOR(S), PUBLISHER(S), OR PRESENTER(S) HAVE BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.+
+ List.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE+     NoMonomorphismRestriction,+     MultiParamTypeClasses,+     FlexibleInstances+  #-}++module List where ++import Control.Monad.Sharing.Lazy++data List m a = Nil | Cons (m a) (m (List m a))++nil = return Nil+cons x xs = return (Cons x xs)++match n _ Nil = n+match _ c (Cons x xs) = c x xs++empty l = l >>= match (return True) (\_ _ -> return False)+first l = l >>= match mzero const+rest  l = l >>= match mzero (flip const)++fold n c l = l >>= match n (\x xs -> c x (fold n c xs))++instance Nondet m a => Nondet m (List m a)+ where+  mapNondet _ Nil         = return Nil+  mapNondet f (Cons x xs) = do+    y  <- f x+    ys <- f xs+    return (Cons y ys)++instance MonadPlus m => Nondet m Int+ where+  mapNondet _ = return
+ Setup.hs view
@@ -0,0 +1,9 @@+import System.Process+import System.Exit+import Distribution.Simple++main = defaultMainWithHooks $ simpleUserHooks { runTests = runTestSuite }++runTestSuite _ _ _ _ =+ runCommand "runhaskell Test.hs" >>= waitForProcess >>= exitWith+
+ Test.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE+     NoMonomorphismRestriction,+     MultiParamTypeClasses,+     FlexibleInstances,+     FlexibleContexts+  #-}++import Control.Monad.Sharing.Lazy++import List++main = do+  putStr "failing tests: "+  print . map fst . filter (not . snd) . zip [1..] $ tests+ where+  tests = [ dup_coin_let, dup_coin_bind, dup_coin_share+          , lazy_share, heads_bind, heads_share, dup_first_coin+          , one_coin, two_coins, dup_coin, dupnot_coin+          , first_rep, first_rep', rep_coin, rep_coin'+          , dup_list, ignore_shared, empty_rep, empty_rep'+          , nest_lazy, nest_share1, nest_share2+          , dup_dup, dup_two_coins, dup_head, dup_head_lazy+          ]++instance MonadPlus m => Nondet m Bool+ where+  mapNondet _ = return++instance MonadPlus m => Nondet m (Int,Int)+ where+  mapNondet _ = return++instance (Nondet m a, Nondet m b) => Nondet m (m a,m b)+ where+  mapNondet f (a,b) = return (,) `ap` f a `ap` f b++fromList _ Nil         = return []+fromList f (Cons x xs) = do y <- x >>= f; ys <- xs >>= fromList f; return (y:ys)++fromPair l r (a,b) = do x <- a >>= l; y <- b >>= r; return (x,y)++assertEqual :: (Nondet (Lazy []) a, Eq b)+            => (a -> Lazy [] b) -> [b] -> Lazy [] a -> Bool+assertEqual f res test = zipEq (runLazy (test >>= eval >>= f)) res+ where+  zipEq [] [] = True+  zipEq [] _  = False+  zipEq (_:_) [] = True+  zipEq (x:xs) (y:ys) = (x==y) && zipEq xs ys++coin :: MonadPlus m => m Int+coin = return 0 `mplus` return 1++ilist = fromList return+illist = fromList ilist+ipair = fromPair return return+pilist = fromPair ilist ilist+ippair = fromPair ipair ipair++-- examples from paper++duplicate :: Monad m => m a -> m (a,a)+duplicate a = do x <- a; y <- a; return (x,y)++dup_coin_let = assertEqual return [(0,0),(0,1),(1,0),(1,1)] $ +                 let x = coin in duplicate x++dup_coin_bind  = assertEqual return [(0,0),(1,1)] $ do+                   x <- coin+                   duplicate (return x)++dup_coin_share = assertEqual return [(0,0),(1,1)] $ do+                   x <- share coin+                   duplicate x++-- strict_bind = -- diverges intentionally+--   do x <- undefined :: Lazy [] Int+--      duplicate (const (return 2) (return x))++lazy_share = assertEqual return [(2::Int,2::Int)] $+  do x <- share (undefined :: Lazy [] Int)+     duplicate (const (return 2) x)++dupl :: Monad m => m a -> m (List m a)+dupl x = cons x (cons x nil)++heads_bind = assertEqual ilist [[0,0],[0,1],[1,0],[1,1]] $ do+               x <- cons coin undefined+	       dupl (first (return x))++heads_share = assertEqual ilist [[0,0],[1,1]] $ do+                x <- share (cons coin undefined)+                dupl (first x)++coins :: MonadPlus m => m (List m Int)+coins = nil `mplus` cons coin coins++dup_first_coin = assertEqual ilist [[0,0],[1,1]] $ do+                   cs <- share coins+                   dupl (first cs)++-- other examples++one_coin = assertEqual return [0,1] coin++two_coins = assertEqual ipair [(0,0),(0,1),(1,0),(1,1)] $ return (coin,coin)++dup_coin = assertEqual ipair [(0,0),(1,1)] $ dup coin++dup a = do+  x <- share a+  return (x,x)++dupnot_coin = assertEqual ipair [(1,1),(0,0)] $ dupnot coin++dupnot a = do+  x <- share a+  return (liftM ((-)1) x, liftM ((-)1) x)++first_rep = assertEqual return [42::Int] $ first (first (rep (rep (return 42))))++rep a = do+  x <- share a+  cons x (rep x)++first_rep' = assertEqual return [42::Int] $+               first (first (rep' (rep' (return 42))))++rep' a = do+  xs <- shareRec (\l -> cons a l)+  xs++rep_coin = assertEqual ipair [(0::Int,0::Int),(1,1)] $+             rep coin >>= match mzero (\x xs -> return (x, first xs))++-- recursive bindings do not work as expected:+rep_coin' = assertEqual ipair [(0::Int,0::Int),(0,1),(1,0),(1,1)] $+              rep' coin >>= match mzero (\x xs -> return (x, first xs))++dup_list = assertEqual pilist [([],[])+                              ,([0],[0])+                              ,([0,0],[0,0])+                              ,([0,0,0],[0,0,0])] $+             dup coins++ignore_shared = assertEqual ipair [(0,1)] $ ign_pair mzero++ign_pair :: Sharing m => m Int -> m (m Int,m Int)+ign_pair a = do+  x <- share a+  return (const (return 0) x, const (return 1) x)++empty_rep = assertEqual return [False] $ empty (rep (undefined::Lazy [] Int))++empty_rep' = assertEqual return [False] $ empty (rep' (undefined::Lazy [] Int))++nest_lazy = assertEqual return [42::Int] $ do+  x <- share (cons (return 42) mzero)+  first x++nest_share1 = assertEqual ipair [(0,0),(1,1)] $ do+  x <- share (share (return True) >> coin)+  return (x,x)++nest_share2 = assertEqual ipair [(0,0),(1,1)] $ do+  x <- share (share coin >>= id)+  return (x,x)++dup_dup = assertEqual ippair [((0,0),(0,0)),((1,1),(1,1))] $ dup (dup coin)++dup_two_coins = assertEqual ippair [((0,0),(0,0)),((0,1),(0,1))+                                   ,((1,0),(1,0)),((1,1),(1,1))] $ do+  x <- share coin+  y <- share coin+  return (return (x,y), return (x,y))++dup_head = assertEqual ipair [(0,0),(1,1)] $ heads (cons coin nil)++heads l = do+  xs <- share l+  return (first xs, first xs)++dup_head_lazy = assertEqual ipair [(0,0),(1,1)] $ heads (cons coin undefined)
+ explicit-sharing.cabal view
@@ -0,0 +1,37 @@+Name:          explicit-sharing+Version:       0.1+Cabal-Version: >= 1.6+Synopsis:      Explicit Sharing of Monadic Effects+Description:   ++  This package implements a monad transformer for sharing monadic+  effects of monads for non-determinism.++Category:      Control, Monads+License:       PublicDomain+License-File:  LICENSE+Author:        Chung-chieh Shan, Oleg Kiselyov, and Sebastian Fischer+Maintainer:    sebf@informatik.uni-kiel.de+Bug-Reports:   mailto:sebf@informatik.uni-kiel.de+Build-Type:    Custom+Stability:     experimental++Extra-Source-Files: Test.hs, List.hs++Library+  Build-Depends:    base, containers, mtl+  Exposed-Modules:  Control.Monad.Trans.ContT,+                    Control.Monad.Sharing,+                    Control.Monad.Sharing.Lazy+                    Control.Monad.Sharing.Lazy.State,+                    Control.Monad.Sharing.Lazy.ContReader,+                    Control.Monad.Sharing.Lazy.ContReaderNoThunks,+                    Control.Monad.Sharing.Lazy.ContReaderNoThunksInlined+  Other-Modules:    Control.Monad.Sharing.Memoization+  Ghc-Options:      -Wall+  Extensions:       GeneralizedNewtypeDeriving,+                    ExistentialQuantification,+                    MultiParamTypeClasses,+                    FlexibleInstances,+                    FlexibleContexts,+                    Rank2Types