explicit-sharing 0.6 → 0.7

raw patch · 11 files changed

+167/−45 lines, 11 filesdep ~derivesetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: derive

API changes (from Hackage documentation)

Files

• Control/Monad/Sharing.hs +3/−1
• Control/Monad/Sharing/Classes.hs +11/−15
• Control/Monad/Sharing/FirstOrder.hs +1/−1
• Control/Monad/Sharing/Implementation/CPS.hs +13/−11
• Control/Monad/Sharing/Implementation/SlowState.hs +55/−0
• Control/Monad/Sharing/Implementation/SlowStateCPS.hs +60/−0
• Data/Monadic/Derive.hs +6/−4
• Data/Monadic/List.hs +10/−6
• Setup.hs +1/−2
• Test.hs +2/−2
• explicit-sharing.cabal +5/−3

@@ -14,7 +14,7 @@    -- * Classes -  Sharing(..), Shareable(..), Convertible(..), convert,+  Sharing(..), Shareable(..), Convertible(..),    -- * Monad transformer @@ -25,3 +25,5 @@ import Control.Monad import Control.Monad.Sharing.Classes import Control.Monad.Sharing.Implementation.CPS+-- import Control.Monad.Sharing.Implementation.SlowState+-- import Control.Monad.Sharing.Implementation.SlowStateCPS

