summaryrefslogtreecommitdiffstats
path: root/src/Control/CacheArrow.hs
blob: ff77112ac9ce0a25701fe15f06c0437e50af41e6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, Arrows #-}

module Control.CacheArrow ( CacheArrow
                          , runCache'
                          , runCache
                          ) where

import Prelude hiding ((.), id)
import Control.Arrow
import Control.Arrow.Transformer
import Control.Category


data CacheArrow a b c = CacheArrow (Maybe (b, c)) (a b c)

instance Arrow a => Category (CacheArrow a) where
  (CacheArrow _ g) . (CacheArrow _ f) = CacheArrow Nothing (g . f)

  id = arr id

instance Arrow a => Arrow (CacheArrow a) where
  arr = lift . arr
  first (CacheArrow _ f) = lift . first $ f
  second (CacheArrow _ f) = lift . second $ f

instance ArrowChoice a => ArrowChoice (CacheArrow a) where
  left (CacheArrow _ f) = lift . left $ f
  right (CacheArrow _ f) = lift . right $ f

instance Arrow a => ArrowTransformer CacheArrow a where
  lift = CacheArrow Nothing


runCacheAlways :: Arrow a => CacheArrow a b c -> a b (c, CacheArrow a b c)
runCacheAlways (CacheArrow _ f) = proc b -> do
  c <- f -< b
  returnA -< (c, CacheArrow (Just (b, c)) f)

runCache' :: (ArrowChoice a, Eq b) => CacheArrow a b c -> a b (c, Bool, CacheArrow a b c)
runCache' a@(CacheArrow cache _) = proc b ->
  case cache of
    (Just (b', c')) | b == b' -> returnA -< (c', False, a)
    _ -> do
      (c, cache') <- runCacheAlways a -< b
      returnA -< (c, True, cache')

runCache :: (ArrowChoice a, Eq b) => CacheArrow a b c -> a b (c, CacheArrow a b c)
runCache a = runCache' a >>^ (\(c, _, cache) -> (c, cache))