{-# 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.Monad
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 { Container arr -> arr
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 -> Cache c k e m (Maybe v)
lookup k
k = do
Container (c k e)
c <- ReaderCache (Container (c k e)) m (Container (c k e))
forall (m :: * -> *) c. Monad m => ReaderCache c m c
container
e
e <- m e -> ReaderCache (Container (c k e)) m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m e -> ReaderCache (Container (c k e)) m e)
-> m e -> ReaderCache (Container (c k e)) m e
forall a b. (a -> b) -> a -> b
$ c k e -> k -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (Container (c k e) -> c k e
forall arr. Container arr -> arr
toArray Container (c k e)
c) k
k
Maybe v -> Cache c k e m (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (if e -> Bool
forall a v. MaybeLike a v => a -> Bool
isNothing e
e then Maybe v
forall a. Maybe a
Nothing else v -> Maybe v
forall a. a -> Maybe a
Just (e -> v
forall a v. MaybeLike a v => a -> v
fromJust e
e))
{-# INLINE add #-}
add :: k -> v -> Cache c k e m ()
add k
k v
v = do
Container (c k e)
c <- ReaderCache (Container (c k e)) m (Container (c k e))
forall (m :: * -> *) c. Monad m => ReaderCache c m c
container
m () -> Cache c k e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Cache c k e m ()) -> m () -> Cache c k e m ()
forall a b. (a -> b) -> a -> b
$ c k e -> k -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (Container (c k e) -> c k e
forall arr. Container arr -> arr
toArray Container (c k e)
c) k
k (v -> e
forall a v. MaybeLike a v => v -> a
just v
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 :: (k -> Cache c k e m v) -> k -> Cache c k e m v
memo k -> Cache c k e m v
f k
k = do
Container (c k e)
c <- ReaderCache (Container (c k e)) m (Container (c k e))
forall (m :: * -> *) c. Monad m => ReaderCache c m c
container
e
e <- m e -> ReaderCache (Container (c k e)) m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m e -> ReaderCache (Container (c k e)) m e)
-> m e -> ReaderCache (Container (c k e)) m e
forall a b. (a -> b) -> a -> b
$ c k e -> k -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (Container (c k e) -> c k e
forall arr. Container arr -> arr
toArray Container (c k e)
c) k
k
if e -> Bool
forall a v. MaybeLike a v => a -> Bool
isNothing e
e
then do
v
v <- k -> Cache c k e m v
f k
k
m () -> ReaderCache (Container (c k e)) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderCache (Container (c k e)) m ())
-> m () -> ReaderCache (Container (c k e)) m ()
forall a b. (a -> b) -> a -> b
$ c k e -> k -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (Container (c k e) -> c k e
forall arr. Container arr -> arr
toArray Container (c k e)
c) k
k (v -> e
forall a v. MaybeLike a v => v -> a
just v
v)
v -> Cache c k e m v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v
else v -> Cache c k e m v
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> v
forall a v. MaybeLike a v => a -> v
fromJust e
e)
type family Array (m :: * -> *) :: * -> * -> *
type instance Array (ST s) = STArray s
type instance Array IO = IOArray
type instance Array (ReaderCache c (ST s)) = STArray s
type instance Array (ReaderCache c 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 :: ArrayCache k e m a -> (k, k) -> m a
evalArrayMemo = ArrayCache k e m a -> (k, k) -> m a
forall k e v (arr :: * -> * -> *) (m :: * -> *) a.
(Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m a
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 :: ArrayCache k e m a -> (k, k) -> m (a, Array m k e)
runArrayMemo = ArrayCache k e m a -> (k, k) -> m (a, Array m k e)
forall k e v (arr :: * -> * -> *) (m :: * -> *) a.
(Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m (a, arr k e)
genericRunArrayMemo
type family UArray (m :: * -> *) :: * -> * -> *
type instance UArray (ST s) = STUArray s
type instance UArray IO = IOUArray
type instance UArray (ReaderCache c (ST s)) = STUArray s
type instance UArray (ReaderCache c 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 :: UArrayCache k e m a -> (k, k) -> m a
evalUArrayMemo = UArrayCache k e m a -> (k, k) -> m a
forall k e v (arr :: * -> * -> *) (m :: * -> *) a.
(Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m a
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 :: UArrayCache k e m a -> (k, k) -> m (a, UArray m k e)
runUArrayMemo = UArrayCache k e m a -> (k, k) -> m (a, UArray m k e)
forall k e v (arr :: * -> * -> *) (m :: * -> *) a.
(Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m (a, arr k e)
genericRunArrayMemo
genericEvalArrayMemo :: (Ix k, MaybeLike e v, MArray arr e m) =>
Cache arr k e m a -> (k, k) -> m a
{-# INLINE genericEvalArrayMemo #-}
genericEvalArrayMemo :: Cache arr k e m a -> (k, k) -> m a
genericEvalArrayMemo Cache arr k e m a
m (k, k)
lu = do
arr k e
arr <- (k, k) -> e -> m (arr k e)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (k, k)
lu e
forall a v. MaybeLike a v => a
nothing
Cache arr k e m a -> Container (arr k e) -> m a
forall r (m :: * -> *) a. ReaderCache r m a -> r -> m a
evalReaderCache Cache arr k e m a
m (arr k e -> Container (arr k e)
forall arr. arr -> Container arr
Container arr k e
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 :: Cache arr k e m a -> (k, k) -> m (a, arr k e)
genericRunArrayMemo Cache arr k e m a
m (k, k)
lu = do
arr k e
arr <- (k, k) -> e -> m (arr k e)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (k, k)
lu e
forall a v. MaybeLike a v => a
nothing
a
a <- Cache arr k e m a -> Container (arr k e) -> m a
forall r (m :: * -> *) a. ReaderCache r m a -> r -> m a
evalReaderCache Cache arr k e m a
m (arr k e -> Container (arr k e)
forall arr. arr -> Container arr
Container arr k e
arr)
(a, arr k e) -> m (a, arr k e)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, arr k e
arr)