Cache.hs 4.79 KB
Newer Older
1
{-# LANGUAGE DefaultSignatures #-}
2
{-# LANGUAGE FlexibleInstances #-}
Sven Keidel's avatar
Sven Keidel committed
3
{-# LANGUAGE FunctionalDependencies #-}
4
5
6
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
Sven Keidel's avatar
Sven Keidel committed
7
8
module Control.Arrow.Fix.Cache where

9
import Prelude hiding (lookup)
10

Sven Keidel's avatar
Sven Keidel committed
11
import Control.Arrow
12
import Control.Arrow.Trans
13
14
15
16
17
18
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Writer

Sven Keidel's avatar
Sven Keidel committed
19
import Data.Profunctor
Sven Keidel's avatar
Sven Keidel committed
20
import Data.Abstract.Stable
Sven Keidel's avatar
Sven Keidel committed
21
22

class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
23
24
  type Widening c

25
  -- | Initializes a cache entry with 'bottom'.
Sven Keidel's avatar
Sven Keidel committed
26
27
28
29
  --
  -- The operation satisfies the following laws:
  --  * 'initialize' is an update with bottom: @(_,_,b)<-update-<(Unstable,a,⊥) ⊑ b'<-initialize-<a@
  initialize :: (?cacheWidening :: Widening c) => c a b
30

Sven Keidel's avatar
Sven Keidel committed
31
32
33
34
  -- | Looks up if there is an entry in the cache.
  lookup :: c a (Maybe (Stable,b))

  -- | Update an existing entry in the cache.
Sven Keidel's avatar
Sven Keidel committed
35
36
37
38
  --
  -- The operation satisfies the following laws:
  --  * 'update' increases the entry: if @(s',a',b') <- update -< (s,a,b)@ then @a ⊑ a'@, and @b ⊑ b'@
  --  * 'update' does not forget: if @(s',a',b') <- update -< (s,a,b); m <- lookup -< a@ then @Just (s ⊔ s',b') ⊑ m@
39
  update :: (?cacheWidening :: Widening c) => c (Stable,a,b) (Stable,a,b)
Sven Keidel's avatar
Sven Keidel committed
40

Sven Keidel's avatar
Sven Keidel committed
41
42
43
  -- | Write a new entry to the cache.
  write :: c (a,b,Stable) ()

Sven Keidel's avatar
Sven Keidel committed
44
45
  -- | Set a given entry to stable or unstable.
  setStable :: c (Stable,a) ()
46

Sven Keidel's avatar
Sven Keidel committed
47
  default initialize :: (c ~ t c', ArrowTrans t, ArrowCache a b c', ?cacheWidening :: Widening c') => c a b
48
49
50
51
  default lookup :: (c ~ t c', ArrowTrans t, ArrowCache a b c') => c a (Maybe (Stable,b))
  default write :: (c ~ t c', ArrowTrans t, ArrowCache a b c') => c (a,b,Stable) ()
  default update :: (c ~ t c', ArrowTrans t, ArrowCache a b c', ?cacheWidening :: Widening c') => c (Stable,a,b) (Stable,a,b)
  default setStable :: (c ~ t c', ArrowTrans t, ArrowCache a b c') => c (Stable,a) ()
52
53
54
55
56
57
58
59
60
61
62
63

  initialize = lift' initialize
  lookup = lift' lookup
  write = lift' write
  update = lift' update
  setStable = lift' setStable

  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE write #-}
  {-# INLINE update #-}
  {-# INLINE setStable #-}
64

65
class (ArrowIterateCache a b c) => ArrowParallelCache a b c where
Sven Keidel's avatar
Sven Keidel committed
66
  lookupOldCache :: (?cacheWidening :: Widening c) => c a b
67
  lookupNewCache :: c a (Maybe b)
68
  updateNewCache :: (?cacheWidening :: Widening c) => c (a,b) b
69
70
  isStable :: c () Stable

Sven Keidel's avatar
Sven Keidel committed
71
  default lookupOldCache :: (c ~ t c', ArrowTrans t, ArrowParallelCache a b c', ?cacheWidening :: Widening c') => c a b
72
73
74
  default lookupNewCache :: (c ~ t c', ArrowTrans t, ArrowParallelCache a b c') => c a (Maybe b)
  default updateNewCache :: (c ~ t c', ArrowTrans t, ArrowParallelCache a b c', ?cacheWidening :: Widening c') => c (a,b) b
  default isStable :: (c ~ t c', ArrowTrans t, ArrowParallelCache a b c') => c () Stable
75
76
77
78
79
80
81
82
83
84
85

  lookupOldCache = lift' lookupOldCache
  lookupNewCache = lift' lookupNewCache
  updateNewCache = lift' updateNewCache
  isStable = lift' isStable

  {-# INLINE lookupOldCache #-}
  {-# INLINE lookupNewCache #-}
  {-# INLINE updateNewCache #-}
  {-# INLINE isStable #-}

86
87
class (Arrow c, Profunctor c) => ArrowIterateCache a b c | c -> a, c -> b where
  nextIteration :: c (a,b) (a,b)
88
  default nextIteration :: (c ~ t c', ArrowTrans t, ArrowIterateCache a b c') => c (a,b) (a,b)
89
90
  nextIteration = lift' nextIteration
  {-# INLINE nextIteration #-}
Sven Keidel's avatar
Sven Keidel committed
91
92
93

class (Arrow c, Profunctor c) => ArrowGetCache cache c where
  getCache :: c () cache
94
  default getCache :: (c ~ t c', ArrowTrans t, ArrowGetCache cache c') => c () cache
Sven Keidel's avatar
Sven Keidel committed
95
96
  getCache = lift' getCache
  {-# INLINE getCache #-}
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

------------- Instances --------------
instance ArrowCache a b c => ArrowCache a b (ConstT r c) where
  type Widening (ConstT r c) = Widening c

instance ArrowCache a b c => ArrowCache a b (ReaderT r c) where
  type Widening (ReaderT r c) = Widening c

instance ArrowParallelCache a b c => ArrowParallelCache a b (ReaderT r c)
instance ArrowIterateCache a b c => ArrowIterateCache a b (ReaderT r c)
instance ArrowGetCache cache c => ArrowGetCache cache (ReaderT r c)

instance ArrowCache a b c => ArrowCache a b (StateT s c) where
  type Widening (StateT s c) = Widening c

instance ArrowParallelCache a b c => ArrowParallelCache a b (StateT s c)
instance ArrowIterateCache a b c => ArrowIterateCache a b (StateT s c)
instance ArrowGetCache cache c => ArrowGetCache cache (StateT s c)

instance (Applicative f, ArrowCache a b c) => ArrowCache a b (StaticT f c) where
  type Widening (StaticT f c) = Widening c
  {-# SPECIALIZE instance ArrowCache a b c => ArrowCache a b (StaticT ((->) r) c) #-}

instance (Monoid w, ArrowCache a b c) => ArrowCache a b (WriterT w c) where
  type Widening (WriterT w c) = Widening c