{-# LANGUAGE NoImplicitPrelude,
MultiParamTypeClasses, FunctionalDependencies,
FlexibleInstances, FlexibleContexts, TypeSynonymInstances,
UndecidableInstances, TypeFamilies #-}
module Control.Monad.Memo.Array
(
Array,
ArrayCache,
ArrayMemo,
evalArrayMemo,
runArrayMemo,
UArray,
UArrayCache,
UArrayMemo,
evalUArrayMemo,
runUArrayMemo,
Container(..),
Cache,
genericEvalArrayMemo,
genericRunArrayMemo
) where
import Data.Function
import Data.Maybe (Maybe(..))
import Data.Array.ST
import Data.Array.IO
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans.Class
import Control.Monad.ST
import System.IO
import Data.MaybeLike
import Control.Monad.Memo.Class
import Control.Monad.Trans.Memo.ReaderCache
newtype Container arr = Container { toArray :: arr }
type Cache arr k e = ReaderCache (Container (arr k e))
instance (Monad m, Ix k, MaybeLike e v, MArray c e m) =>
MonadCache k v (Cache c k e m) where
{-# INLINE lookup #-}
lookup k = do
c <- container
e <- lift $ readArray (toArray c) k
return (if isNothing e then Nothing else Just (fromJust e))
{-# INLINE add #-}
add k v = do
c <- container
lift $ writeArray (toArray c) k (just v)
instance (Monad m, Ix k, MaybeLike e v, MArray c e m) =>
MonadMemo k v (Cache c k e m) where
{-# INLINE memo #-}
memo f k = do
c <- container
e <- lift $ readArray (toArray c) k
if isNothing e
then do
v <- f k
lift $ writeArray (toArray c) k (just v)
return v
else return (fromJust e)
type family Array (m :: * -> *) :: * -> * -> *
type instance Array (ST s) = STArray s
type instance Array IO = IOArray
type ArrayCache k e m = Cache (Array m) k e m
class MaybeLike e v => ArrayMemo v e | v -> e
evalArrayMemo :: (Ix k, MArray (Array m) e m, ArrayMemo v e) =>
ArrayCache k e m a
-> (k,k)
-> m a
{-# INLINE evalArrayMemo #-}
evalArrayMemo = genericEvalArrayMemo
runArrayMemo :: (Ix k, MArray (Array m) e m, ArrayMemo v e) =>
ArrayCache k e m a
-> (k,k)
-> m (a, Array m k e)
{-# INLINE runArrayMemo #-}
runArrayMemo = genericRunArrayMemo
type family UArray (m :: * -> *) :: * -> * -> *
type instance UArray (ST s) = STUArray s
type instance UArray IO = IOUArray
type UArrayCache k e m = Cache (UArray m) k e m
class MaybeLike e v => UArrayMemo v e | v -> e
evalUArrayMemo :: (Ix k, MArray (UArray m) e m, UArrayMemo v e) =>
UArrayCache k e m a
-> (k,k)
-> m a
{-# INLINE evalUArrayMemo #-}
evalUArrayMemo = genericEvalArrayMemo
runUArrayMemo :: (Ix k, MArray (UArray m) e m, UArrayMemo v e) =>
UArrayCache k e m a
-> (k,k)
-> m (a, UArray m k e)
{-# INLINE runUArrayMemo #-}
runUArrayMemo = genericRunArrayMemo
genericEvalArrayMemo :: (Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m a
{-# INLINE genericEvalArrayMemo #-}
genericEvalArrayMemo m lu = do
arr <- newArray lu nothing
evalReaderCache m (Container arr)
genericRunArrayMemo :: (Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m (a, arr k e)
{-# INLINE genericRunArrayMemo #-}
genericRunArrayMemo m lu = do
arr <- newArray lu nothing
a <- evalReaderCache m (Container arr)
return (a, arr)