Immutable.hs 24.5 KB
Newer Older
1
{-# LANGUAGE Arrows #-}
2
{-# LANGUAGE DataKinds #-}
3
4
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
5
{-# LANGUAGE GADTs #-}
6
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7
{-# LANGUAGE ImplicitParams #-}
Sven Keidel's avatar
Sven Keidel committed
8
{-# LANGUAGE MultiParamTypeClasses #-}
9
{-# LANGUAGE OverloadedStrings #-}
Sven Keidel's avatar
Sven Keidel committed
10
{-# LANGUAGE PolyKinds #-}
Sven Keidel's avatar
Sven Keidel committed
11
{-# LANGUAGE RankNTypes #-}
Sven Keidel's avatar
Sven Keidel committed
12
{-# LANGUAGE ScopedTypeVariables #-}
13
14
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
15
{-# LANGUAGE UnboxedTuples #-}
16
{-# LANGUAGE UndecidableInstances #-}
Sven Keidel's avatar
Sven Keidel committed
17
module Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable where
Sven Keidel's avatar
Sven Keidel committed
18

19
import           Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))
Sven Keidel's avatar
Sven Keidel committed
20

21
import           Control.Category
22
import           Control.Arrow hiding ((<+>))
23
import           Control.Arrow.Primitive
24
import           Control.Arrow.Strict
25
26
27
28
29
import           Control.Arrow.Trans
import           Control.Arrow.State
import           Control.Arrow.Fix.ControlFlow as ControlFlow
import           Control.Arrow.Fix.Context as Context
import           Control.Arrow.Fix.Cache as Cache
30
import           Control.Arrow.Order (ArrowLowerBounded)
31
import qualified Control.Arrow.Order as Order
32
import           Control.Arrow.Transformer.State
Sven Keidel's avatar
Sven Keidel committed
33

34
35
36
37
38
import           Data.Profunctor.Unsafe
import           Data.Empty
import           Data.Order hiding (lub)
import           Data.Coerce
import           Data.Identifiable
39
40
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
41
42
import           Data.Monoidal
import           Data.Maybe
43
import           Data.Text.Prettyprint.Doc
Sven Keidel's avatar
Sven Keidel committed
44

45
import           Data.Abstract.Stable
46
import qualified Data.Abstract.Widening as W
Sven Keidel's avatar
Sven Keidel committed
47

48
import           GHC.Exts
49

50
newtype CacheT cache a b c x y = CacheT { unCacheT :: StateT (cache a b) c x y}
51
  deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,ArrowTrans,
52
            ArrowState (cache a b),ArrowControlFlow stmt, ArrowPrimitive)
53

Sven Keidel's avatar
Sven Keidel committed
54
instance (IsEmpty (cache a b), ArrowRun c) => ArrowRun (CacheT cache a b c) where
55
  type Run (CacheT cache a b c) x y = Run c x (cache a b,y)
56
  run f = run (lmap (\x -> (empty, x)) (unlift f))
Sven Keidel's avatar
Sven Keidel committed
57
58
  {-# INLINE run #-}

59
instance ArrowLift (CacheT cache a b c) where
60
  type Underlying (CacheT cache a b c) x y = c (cache a b, x) (cache a b, y)
Sven Keidel's avatar
Sven Keidel committed
61

Sven Keidel's avatar
Sven Keidel committed
62
63
64
instance (Arrow c, Profunctor c) => ArrowGetCache (cache a b) (CacheT cache a b c) where
  getCache = CacheT get

65
66
67
68
instance (Arrow c, ArrowContext ctx c) => ArrowContext ctx (CacheT cache a b c) where
  localContext (CacheT f) = CacheT (localContext f)
  {-# INLINE localContext #-}

Sven Keidel's avatar
Sven Keidel committed
69
70
71
72
instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT cache a b c) where
  app = CacheT (app .# first coerce)
  {-# INLINE app #-}

73
74
----- Basic Cache -----
newtype Cache a b = Cache { getMap :: HashMap a (Stable,b)}
75

76
77
78
instance IsEmpty (Cache a b) where
  empty = Cache M.empty

79
80
81
instance (Show a, Show b) => Show (Cache a b) where
  show (Cache m) = show (M.toList m)

82
83
84
85
86
instance (Pretty a, Pretty b) => Pretty (Cache a b) where
  pretty (Cache m) = list [ pretty k <+> prettyStable s <+> pretty v | (k,(s,v)) <- M.toList m]
    where
      prettyStable Stable = "->"
      prettyStable Unstable = "~>"
87

Sven Keidel's avatar
Sven Keidel committed
88
89
instance (Identifiable a, LowerBounded b, ArrowChoice c, Profunctor c)
  => ArrowCache a b (CacheT Cache a b c) where
90
91
  type Widening (CacheT Cache a b c) = W.Widening b

Sven Keidel's avatar
Sven Keidel committed
92
93
94
95
  initialize = CacheT $ modify' $ \(a,Cache cache) ->
    let cache' = M.insertWith (\_ _old -> _old) a (Unstable,bottom) cache
        ~(_,b) = M.lookupDefault (Unstable,bottom) a cache
    in (b,Cache cache')
96
97
98
  lookup = CacheT $ proc a -> do
    Cache cache <- get -< ()
    returnA -< M.lookup a cache
99
  update = CacheT $ proc (st,a,b) -> do
100
101
    Cache cache <- get -< ()
    case M.lookup a cache of
102
      Just (_,b') -> do
103
104
105
        let (st',b'') = ?cacheWidening b' b
        put -< Cache (M.insert a (st  st',b'') cache)
        returnA -< (st',a,b'')
106
107
      Nothing -> do
        put -< Cache (M.insert a (Unstable,b) cache)
108
        returnA -< (Unstable,a,b)
109
110
  write = CacheT $ modify' (\((a,b,s),Cache cache) -> ((),Cache (M.insert a (s,b) cache)))
  setStable = CacheT $ modify' $ \((s,a),Cache cache) -> ((),Cache (M.adjust (first (const s)) a cache))
111
  {-# INLINE initialize #-}
112
113
114
115
  {-# INLINE lookup #-}
  {-# INLINE write #-}
  {-# INLINE update #-}
  {-# INLINE setStable #-}
116
117
118
119
120
  {-# SCC initialize #-}
  {-# SCC lookup #-}
  {-# SCC write #-}
  {-# SCC update #-}
  {-# SCC setStable #-}
121

122
123
124
125
instance (Arrow c, Profunctor c) => ArrowIterateCache a b (CacheT Cache a b c) where
  nextIteration = CacheT $ proc x -> do
    put -< empty
    returnA -< x
126
127
128
129
130
131
  {-# INLINE nextIteration #-}

instance (LowerBounded b, Profunctor c, Arrow c) => ArrowLowerBounded b (CacheT Cache a b c) where
  bottom = proc _ -> returnA -< bottom
  {-# INLINE bottom #-}

132
133
134
135
instance Identifiable a => IsList (Cache a b) where
  type Item (Cache a b) = (a,b,Stable)
  toList (Cache m) = [ (a,b,s) | (a,(s,b)) <- M.toList m]
  fromList l = Cache $ M.fromList [ (a,(s,b)) | (a,b,s) <- l]
136
137
138
139
140
141
142
143
144
145

------ Group Cache ------
data Group cache a b where
  Groups :: HashMap k (cache a b) -> Group cache (k,a) b

instance IsEmpty (Group cache (k,a) b) where
  empty = Groups empty
  {-# INLINE empty #-}

instance (Identifiable k, Arrow c, Profunctor c, ArrowCache a b (CacheT cache a b c), IsEmpty (cache a b)) => ArrowCache (k,a) b (CacheT (Group cache) (k,a) b c) where
146
  type Widening (CacheT (Group cache) (k,a) b c) = Cache.Widening (CacheT cache a b c)
Sven Keidel's avatar
Sven Keidel committed
147
148
  initialize = withGroup Cache.initialize
  lookup = withGroup Cache.lookup
149
150
151
  update = proc (st,(k,a),b) -> do
    (st',a',b') <- withGroup Cache.update -< (k,(st,a,b))
    returnA -< (st',(k,a'),b')
Sven Keidel's avatar
Sven Keidel committed
152
153
  write = lmap (\((k,a),b,s) -> (k,(a,b,s))) (withGroup Cache.write)
  setStable = lmap shuffle1 (withGroup Cache.setStable)
154
  {-# INLINE initialize #-}
155
  {-# INLINE lookup #-}
156
  {-# INLINE update #-}
157
158
  {-# INLINE write #-}
  {-# INLINE setStable #-}
159
160
161
162
163
  {-# SCC initialize #-}
  {-# SCC lookup #-}
  {-# SCC write #-}
  {-# SCC update #-}
  {-# SCC setStable #-}
164

Sven Keidel's avatar
Sven Keidel committed
165
instance (Identifiable k, IsEmpty (cache a b), ArrowApply c, Profunctor c, ArrowJoinContext a (CacheT cache a b c)) => ArrowJoinContext (k,a) (CacheT (Group cache) (k,a) b c) where
166
  type Widening (CacheT (Group cache) (k,a) b c) = Context.Widening (CacheT cache a b c)
Sven Keidel's avatar
Sven Keidel committed
167
168
169
170
171
  joinByContext = proc (k,a) -> do
    a' <- withGroup joinByContext -< (k,a)
    returnA -< (k,a')
  {-# INLINE joinByContext #-}

172
173
174
withGroup :: (Identifiable k, IsEmpty (cache a b),
              Profunctor c, Arrow c)
          => CacheT cache a b c x y -> CacheT (Group cache) (k,a) b c (k,x) y
175
withGroup f = lift $
Sven Keidel's avatar
Sven Keidel committed
176
177
  dimap (\(Groups groups,(k,x)) -> ((groups,k),(fromMaybe empty (M.lookup k groups),x)))
        (\((groups,k),(cache,y)) -> (Groups (M.insert k cache groups), y))
178
        (second (unlift f))
Sven Keidel's avatar
Sven Keidel committed
179
{-# INLINE withGroup #-}
180
181
182
183
184
185
186
187

instance Identifiable k => IsList (Group cache (k,a) b) where
  type Item (Group cache (k,a) b) = (k,cache a b)
  toList (Groups m) = M.toList m
  fromList l = Groups $ M.fromList l

instance (Show k, Show (cache a b)) => Show (Group cache (k,a) b) where
  show (Groups m) = show (M.toList m)
188

Sven Keidel's avatar
Sven Keidel committed
189
------ Parallel Cache ------
190
191
192
193
194
data Parallel cache a b =
  Parallel { old :: cache a b
           , new :: cache a b
           , stable :: !Stable
           }
195
196
197

instance Pretty (cache a b) => Show (Parallel cache a b)   where show = show . pretty
instance Pretty (cache a b) => Pretty (Parallel cache a b) where
198
199
200
201
202
203
  pretty (Parallel o n s) =
    vsep ["Parallel",
          "Old:" <+> align (pretty o),
          "New:" <+> align (pretty n),
          "Stable:" <> viaShow s
         ]
Sven Keidel's avatar
Sven Keidel committed
204
205
206
207

instance IsEmpty (cache a b) => IsEmpty (Parallel cache a b) where
  empty = Parallel { old = empty, new = empty, stable = Stable }

208
209
210
instance (Profunctor c, Arrow c,
          ArrowLowerBounded b (CacheT cache a b c))
    => ArrowLowerBounded b (CacheT (Parallel cache) a b c) where
211
212
213
  bottom = newCache Order.bottom
  {-# INLINE bottom #-}

214
215
216
instance (Profunctor c, ArrowChoice c,
          ArrowIterateCache a b (CacheT cache a b c),
          ArrowCache a b (CacheT cache a b c))
217
    => ArrowParallelCache a b (CacheT (Parallel cache) a b c) where
Sven Keidel's avatar
Sven Keidel committed
218
219
220
221
  lookupOldCache = oldCache $ proc a -> do
    m <- lookup -< a; case m of
      Just (_,b) -> returnA -< b
      Nothing    -> initialize -< a
222
  lookupNewCache = newCache (rmap (fmap snd) lookup)
223
  updateNewCache = dimap (\(a,b) -> (Stable,a,b)) (\(_,_,b) -> b) update
224
  isStable = modify' (\(_,p) -> (stable p,p))
225
226
227
  {-# INLINE lookupOldCache #-}
  {-# INLINE lookupNewCache #-}
  {-# INLINE updateNewCache #-}
228
  {-# INLINE isStable #-}
229
230
231
232
  {-# SCC lookupOldCache #-}
  {-# SCC lookupNewCache #-}
  {-# SCC updateNewCache #-}
  {-# SCC isStable #-}
233

234
235
236
237
instance (Profunctor c, ArrowChoice c,
          ArrowIterateCache a b (CacheT cache a b c))
    => ArrowIterateCache a b (CacheT (Parallel cache) a b c) where
  nextIteration = proc x -> do
238
    modify' (\(_,p) -> ((),p { old = new p, stable = Stable })) -< ()
239
    newCache nextIteration -< x
Sven Keidel's avatar
Sven Keidel committed
240
241
  {-# INLINE nextIteration #-}

242
243
244
instance (Profunctor c, ArrowChoice c,
          ArrowCache a b (CacheT cache a b c))
    => ArrowCache a b (CacheT (Parallel cache) a b c) where
245
  type Widening (CacheT (Parallel cache) a b c) = Cache.Widening (CacheT cache a b c)
Sven Keidel's avatar
Sven Keidel committed
246
  initialize = proc a -> do
247
    m <- oldCache lookup -< a; case m of
Sven Keidel's avatar
Sven Keidel committed
248
249
250
251
252
253
254
      Just (s,b) -> do
        newCache write -< (a,b,s)
        returnA -< b
      Nothing -> do
        modify' (\((),cache) -> ((),cache { stable = Unstable })) -< ()
        newCache initialize -< a
  lookup = newCache lookup
255
256
257
258
  update = proc (st,a,b) -> do
    (st',a',b') <- newCache update -< (st,a,b)
    st'' <- modify' (\(st',cache) -> let st'' = stable cache  st' in (st'',cache { stable = st'' })) -< st'
    returnA -< (st'',a',b')
Sven Keidel's avatar
Sven Keidel committed
259
260
261
262
263
264
265
266
  write = newCache write
  setStable = newCache setStable
  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE write #-}
  {-# INLINE update #-}
  {-# INLINE setStable #-}

267
-- Note: All operations on the old cache are read-only.
Sven Keidel's avatar
Sven Keidel committed
268
oldCache :: (Arrow c, Profunctor c) => CacheT cache a b c x y -> CacheT (Parallel cache) a b c x y
269
oldCache f = lift $ dimap (\(p,x) -> (p,(old p,x))) (\(p,(_,y)) -> (p, y)) (second (unlift f))
Sven Keidel's avatar
Sven Keidel committed
270
271
272
{-# INLINE oldCache #-}

newCache :: (Arrow c, Profunctor c) => CacheT cache a b c x y -> CacheT (Parallel cache) a b c x y
273
newCache f = lift $
274
275
  dimap (\(p,x) -> (p,(new p,x)))
        (\(p,(n,y)) -> (p { new = n }, y))
276
        (second (unlift f))
Sven Keidel's avatar
Sven Keidel committed
277
278
{-# INLINE newCache #-}

279
280
------ Monotone Cache ------
data Monotone a b where
281
  Monotone :: s -> HashMap a (Stable,s,b) -> Monotone (s,a) (s,b)
282

283
284
instance IsEmpty s => IsEmpty (Monotone (s,a) (s,b)) where
  empty = Monotone empty empty
285

286
instance (Show s, Show a, Show b) => Show (Monotone (s,a) (s,b)) where
287
  show (Monotone s m) = show (s,m)
288

289
instance (Pretty s, Pretty a, Pretty b) => Pretty (Monotone (s,a) (s,b)) where
290
  pretty (Monotone _ m) =
Sven Keidel's avatar
Sven Keidel committed
291
292
    align (list [ pretty s <+> "|" <+> pretty a <+> showArrow st <+> pretty b | (a,(st,s,b)) <- M.toList m])

293
instance (Identifiable a, PreOrd s, LowerBounded b, ArrowChoice c, Profunctor c)
Sven Keidel's avatar
Sven Keidel committed
294
295
    => ArrowCache (s,a) (s,b) (CacheT Monotone (s,a) (s,b) c) where
  type Widening (CacheT Monotone (s,a) (s,b) c) = (W.Widening s,W.Widening b)
296
  initialize = CacheT $ modify' $ \((sNew,a),Monotone s cache) ->
Sven Keidel's avatar
Sven Keidel committed
297
298
    case M.lookup a cache of
      Just (_,sOld,b)
299
300
301
302
        | sNew  sOld -> ((sNew,b),      Monotone s cache)
        | otherwise   -> ((sNew,b),      Monotone s (M.insert a (Unstable,sNew,b) cache))
      Nothing         -> ((sNew,bottom), Monotone s (M.insert a (Unstable,sNew,bottom) cache))
  lookup = CacheT $ modify' $ \((s,a),m@(Monotone _ cache)) ->
Sven Keidel's avatar
Sven Keidel committed
303
304
305
    case M.lookup a cache of
      Just (st,s',b) | s  s' -> (Just (st,(s,b)), m)
      _ -> (Nothing, m)
306
  update = CacheT $ modify' $ \((stable0,(sNew,a),(sNew',bNew)),Monotone s cache) ->
Sven Keidel's avatar
Sven Keidel committed
307
    let (widenS,widenB) = ?cacheWidening
308
        (_,sWiden) = widenS s sNew'
Sven Keidel's avatar
Sven Keidel committed
309
310
311
312
    in case M.lookup a cache of
      Just (_,sOld,bOld) ->
          let stable1 = if sNew  sOld then Stable else Unstable
              (stable2,bWiden) = widenB bOld bNew
313
314
          in ((stable1  stable2, (sWiden,a), (sWiden,bWiden)),
              Monotone sWiden (M.insert a (stable0  stable1  stable2,sNew,bWiden) cache))
315
      Nothing -> ((Unstable,(sWiden,a),(sWiden,bNew)), Monotone sWiden (M.insert a (Unstable,sNew,bNew) cache))
316
317
  write = CacheT $ modify' $ \(((sNew, a), (_,b), st), Monotone s cache) ->
    ((), Monotone s (M.insert a (st, sNew, b) cache))
Sven Keidel's avatar
Sven Keidel committed
318
319
320
321
322
323
324
325
326
327
328
329
330
  setStable = CacheT $ proc _ -> returnA -< ()
  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE write #-}
  {-# INLINE update #-}
  {-# INLINE setStable #-}
  {-# SCC initialize #-}
  {-# SCC lookup #-}
  {-# SCC write #-}
  {-# SCC update #-}
  {-# SCC setStable #-}

instance (Arrow c, Profunctor c) => ArrowIterateCache (s,a) (s,b) (CacheT Monotone (s,a) (s,b) c) where
331
332
333
  nextIteration = CacheT $ proc ((_,a),(sNew,b)) -> do
    put -< Monotone sNew empty
    returnA -< ((sNew,a),(sNew,b))
Sven Keidel's avatar
Sven Keidel committed
334
335
  {-# INLINE nextIteration #-}

Sven Keidel's avatar
Sven Keidel committed
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
-- | Cache for an analysis with abstract garbage collection. The type variable
-- @s@ stands for the store.
data GarbageCollect a b where
  GarbageCollect :: HashMap a (Stable,s,s,b) -> GarbageCollect (s,a) (s,b)

instance IsEmpty (GarbageCollect (s,a) (s,b)) where
  empty = GarbageCollect empty

instance (Show s, Show a, Show b) => Show (GarbageCollect (s,a) (s,b)) where
  show (GarbageCollect m) = show m

instance (Pretty s, Pretty a, Pretty b) => Pretty (GarbageCollect (s,a) (s,b)) where
  pretty (GarbageCollect m) =
    align (list [ pretty s1 <+> "×" <+> pretty a <+> showArrow st <+> pretty s2 <+> "×" <+> pretty b | (a,(st,s1,s2,b)) <- M.toList m])

instance (Identifiable a, PreOrd s, LowerBounded b, ArrowChoice c, Profunctor c)
    => ArrowCache (s,a) (s,b) (CacheT GarbageCollect (s,a) (s,b) c) where
  type Widening (CacheT GarbageCollect (s,a) (s,b) c) = (W.Widening s,W.Widening b)
  initialize = CacheT $ modify' $ \((sNew1,a),GarbageCollect cache) ->
    let (widenS,_) = ?cacheWidening
    in case M.lookup a cache of
      Just (_,sOld1,sOld2,b)
        | sNew1  sOld1 -> ((sOld2,b), GarbageCollect cache)
        | otherwise     -> let (_,sWiden1) = widenS sOld1 sNew1
                               (_,sWiden2) = widenS sOld2 sNew1
                           in ((sWiden2,b), GarbageCollect (M.insert a (Unstable,sWiden1,sOld2,b) cache))
      Nothing           -> ((sNew1,bottom), GarbageCollect (M.insert a (Unstable,sNew1,sNew1,bottom) cache))
  lookup = CacheT $ modify' $ \((sNew1,a),m@(GarbageCollect cache)) ->
    case M.lookup a cache of
      Just (st,sOld1,sOld2,b)
        | sNew1  sOld1 -> (Just (st,(sOld2,b)),       m)
        | otherwise     -> (Just (Unstable,(sOld2,b)), m)
      _ -> (Nothing, m)
  update = CacheT $ modify' $ \((stable0,(sNew1,a),(sNew2,bNew)),GarbageCollect cache) ->
    let (widenS,widenB) = ?cacheWidening
    in case M.lookup a cache of
      Just (_,sOld1,sOld2,bOld) ->
          let (stable1,sWiden1) = widenS sOld1 sNew1
              (stable2,sWiden2) = widenS sOld2 sNew2
              (stable3,bWiden)  = widenB bOld bNew
          in ((stable1  stable2  stable3, (sWiden1,a), (sWiden2,bWiden)),
              GarbageCollect (M.insert a (stable0  stable1  stable2  stable3, sWiden1, sWiden2, bWiden) cache))
      Nothing -> ((Unstable,(sNew1,a),(sNew2,bNew)), GarbageCollect (M.insert a (Unstable,sNew1,sNew2,bNew) cache))
  write = CacheT $ modify' $ \(((sNew1, a), (sNew2,b), st), GarbageCollect cache) ->
    ((), GarbageCollect (M.insert a (st, sNew1, sNew2, b) cache))
  setStable = CacheT $ proc _ -> returnA -< ()
  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE write #-}
  {-# INLINE update #-}
  {-# INLINE setStable #-}
  {-# SCC initialize #-}
  {-# SCC lookup #-}
  {-# SCC write #-}
  {-# SCC update #-}
  {-# SCC setStable #-}

instance (Arrow c, Profunctor c) => ArrowIterateCache (s,a) (s,b) (CacheT GarbageCollect (s,a) (s,b) c) where
  nextIteration = CacheT $ proc ((_,a),(sNew2,b)) -> do
    put -< GarbageCollect empty
    returnA -< ((sNew2,a),(sNew2,b))
  {-# INLINE nextIteration #-}

Sven Keidel's avatar
Sven Keidel committed
399
400
401
402
403
404
405
406
407
408
409
410
------ Monotone Cache that factors out the monotone element ------
data MonotoneFactor a b where
  MonotoneFactor :: s -> HashMap a b -> MonotoneFactor (s,a) (s,b)

instance IsEmpty s => IsEmpty (MonotoneFactor (s,a) (s,b)) where
  empty = MonotoneFactor empty empty

instance (Show s, Show a, Show b) => Show (MonotoneFactor (s,a) (s,b)) where
  show (MonotoneFactor s m) = show (s,m)

instance (Pretty s, Pretty a, Pretty b) => Pretty (MonotoneFactor (s,a) (s,b)) where
  pretty (MonotoneFactor s m) =
411
412
413
414
415
416
    vsep [ "Monotone:" <+> pretty s
         , "NonMonotone:" <+> align (list [ pretty k <+> "->" <+> pretty v | (k,v) <- M.toList m])
         ]

instance (Identifiable a, LowerBounded b,
          ArrowChoice c, Profunctor c)
Sven Keidel's avatar
Sven Keidel committed
417
418
419
    => ArrowCache (s,a) (s,b) (CacheT MonotoneFactor (s,a) (s,b) c) where
  type Widening (CacheT MonotoneFactor (s,a) (s,b) c) = (W.Widening s,W.Widening b)
  initialize = CacheT $ modify' $ \((s,a),MonotoneFactor s' cache) ->
420
    let cache' = M.insertWith (\_ _old -> _old) a bottom cache
Sven Keidel's avatar
Sven Keidel committed
421
422
423
        b = M.lookupDefault bottom a cache'
    in ((s,b),MonotoneFactor s' cache')
  lookup = CacheT $ modify' $ \((s,a),m@(MonotoneFactor _ cache)) ->
424
    ((\b -> (Unstable,(s,b))) <$> M.lookup a cache, m)
425
  update = CacheT $ modify' $ \((_,(_,a),(sNew,b)),MonotoneFactor sOld cache) ->
426
427
    let (widenS,widenB) = ?cacheWidening
        (stable1,sWiden) = widenS sOld sNew
428
429
    in case M.lookup a cache of
        Just b' ->
430
431
432
          let (stable2,b'') = widenB b' b
          in ((stable1  stable2, (sWiden,a), (sWiden,b'')),
              MonotoneFactor sWiden (M.insert a b'' cache))
Sven Keidel's avatar
Sven Keidel committed
433
434
        Nothing -> ((Unstable,(sWiden,a), (sWiden,b)),MonotoneFactor sWiden (M.insert a b cache))
  write = CacheT $ modify' $ \(((_, a), (_, b), _),MonotoneFactor s cache) -> ((),MonotoneFactor s (M.insert a b cache))
435
  setStable = CacheT $ proc _ -> returnA -< ()
436
  {-# INLINE initialize #-}
437
  {-# INLINE lookup #-}
438
439
440
  {-# INLINE write #-}
  {-# INLINE update #-}
  {-# INLINE setStable #-}
441
442
443
444
445
  {-# SCC initialize #-}
  {-# SCC lookup #-}
  {-# SCC write #-}
  {-# SCC update #-}
  {-# SCC setStable #-}
446

Sven Keidel's avatar
Sven Keidel committed
447
instance (Arrow c, Profunctor c) => ArrowIterateCache (s,a) (s,b) (CacheT MonotoneFactor (s,a) (s,b) c) where
448
  nextIteration = CacheT $ proc ((_,a),(sNew,b)) -> do
Sven Keidel's avatar
Sven Keidel committed
449
    put -< MonotoneFactor sNew empty
450
    returnA -< ((sNew,a),(sNew,b))
451
452
  {-# INLINE nextIteration #-}

453
------ Product Cache ------
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
-- data (**) cache1 cache2 a b where
--   Product :: cache1 a1 b1 -> cache2 a2 b2 -> (**) cache1 cache2 (a1,a2) (b1,b2)

-- instance (IsEmpty (cache1 a1 b1), IsEmpty (cache2 a2 b2)) => IsEmpty ((**) cache1 cache2 (a1,a2) (b1,b2)) where
--   empty = Product empty empty

-- instance (Show (cache1 a1 b1), Show (cache2 a2 b2)) => Show ((**) cache1 cache2 (a1,a2) (b1,b2)) where
--   show (Product c1 c2) = show (c1,c2)

-- instance (Arrow c, Profunctor c, ArrowCache a1 b1 (CacheT cache1 a1 b1 c), ArrowCache a2 b2 (CacheT cache2 a2 b2 c))
--   => ArrowCache (a1,a2) (b1,b2) (CacheT (cache1 ** cache2) (a1,a2) (b1,b2) c) where
--   type Widening (CacheT (cache1 ** cache2) (a1,a2) (b1,b2) c) = (Widening (CacheT cache1 a1 b1 c), Widening (CacheT cache2 a2 b2 c))
--   initialize = initialize ** initialize
--   lookup = rmap lubMaybe (lookup ** lookup)
--   update = dimap (\((a1,a2),(b1,b2)) -> ((a1,b1),(a2,b2))) lubStable (update ** update)
--   write = dimap (\((a1,a2),(b1,b2),s) -> ((a1,b1,s),(a2,b2,s))) (const ()) (write ** write)
--   setStable = dimap (\(s,(a1,a2)) -> ((s,a1),(s,a2))) (const ()) (setStable ** setStable)
--   {-# INLINE initialize #-}
--   {-# INLINE lookup #-}
--   {-# INLINE write #-}
--   {-# INLINE update #-}
--   {-# INLINE setStable #-}
476

477
478
479
-- (**) :: (Profunctor c, Arrow c) => CacheT cache1 a1 b1 c x1 y1 -> CacheT cache2 a2 b2 c x2 y2 -> CacheT (cache1 ** cache2) (a1,a2) (b1,b2) c (x1,x2) (y1,y2)
-- (**) f g = lift $ \(w1,w2) -> dimap (\(Product cache1 cache2,(x1,x2)) -> ((cache1,x1),(cache2,x2))) (\((cache1,x1),(cache2,x2)) -> (Product cache1 cache2,(x1,x2))) (unlift f w1 *** unlift g w2)
-- {-# INLINE (**) #-}
480

481
482
483
-- lubMaybe :: (Maybe (Stable,b1), Maybe (Stable,b2)) -> Maybe (Stable,(b1,b2))
-- lubMaybe (Just (s1,b1), Just (s2,b2)) = Just (s1 ⊔ s2,(b1,b2))
-- lubMaybe _ = Nothing
484

485
486
487
-- lubStable :: ((Stable,a1,b1),(Stable,a2,b2)) -> (Stable,(a1,a2),(b1,b2))
-- lubStable ((s1,a1,b1),(s2,a2,b2)) = (s1 ⊔ s2,(a1,a2),(b1,b2))
-- {-# INLINE lubStable #-}
488

Sven Keidel's avatar
Sven Keidel committed
489
490
491
------ Second Projection ------
data Proj2 cache a b where
  Proj2 :: cache a b -> Proj2 cache (u,a) b
492

493
-- type instance Widening (Proj2 cache (u,a) b) = Widening (cache a b)
Sven Keidel's avatar
Sven Keidel committed
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516

instance IsEmpty (cache a b) => IsEmpty (Proj2 cache (u,a) b) where
  empty = Proj2 empty
  {-# INLINE empty #-}

-- NOTE: A cache which ignores one of its inputs is possibly unsound.
-- instance (Arrow c, Profunctor c, ArrowCache a b (CacheT cache a b c)) => ArrowCache (u,a) b (CacheT (Proj2 cache) (u,a) b c) where
--   initialize = p2 initialize
--   lookup = p2 lookup
--   update = lmap assoc2 (p2 update)
--   write = lmap (\((u,a),b,s) -> (u,(a,b,s))) (p2 write)
--   setStable = lmap (\(s,(u,a)) -> (u,(s,a))) (p2 setStable)
--   {-# INLINE initialize #-}
--   {-# INLINE lookup #-}
--   {-# INLINE update #-}
--   {-# INLINE write #-}
--   {-# INLINE setStable #-}

-- p2 :: Profunctor c => CacheT cache a b c x2 y -> CacheT (Proj2 cache) (u,a) b c (x1,x2) y
-- p2 f = lift $ \widen -> dimap (\(Proj2 cache,(_,a)) -> (cache,a)) (first Proj2) (unlift f widen)
-- {-# INLINE p2 #-}

instance (Arrow c, Profunctor c, ArrowJoinContext a (CacheT cache a b c)) => ArrowJoinContext (u,a) (CacheT (Proj2 cache) (u,a) b c) where
517
518
  type Widening (CacheT (Proj2 cache) (u,a) b c) = Context.Widening (CacheT cache a b c)
  joinByContext = lift $
Sven Keidel's avatar
Sven Keidel committed
519
    dimap (\(Proj2 cache,(u,a)) -> (u,(cache,a))) (\(u,(cache,a)) -> (Proj2 cache,(u,a)))
520
          (second (unlift (joinByContext :: CacheT cache a b c a a)))
Sven Keidel's avatar
Sven Keidel committed
521
  {-# INLINE joinByContext #-}
522
523


Sven Keidel's avatar
Sven Keidel committed
524
525
526
527
528
529
------ Context ------
data Context ctx cache a b = Context (ctx a b) (cache a b)

instance (IsEmpty (ctx a b), IsEmpty (cache a b)) => IsEmpty (Context ctx cache a b) where
  empty = Context empty empty
  {-# INLINE empty #-}
530
531

instance (Arrow c, Profunctor c, ArrowCache a b (CacheT cache a b c)) => ArrowCache a b (CacheT (Context ctx cache) a b c) where
532
  type Widening (CacheT (Context ctx cache) a b c) = Cache.Widening (CacheT cache a b c)
Sven Keidel's avatar
Sven Keidel committed
533
534
535
536
537
  initialize = withCache initialize
  lookup = withCache lookup
  update = withCache update
  write = withCache write
  setStable = withCache setStable
538
539
540
541
542
543
  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE update #-}
  {-# INLINE write #-}
  {-# INLINE setStable #-}

544
545
546
547
548
-- instance (Arrow c, Profunctor c, ArrowIterate (CacheT cache a b c)) => ArrowIterate (CacheT (Context ctx cache) a b c) where
--   nextIteration = withCache nextIteration
--   isStable = withCache isStable
--   {-# INLINE nextIteration #-}
--   {-# INLINE isStable #-}
549

Sven Keidel's avatar
Sven Keidel committed
550
instance (Arrow c, Profunctor c, ArrowJoinContext a (CacheT ctx a b c)) => ArrowJoinContext a (CacheT (Context ctx cache) a b c) where
551
  type Widening (CacheT (Context ctx cache) a b c) = Context.Widening (CacheT ctx a b c)
Sven Keidel's avatar
Sven Keidel committed
552
553
554
555
  joinByContext = withCtx joinByContext
  {-# INLINE joinByContext #-}

withCache :: (Profunctor c, Arrow c) => CacheT cache a b c x y -> CacheT (Context ctx cache) a b c x y
556
withCache f = lift $ dimap (\(Context ctx cache,x) -> (ctx,(cache,x))) (\(ctx,(cache,x2)) -> (Context ctx cache,x2)) (second (unlift f))
Sven Keidel's avatar
Sven Keidel committed
557
558
559
{-# INLINE withCache #-}

withCtx :: (Profunctor c, Arrow c) => CacheT ctx a b c x y -> CacheT (Context ctx cache) a b c x y
560
withCtx f = lift $ dimap (\(Context ctx cache, a) -> (cache,(ctx,a))) (\(cache,(ctx,a)) -> (Context ctx cache,a)) (second (unlift f))
Sven Keidel's avatar
Sven Keidel committed
561
562
563
564
565
{-# INLINE withCtx #-}

------ Context Cache ------
newtype CtxCache ctx a b = CtxCache (HashMap ctx a)

566
-- type instance Widening (CtxCache ctx a b) = W.Widening a
Sven Keidel's avatar
Sven Keidel committed
567
568
569
570
571
572
573
574

instance IsEmpty (CtxCache ctx a b) where
  empty = CtxCache empty

instance (Show ctx, Show a) => Show (CtxCache ctx a b) where
  show (CtxCache m) = show (M.toList m)

instance (Identifiable ctx, PreOrd a, Profunctor c, ArrowChoice c, ArrowContext ctx c) => ArrowJoinContext a (CacheT (CtxCache ctx) a b c) where
575
576
  type Widening (CacheT (CtxCache ctx) a b c) = W.Widening a
  joinByContext = lift $ proc (CtxCache cache, a) -> do
577
    ctx <- Context.askContext -< ()
Sven Keidel's avatar
Sven Keidel committed
578
    returnA -< case M.lookup ctx cache of
579
580
581
      -- If there exists a stable cached entry and the actual input is
      -- smaller than the cached input, recurse the cached input.
      Just a'
Sven Keidel's avatar
Sven Keidel committed
582
583
        | a  a' -> (CtxCache cache, a')
        | otherwise ->
584
585
          -- If there exists the actual input is not smaller than the cached
          -- input, widen the input.
Sven Keidel's avatar
Sven Keidel committed
586
          let (_,a'') = ?contextWidening a' a
Sven Keidel's avatar
Sven Keidel committed
587
588
          in (CtxCache (M.insert ctx a'' cache),a'')
      Nothing -> (CtxCache (M.insert ctx a cache),a)
589
  {-# INLINE joinByContext #-}
Sven Keidel's avatar
Sven Keidel committed
590