module Control.Wire.Trans.Memoize
(
WCache(..),
WPurify(..)
)
where
import Control.Arrow
import Control.Monad.Fix
import Control.Wire.Classes
import Control.Wire.TimedMap
import Control.Wire.Types
import Data.AdditiveGroup
class Arrow (>~) => WCache t (>~) | (>~) -> t where
cache :: Ord a => Wire e (>~) a b -> Wire e (>~) ((a, t), Int) b
instance (AdditiveGroup t, MonadClock t m, Ord t) => WCache t (Kleisli m) where
cache = cache' tmEmpty
where
cache' :: Ord a => TimedMap t a b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) ((a, t), Int) b
cache' xs' w' =
WmGen $ \((x', maxAge), limit) -> do
t <- getTime
(mx, w) <-
case tmLookup x' xs' of
Nothing -> toGenM w' x'
Just x -> return (Right x, w')
let xs = tmLimitSize limit .
tmLimitAge (t ^-^ maxAge) .
either (const id) (tmInsert t x') mx $ xs'
return (mx, cache' xs w)
class Arrow (>~) => WPurify (>~) where
purify :: Eq a => Wire e (>~) a b -> Wire e (>~) a b
instance Monad m => WPurify (Kleisli m) where
purify w' =
case w' of
WmPure f ->
WmPure $ \x' ->
let (mx, w) = f x' in
(mx, either (const $ purify w) (\x -> purify' x' x w) mx)
WmGen c ->
WmGen $ \x' -> do
(mx, w) <- c x'
return (mx, either (const $ purify w) (\x -> purify' x' x w) mx)
where
purify' :: Eq a => a -> b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) a b
purify' x0' x0 =
fix $ \again w' ->
case w' of
WmPure f ->
WmPure $ \x' ->
if x' /= x0'
then
let (mx, w) = f x' in
(mx, either (const $ again w) (\x -> purify' x' x w) mx)
else (Right x0, again w')
WmGen c ->
WmGen $ \x' ->
if x' /= x0'
then do
(mx, w) <- c x'
return (mx, either (const $ again w) (\x -> purify' x' x w) mx)
else return (Right x0, again w')