Memoize.hs

-- |
-- Module:     Control.Wire.Trans.Memoize
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Memoizing wire transformers.

module Control.Wire.Trans.Memoize
    ( -- * Memoizing
      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


-- | Remember the most recently produced values.  You can limit both the
-- maximum age and the number of remembered values.  The second input
-- value specifies the maximum age, the third specifies the maximum
-- number.
--
-- Note: Inhibtion is never remembered.
--
-- Note: Decreasing the size limit has O(n * log n) complexity, where n
-- is the difference to the old limit.
--
-- * Depends: Current instant.
--
-- * Inhibits: Whenever result is not cached and argument wire inhibits.

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)


-- | Remember the last produced value.  Whenever an input is repeated,
-- the argument wire is ignored and the memoized result is returned
-- instantly.  Note: inhibition will not be remembered.
--
-- * Depends: Current instant.
--
-- * Inhibits: Like the argument wire for non-memoized inputs.

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')