@@ -19,7 +19,7 @@ -- sharing. module Control.Monad.Sharing.Classes ( -  Sharing(..), Shareable(..), Convertible(..), convert,+  Sharing(..), Shareable(..), Convertible(..),    MInt, MChar, MBool @@ -46,7 +46,7 @@ -- could be applied. class Shareable m a  where-  shareArgs :: Monad n => +  shareArgs :: Monad n =>                (forall b . Shareable m b => m b -> n (m b)) -> a -> n a  type MInt  m = Int@@ -98,46 +98,42 @@ -- could be applied. class Convertible m a b  where-  convArgs :: (forall c d . Convertible m c d => c -> m d) -> a -> m b---- | Converts a convertible value recursively.-convert :: Convertible m a b => a -> m b-convert = convArgs convert+  convert :: a -> m b  instance Monad m => Convertible m Bool Bool  where-  convArgs _ = return+  convert = return  instance Monad m => Convertible m Int Int  where-  convArgs _ = return+  convert = return  instance Monad m => Convertible m Char Char  where-  convArgs _ = return+  convert = return  instance Monad m => Convertible m [Bool] [Bool]  where-  convArgs _ = return+  convert = return  instance Monad m => Convertible m [Int] [Int]  where-  convArgs _ = return+  convert = return  instance Monad m => Convertible m [Char] [Char]  where-  convArgs _ = return+  convert = return  -- | -- An instance to convert ordinary lists into lists with monadic -- elements. instance (Monad m, Convertible m a b) => Convertible m [a] [m b]  where-  convArgs f = return . map f+  convert = return . map convert  -- | -- An instance to convert lists with monadic elements into ordinary -- lists. instance (Monad m, Convertible m a b) => Convertible m [m a] [b]  where-  convArgs f = mapM (>>=f)+  convert = mapM (>>=convert)

@@ -16,7 +16,7 @@    -- * Classes -  Sharing(..), Shareable(..), Convertible(..), convert,+  Sharing(..), Shareable(..), Convertible(..),    -- * Monad transformer 

@@ -21,8 +21,10 @@    Lazy, evalLazy, runLazy, -  Store, emptyStore, freshLabel, lookupValue, storeValue+  Store, emptyStore, freshLabel, lookupValue, storeValue, +  Untyped(..), typed+  ) where  import Control.Monad       ( MonadPlus(..) )@@ -116,16 +118,16 @@   share a = memo (a >>= shareArgs share)  -- This is an inlined version of the following definition:--- --- > memo :: MonadState Store m => m a -> m (m a)--- > memo a = do key <- freshLabel--- >             return $ do thunk <- lookupValue key--- >                         case thunk of--- >                           Just x  -> return x--- >                           Nothing -> do x <- a--- >                                         storeValue key x--- >                                         return x---++-- memo :: MonadState Store m => m a -> m (m a)+-- memo a = do key <- freshLabel+--             return $ do thunk <- lookupValue key+--                         case thunk of+--                           Just x  -> return x+--                           Nothing -> do x <- a+--                                         storeValue key x+--                                         return x+ memo :: Lazy m a -> Lazy m (Lazy m a) memo a = Lazy (\c (Store key heap) ->       c (Lazy (\c s@(Store _ heap) -> 

@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}++module Control.Monad.Sharing.Implementation.SlowState (++  Lazy, evalLazy,++  ThunkStore, Thunk(..), emptyThunks, getFreshKey, lookupThunk, insertThunk++ ) where++import Data.Maybe ( fromJust )+import Control.Monad.State++import qualified Data.IntMap as M++import Control.Monad.Sharing.Classes+import Control.Monad.Sharing.Implementation.CPS ( Untyped(..), typed )++type Lazy m = StateT ThunkStore m++evalLazy :: (Monad m, Convertible (Lazy m) a b) => Lazy m a -> m b+evalLazy m = evalStateT (m >>= convert) emptyThunks++instance Monad m => Sharing (StateT ThunkStore m)+ where+  share a = memo (a >>= shareArgs share)++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++data ThunkStore = ThunkStore { nextLabel :: Int, heap :: M.IntMap Untyped }++data Thunk m a = Uneval (m a) | Eval a++emptyThunks :: ThunkStore+emptyThunks = ThunkStore 1 M.empty++getFreshKey :: MonadState ThunkStore m => m Int+getFreshKey = do s <- get+                 put (s { nextLabel = nextLabel s + 1 })+                 return (nextLabel s)++lookupThunk :: MonadState ThunkStore m => Int -> m (Thunk m a)+lookupThunk k = gets (typed . fromJust . M.lookup k . heap)++insertThunk :: MonadState ThunkStore m => Int -> a -> m ()+insertThunk k v = modify (\s -> s { heap = M.insert k (Untyped v) (heap s) })+

@@ -0,0 +1,60 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, Rank2Types #-}++module Control.Monad.Sharing.Implementation.SlowStateCPS (++  Lazy, evalLazy++ ) where++import Control.Monad.State++import Control.Monad.Sharing.Classes+import Control.Monad.Sharing.Implementation.SlowState hiding ( Lazy, evalLazy )++newtype Lazy m a = Lazy {+  fromLazy :: forall w . (a -> ThunkStore -> m w) -> ThunkStore -> m w+ }++evalLazy :: (Monad m, Convertible (Lazy m) a b) => Lazy m a -> m b+evalLazy m = runLazy (m >>= convert)++runLazy :: Monad m => Lazy m a -> m a+runLazy m = fromLazy m (\a _ -> return a) emptyThunks++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 err = Lazy (\_ _ -> fail err)++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 ThunkStore (Lazy m)+ where+  get   = Lazy (\c s -> c s s)+  put s = Lazy (\c _ -> c () s)++instance MonadTrans Lazy+ where+  lift a = Lazy (\c s -> a >>= flip c s)++instance MonadIO m => MonadIO (Lazy m)+ where+  liftIO = lift . liftIO++instance Monad m => Sharing (Lazy m)+ where+  share a = memo (a >>= shareArgs share)++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

@@ -19,6 +19,8 @@ import Control.Applicative import Control.Arrow +-- import Debug.Trace+ typeParamName, branchResName, funArgName :: String typeParamName = "m"; branchResName = "a"; funArgName = "fun" @@ -323,13 +325,13 @@  makeConvToM :: QualConDecl -> Conv Match makeConvToM (QualConDecl _ [] [] con) =-  return $ Match sl (Ident "convArgs") [PVar fun,cpat] Nothing+  return $ Match sl fun [cpat] Nothing              (UnGuardedRhs rhs) (BDecls [])  where   name = consName con   args = map (Ident.(:[]).fst) . zip ['a'..] $ consArgs con -  fun  = Ident funArgName+  fun  = Ident "convert"   cpat = UnQual name `PApp` map PVar args    rhs  = foldl App (Var (UnQual (convName False name))) $@@ -339,13 +341,13 @@  makeConvFromM :: QualConDecl -> Conv Match makeConvFromM (QualConDecl _ [] [] con) =-  return $ Match sl (Ident "convArgs") [PVar fun,cpat] Nothing+  return $ Match sl fun [cpat] Nothing              (UnGuardedRhs rhs) (BDecls [])  where   name = consName con   args = map (Ident.(:[]).fst) . zip ['a'..] $ consArgs con -  fun  = Ident funArgName+  fun  = Ident "convert"   cpat = UnQual (convName True name) `PApp` map PVar args   cexp = foldl App (Con (UnQual name)) $ map (Var . UnQual) args 

@@ -16,7 +16,7 @@   ) where -import Control.Monad                 ( MonadPlus, ap )+import Control.Monad                 ( MonadPlus ) import Control.Monad.Sharing.Classes ( Shareable(..), Convertible(..) )  -- | Data type for lists where both the head and tail are monadic.@@ -55,20 +55,24 @@ instance (Monad m, Shareable m a) => Shareable m (List m a)  where   shareArgs _ Nil         = return Nil-  shareArgs f (Cons x xs) = return Cons `ap` f x `ap` f xs+  shareArgs f (Cons x xs) = do y  <- f x+                               ys <- f xs+                               return (Cons y ys)  -- | -- This instance enables the function 'Control.Monad.Sharing.convert' -- to transform ordinary Haskell lists into nested monadic lists. instance (Monad m, Convertible m a b) => Convertible m [a] (List m b)  where-  convArgs _ []     = return Nil-  convArgs f (x:xs) = return (Cons (f x) (f xs))+  convert []     = return Nil+  convert (x:xs) = return (Cons (convert x) (convert xs))  -- | -- This instance enables the function 'Control.Monad.Sharing.convert' -- to transform nested monadic lists into ordinary Haskell lists. instance (Monad m, Convertible m a b) => Convertible m (List m a) [b]  where-  convArgs _ Nil         = return []-  convArgs f (Cons x xs) = return (:) `ap` (x >>= f) `ap` (xs >>= f)+  convert Nil         = return []+  convert (Cons x xs) = do y  <- x  >>= convert+                           ys <- xs >>= convert+                           return (y:ys)

@@ -5,7 +5,6 @@ main = defaultMainWithHooks $ simpleUserHooks { runTests = runTestSuite }  runTestSuite _ _ _ _ =- do pid <- runCommand $ "ghc -hide-package monads-fd "-                     ++ "-hide-package transformers -e main Test.hs"+ do pid <- runCommand $ "ghc -hide-package transformers -e main Test.hs"     waitForProcess pid >>= exitWith 

@@ -36,7 +36,7 @@  instance Monad m => Convertible m (Int,Int) (Int,Int)  where-  convArgs _ = return+  convert = return  instance (Monad m, Shareable m a) => Shareable m (m a, m a)  where@@ -44,7 +44,7 @@  instance (Monad m, Convertible m a b) => Convertible m (m a, m a) (b, b)  where-  convArgs f (x,y) = return (,) `ap` (x >>= f) `ap` (y >>= f)+  convert (x,y) = return (,) `ap` (x >>= convert) `ap` (y >>= convert)  assertEqual :: (Shareable (Lazy []) a, Convertible (Lazy []) a b, Eq b)             => [b] -> Lazy [] a -> Bool

@@ -1,5 +1,5 @@ Name:          explicit-sharing-Version:       0.6+Version:       0.7 Cabal-Version: >= 1.6 Synopsis:      Explicit Sharing of Monadic Effects Description:   @@ -22,14 +22,16 @@ Library   Build-Depends:    base >= 3 && < 5, containers, mtl,                     template-haskell >= 2.4 && < 2.5,-                    derive >= 2.3 && < 2.4+                    derive >= 2.3.0.1 && < 2.4   Exposed-Modules:  Control.Monad.Sharing,                     Control.Monad.Sharing.Classes,                     Control.Monad.Sharing.FirstOrder,                     Data.Monadic.Derive,                     Data.Monadic.List   Other-Modules:    Control.Monad.Sharing.Implementation.CPS,-                    Control.Monad.Sharing.Implementation.FirstOrder+                    Control.Monad.Sharing.Implementation.FirstOrder,+                    Control.Monad.Sharing.Implementation.SlowState,+                    Control.Monad.Sharing.Implementation.SlowStateCPS   Ghc-Options:      -Wall -fno-warn-name-shadowing   Extensions:       ExistentialQuantification,                     MultiParamTypeClasses,