move to recursion strategies

lib/src/Control/Arrow/Fix.hs

@@ -8,18 +8,15 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
-module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,filter,trace) where
+module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,filter) where
 
 import           Prelude hiding (filter,pred)
 
 import           Control.Arrow
 import           Control.Arrow.Trans
 
-import qualified Debug.Trace as Debug
-
 import           Data.Profunctor
 import           Data.Lens(Prism',getMaybe,set)
-import           Text.Printf
 
 -- | Type family that computes the type of the fixpoint.
 type family Fix (c :: * -> * -> *) x y :: * -> * -> *
@@ -44,10 +41,3 @@ filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> Iteratio
 filter pred strat f = proc a -> case getMaybe pred a of
   Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
   Nothing -> f -< a
-
-trace :: (Show a, Show b, Arrow c) => IterationStrategy c a b -> IterationStrategy c a b
-trace strat f = proc x -> do
-  strat (proc x -> do
-           y <- f -< x
-           returnA -< Debug.trace (printf "RETURN\neval(%s)\n\t= %s\n\n" (show x) (show y)) y)
-    -< Debug.trace (printf "CALL\n%s\n\n" (show x)) x 

lib/src/Control/Arrow/Cache.hs → lib/src/Control/Arrow/Fix/Cache.hs

-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Control.Arrow.Cache where
+module Control.Arrow.Fix.Cache where
 
 import Control.Arrow
 import Data.Profunctor
-import Data.Abstract.Widening (Stable)
-
-class (Arrow c, Profunctor c) => ArrowRecurse a b c | c -> a, c -> b where
-  -- | Decides whether to return a cached result or to recompute.
-  recurse :: c (a,Cached b) y -> c a y
-
-data Cached b = Compute | Cached (Stable,b)
-  deriving (Show,Eq)
+import Data.Abstract.Widening
 
 class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
   -- | Looks up if there is an entry in the cache.
@@ -27,5 +17,3 @@ class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
 
   -- | Set a given entry to stable or unstable.
   setStable :: c (Stable,a) ()
-
-type ArrowCacheRecurse a b c = (ArrowCache a b c, ArrowRecurse a b c)

lib/src/Control/Arrow/Fix/Chaotic.hs

+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Control.Arrow.Fix.Chaotic where
+
+import           Prelude hiding (head)
+
+import           Control.Arrow
+
+import           Data.HashSet (HashSet)
+import qualified Data.HashSet as H
+import           Data.Identifiable
+import           Data.Profunctor
+import           Data.Order
+
+import           Text.Printf
+
+class (Arrow c, Profunctor c) => ArrowIterate a c where
+  -- | Remembers to iterate on an unstable result until it stabilized.
+  iterate :: c (a,b) b
+
+class (Arrow c, Profunctor c) => ArrowComponent a c | c -> a where
+  setComponent :: c (Component a,y) y
+  withComponent :: c x y -> (c (x,y,Component a) y) -> c x y
+
+data Component a = Component { head :: HashSet a, body :: HashSet a } deriving (Eq)
+
+instance Identifiable a => PreOrd (Component a) where
+  c1 ⊑ c2 = head c1 ⊑ head c2 && body c1 ⊑ body c2
+  {-# INLINE (⊑) #-}
+
+instance Identifiable a => Complete (Component a) where
+  c1 ⊔ c2 = c1 <> c2
+  {-# INLINE (⊔) #-}
+
+instance Identifiable a => Semigroup (Component a) where
+  Component h1 b1 <> Component h2 b2 = Component { head = h1 <> h2, body = b1 <> b2 }
+  {-# INLINE (<>) #-}
+
+instance Identifiable a => Monoid (Component a) where
+  mempty = Component { head = H.empty, body = H.empty }
+  mappend = (<>)
+  {-# INLINE mempty #-}
+  {-# INLINE mappend #-}
+
+singleton :: Identifiable a => a -> Component a
+singleton a = Component { head = H.singleton a, body = H.empty }
+{-# INLINE singleton #-}
+
+instance Show a => Show (Component a) where
+  show (Component h b) = printf "Component { head = %s, body = %s }" (show (H.toList h)) (show (H.toList b))

lib/src/Control/Arrow/Fix/Context.hs

+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeFamilies #-}
+module Control.Arrow.Fix.Context where
+
+import Control.Arrow
+import Control.Arrow.Fix
+import Control.Arrow.State
+
+import Data.Profunctor
+
+class (Arrow c, Profunctor c) => ArrowContext ctx c | c -> ctx where
+  askContext :: c () ctx
+  localContext :: c x y -> c (ctx,x) y
+
+class ArrowJoinContext cache a b c where
+  type Widening cache a :: *
+  joinContexts' :: Widening cache a -> IterationStrategy c (cache a b, a) b
+
+joinContexts :: (ArrowState (cache a b) c, ArrowJoinContext cache a b c) => Widening cache a -> IterationStrategy c a b
+joinContexts widen f = proc a -> do
+  cache <- get -< ()
+  joinContexts' widen (proc (cache,a) -> do
+    put -< cache
+    f -< a) -< (cache,a)
+{-# INLINE joinContexts #-}

lib/src/Control/Arrow/Fix/Reuse.hs

+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Control.Arrow.Fix.Reuse where
+
+import Control.Arrow
+import Control.Arrow.Fix
+
+import Data.Measure
+import Data.Metric
+
+class ArrowReuse a b c where
+  -- | Reuse cached results at the cost of precision.
+  reuseStable :: (Show m, Monoid m) => (a -> a -> b -> m) -> c a m
+
+reuseStableByMetric :: (Show b, Show n, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
+reuseStableByMetric metric f = proc a -> do
+  m <- reuseStable (\a a' b -> Just (Measured { measured = metric a a', argument = b })) -< a
+  case m of
+    Just n -> returnA -< argument n
+    Nothing -> f -< a
+{-# INLINE reuseStableByMetric #-}

lib/src/Control/Arrow/Fix/Stack.hs

+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Control.Arrow.Fix.Stack where
+
+import Control.Arrow
+
+import Data.Profunctor
+import Data.HashSet
+
+class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
+  peek :: c () (Maybe a)
+  size :: c () Int
+  push :: c a b -> c a b
+  elem :: c a Bool
+  elems :: c () (HashSet a)

lib/src/Control/Arrow/Fix/Widening.hs

+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Control.Arrow.Fix.Widening where
+
+import Control.Arrow
+import Data.Profunctor
+import Data.Order
+import Data.Abstract.Widening (Stable,finite)
+
+class (Arrow c, Profunctor c) => ArrowWidening a c where
+  widening :: c (a,a) (Stable,a)
+
+instance Complete a => ArrowWidening a (->) where
+  widening (a,a') = finite a a'

lib/src/Control/Arrow/Store.hs

-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ConstraintKinds #-}

lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache.hs

+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Control.Arrow.Transformer.Abstract.Fix.Cache where
+
+import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,elem)
+
+import Control.Category
+import Control.Arrow
+import Control.Arrow.Trans
+import Control.Arrow.State
+import Control.Arrow.Fix.Context as Context hiding (Widening)
+import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
+
+import Control.Arrow.Transformer.Const
+import Control.Arrow.Transformer.State
+
+import Data.Profunctor.Unsafe
+import Data.Empty
+import Data.Order
+import Data.Coerce
+import Data.Abstract.Widening
+
+newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (Widening b) (StateT (cache a b) c) x y}
+  deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowContext ctx,ArrowState (cache a b))
+
+runCacheT :: (IsEmpty (cache a b), Profunctor c) => Widening b -> CacheT cache a b c x y -> c x (cache a b,y)
+runCacheT widen (CacheT f) = lmap (\x -> (empty,x)) (runStateT (runConstT widen f))
+{-# INLINE runCacheT #-}
+
+liftCacheT :: Arrow c => CacheT cache' a' b c x y -> CacheT cache a b c (cache' a' b,x) (cache' a' b,y)
+liftCacheT (CacheT f) = CacheT (lift $ \widen -> (withStateT (runConstT widen f)))
+{-# INLINE liftCacheT #-}
+
+liftCacheT' :: Arrow c => CacheT cache' a' b c x y -> ConstT (Widening b) (StateT (cache a b) c) (cache' a' b,x) (cache' a' b,y)
+liftCacheT' = coerce liftCacheT
+{-# INLINE liftCacheT' #-}
+
+instance (IsEmpty (cache a b), ArrowRun c) => ArrowRun (CacheT cache a b c) where
+  type Run (CacheT cache a b c) x y = Widening b -> Run c x (cache a b,y)
+  run f widen = run (runCacheT widen f)
+  {-# INLINE run #-}
+
+instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (CacheT cache a b c) where
+  CacheT f <⊔> CacheT g = CacheT $ rmap (uncurry (⊔)) (f &&& g)
+  {-# INLINE (<⊔>) #-}
+
+instance (Arrow c, Profunctor c) => ArrowJoin (CacheT cache a b c) where
+  joinSecond (CacheT f) = CacheT (second f)
+  {-# INLINE joinSecond #-}
+
+instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT cache a b c) where
+  app = CacheT (app .# first coerce)
+  {-# INLINE app #-}
+
+instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT cache a b c)

lib/src/Control/Arrow/Transformer/Abstract/Fix/StackWidening/Cache.hs → lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/Basic.hs

@@ -6,35 +6,26 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-module Control.Arrow.Transformer.Abstract.Fix.StackWidening.Cache where
+module Control.Arrow.Transformer.Abstract.Fix.Cache.Basic where
 
 import Prelude hiding (pred,lookup,map,head,iterate,(.))
 
-import Control.Category
 import Control.Arrow
-import Control.Arrow.Cache
-import Control.Arrow.Const
+import Control.Arrow.Fix.Reuse
+import Control.Arrow.Fix.Cache
 import Control.Arrow.State
-import Control.Arrow.Trans
-import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
+import Control.Arrow.Const
 
-import Control.Arrow.Transformer.Const
-import Control.Arrow.Transformer.State
+import Control.Arrow.Transformer.Abstract.Fix.Cache
 
+import Data.Order
 import Data.Profunctor
-import Data.Profunctor.Unsafe((.#))
 import Data.Identifiable
-import Data.Coerce
 import Data.Empty
-import Data.Order
 import Data.HashMap.Lazy(HashMap)
 import qualified Data.HashMap.Lazy as M
 
-import Data.Abstract.Widening(Widening,Stable(..))
-import Data.Maybe(fromMaybe)
-
-newtype CacheT a b c x y = CacheT (ConstT (Widening b) (StateT (Cache a b) c) x y)
-  deriving (Profunctor,Category,Arrow,ArrowChoice)
+import Data.Abstract.Widening(Stable(..))
 
 newtype Cache a b = Cache { getMap :: HashMap a (Stable,b)}
 instance (Show a, Show b) => Show (Cache a b) where
@@ -44,45 +35,29 @@ instance IsEmpty (Cache a b) where
   empty = Cache M.empty
   {-# INLINE empty #-}
 
-instance (Identifiable a, LowerBounded b, Arrow c, Profunctor c) => ArrowCache a b (CacheT a b c) where
+instance (Identifiable a, ArrowChoice c, Profunctor c) => ArrowCache a b (CacheT Cache a b c) where
   lookup = CacheT $ proc a -> do
     Cache cache <- get -< ()
     returnA -< M.lookup a cache
+  update = CacheT $ askConst $ \widen -> proc (a,b) -> do
+    Cache cache <- get -< ()
+    case M.lookup a cache of
+      Just (_,b') -> do
+        let b'' = widen b' b
+        put -< Cache (M.insert a b'' cache)
+        returnA -< b''
+      Nothing -> do
+        put -< Cache (M.insert a (Instable,b) cache)
+        returnA -< (Instable,b)
   write = CacheT $ modify' (\((a,b,s),Cache cache) -> ((),Cache (M.insert a (s,b) cache)))
-  update = CacheT $ askConst $ \widen -> modify' (\((a,b),Cache cache) ->
-    let (_,bOld) = fromMaybe (Instable,bottom) (M.lookup a cache)
-        bNew = widen bOld b
-    in (bNew,Cache (M.insert a bNew cache)))
   setStable = CacheT $ modify' $ \((s,a),Cache cache) -> ((),Cache (M.adjust (first (const s)) a cache))
   {-# INLINE lookup #-}
   {-# INLINE write #-}
   {-# INLINE update #-}
   {-# INLINE setStable #-}
 
-runCacheT :: (Profunctor c)
-          => Widening b -> CacheT a b c x y -> c x (Cache a b, y)
-runCacheT widen (CacheT f) = lmap (\x -> (empty,x)) (runStateT (runConstT widen f))
-{-# INLINE runCacheT #-}
-
-instance (ArrowRun c) => ArrowRun (CacheT a b c) where
-  type Run (CacheT a b c) x y = Widening b -> Run c x (Cache a b,y)
-  run f widen = run (runCacheT widen f)
-  {-# INLINE run #-}
-
-instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT a b c) where
-  app = CacheT (app .# first coerce)
-  {-# INLINE app #-}
-
-instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (CacheT a b c) where
-  CacheT f <⊔> CacheT g = CacheT $ rmap (uncurry (⊔)) (f &&& g)
-  {-# INLINE (<⊔>) #-}
-
-instance (Arrow c, Profunctor c) => ArrowJoin (CacheT a b c) where
-  joinSecond (CacheT f) = CacheT (second f)
-  {-# INLINE joinSecond #-}
-
-instance ArrowLift (CacheT a b) where
-  lift' f = CacheT (lift' (lift' f))
-  {-# INLINE lift' #-}
-
-instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT a b c)
+instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
+  reuseStable f = CacheT $ proc a -> do
+    Cache cache <- get -< ()
+    returnA -< M.foldlWithKey' (\m a' (s,b) -> if s == Stable && a ⊑ a' then m <> f a a' b else m) mempty cache
+  {-# INLINE reuseStable #-}

lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/ContextSensitive.hs

+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Control.Arrow.Transformer.Abstract.Fix.Cache.ContextSensitive
+  ( module Control.Arrow.Transformer.Abstract.Fix.Cache
+  , Cache
+  ) where
+
+import           Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,elem)
+
+import           Control.Arrow
+import           Control.Arrow.Const
+import           Control.Arrow.State
+import           Control.Arrow.Fix.Cache as Cache
+import           Control.Arrow.Fix.Context as Context
+import           Control.Arrow.Fix.Reuse as Reuse
+
+import           Control.Arrow.Transformer.Abstract.Fix.Cache
+
+import           Data.Identifiable
+import           Data.Profunctor.Unsafe
+import           Data.Empty
+import           Data.Order
+
+import           Data.Abstract.Widening as W
+import           Data.Abstract.Widening (Stable(..))
+
+import           Data.HashMap.Lazy(HashMap)
+import qualified Data.HashMap.Lazy as M
+
+newtype Cache ctx a b = Cache (HashMap ctx (a,b,Stable)) deriving (Show)
+
+instance IsEmpty (Cache ctx a b) where
+  empty = Cache M.empty
+  {-# INLINE empty #-}
+
+instance (Identifiable ctx, PreOrd a, LowerBounded b, ArrowChoice c, ArrowContext ctx c) => ArrowJoinContext (Cache ctx) a b c where
+  type Widening (Cache ctx) a = W.Widening a
+  joinContexts' widen f = proc (Cache cache,a) -> do
+    ctx <- askContext -< ()
+    (f ||| returnA) -< case M.lookup ctx cache of
+      -- If there exists a stable cached entry and the actual input is
+      -- smaller than the cached input, recurse the cached result.
+      Just (a',b,s)
+        | a ⊑ a' -> case s of
+            Stable   -> Right b
+            Instable -> Left (Cache cache,a')
+        | otherwise ->
+          -- If there exists the actual input is not smaller than the cached
+          -- input, widen the input and recompute.
+          let (_,a'') = widen a' a
+          in Left (Cache (M.insert ctx (a'',b,Instable) cache), a'')
+      Nothing -> Left (Cache (M.insert ctx (a,bottom,Instable) cache), a)
+  {-# INLINE joinContexts' #-}
+
+instance (Identifiable ctx, PreOrd a, Eq a, Complete b, ArrowChoice c, Profunctor c, ArrowContext ctx c)
+    => ArrowCache a b (CacheT (Cache ctx) a b c) where
+  lookup = CacheT $ proc a -> do
+    ctx <- askContext -< ()
+    Cache cache <- get -< ()
+    case M.lookup ctx cache of
+      Just (a',b,s)
+        | a ⊑ a' -> returnA -< Just (s,b)
+        | otherwise -> returnA -< Just (Instable,b)
+      Nothing -> returnA -< Nothing
+  update = CacheT $ askConst $ \widening -> proc (a,b) -> do
+    ctx <- askContext -< ()
+    Cache cache <- get -< ()
+    case M.lookup ctx cache of
+      Just (a',b',_) -> do
+        let (s,b'') = widening b' b
+        put -< Cache (M.insert ctx (a',b'',if a == a' then s else Instable) cache)
+        returnA -< (s,b'')
+      Nothing -> do
+        put -< Cache (M.insert ctx (a,b,Instable) cache)
+        returnA -< (Instable,b)
+  write = CacheT $ proc (a,b,s) -> do
+    ctx <- askContext -< ()
+    Cache cache <- get -< ()
+    case M.lookup ctx cache of
+      Just (a',b',s') -> do
+        let b'' = b ⊔ b'
+        put -< Cache (M.insert ctx (a',b'',if a == a' then s else s') cache)
+      Nothing ->
+        put -< Cache (M.insert ctx (a,b,s) cache)
+  setStable = CacheT $ proc (s,a) -> do
+    Cache cache <- get -< ()
+    ctx <- askContext -< ()
+    put -< Cache (M.adjust (\(a',b',s') -> (a',b',if a == a' then s else s')) ctx cache)
+  {-# INLINE lookup #-}
+  {-# INLINE update #-}
+  {-# INLINE write #-}
+  {-# INLINE setStable #-}
+
+instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT (Cache ctx) a b c) where
+  reuseStable f = CacheT $ proc a -> do
+    Cache cache <- get -< ()
+    returnA -< M.foldl' (\m (a',b,s) -> if s == Stable && a ⊑ a' then m <> f a a' b else m) mempty cache
+  {-# INLINE reuseStable #-}

lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/Group.hs

+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Control.Arrow.Transformer.Abstract.Fix.Cache.Group where
+
+import Prelude hiding (pred,lookup,map,head,iterate,(.))
+
+import Control.Arrow
+-- import Control.Arrow.Fix.Reuse
+import Control.Arrow.Fix.Context
+import Control.Arrow.Fix.Cache as Cache
+import Control.Arrow.State
+
+import Control.Arrow.Transformer.Abstract.Fix.Cache
+import Control.Arrow.Transformer.Reader
+
+import Data.Profunctor
+import Data.Identifiable
+import Data.Empty
+import Data.HashMap.Lazy(HashMap)
+import qualified Data.HashMap.Lazy as M
+import Data.Maybe (fromMaybe)
+
+import Data.Monoidal
+
+data Group cache a b where
+  Groups :: HashMap k (cache a b) -> Group cache (k,a) b
+
+instance (Show k, Show (cache a b)) => Show (Group cache (k,a) b) where
+  show (Groups m) = show (M.toList m)
+
+instance IsEmpty (Group cache (k,a) b) where
+  empty = Groups empty
+  {-# INLINE empty #-}
+
+instance (Identifiable k, IsEmpty (cache a b), Arrow c, ArrowJoinContext cache a b (ReaderT (k,Group cache (k,a) b) c)) => ArrowJoinContext (Group cache) (k,a) b c where
+  type Widening (Group cache) (k,a) = Widening cache a
+  joinContexts' widen f = proc (g,(k,a)) -> do
+    let Groups groups = g
+    runReaderT (joinContexts' widen (ReaderT (proc ((k,g),(cache,a)) -> do
+        let Groups groups = g
+        f -< (Groups (M.insert k cache groups),(k,a))
+      ))) -< ((k,g),(fromMaybe empty (M.lookup k groups),a))
+  {-# INLINE joinContexts' #-}
+
+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
+  lookup = withCache Cache.lookup
+  update = lmap assoc2 (withCache Cache.update)
+  write = lmap (\((k,a),b,s) -> (k,(a,b,s))) (withCache Cache.write)
+  setStable = lmap shuffle1 (withCache Cache.setStable)
+  {-# INLINE lookup #-}
+  {-# INLINE update #-}
+  {-# INLINE write #-}
+  {-# INLINE setStable #-}
+
+-- instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
+--   reuseStable f = CacheT $ proc a -> do
+--     Cache cache <- get -< ()
+--     returnA -< M.foldlWithKey' (\m a' (s,b) -> if s == Stable && a ⊑ a' then m <> f a a' b else m) mempty cache
+--   {-# INLINE reuseStable #-}
+
+withCache :: (Identifiable k, IsEmpty (cache a b), Arrow c, Profunctor c) => CacheT cache a b c x y -> CacheT (Group cache) (k,a) b c (k,x) y
+withCache f = CacheT $ modify $ proc ((k,x),g) -> do
+  let Groups groups = g
+  (cache',y) <- liftCacheT' f -< (fromMaybe empty (M.lookup k groups),x)
+  returnA -< (y,Groups (M.insert k cache' groups))
+{-# INLINE withCache #-}

lib/src/Control/Arrow/Transformer/Abstract/Fix/Chaotic.hs

@@ -11,138 +11,127 @@
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT,iterateOuter,iterateInner) where
 
-import           Prelude hiding (pred,lookup,map,head,iterate,(.),elem)
+import           Prelude hiding (id,pred,lookup,map,head,iterate,(.),elem)
 
 import           Control.Category
 import           Control.Arrow hiding (loop)
 import           Control.Arrow.Fix
-import           Control.Arrow.Cache as Cache
+import           Control.Arrow.Fix.Chaotic
+import           Control.Arrow.Fix.Cache as Cache
+import           Control.Arrow.Fix.Stack as Stack
+import           Control.Arrow.Fix.Context as Context
+import           Control.Arrow.State
 import           Control.Arrow.Trans
 import           Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffectCommutative)
 import           Control.Arrow.Utils
 
 import           Control.Arrow.Transformer.Writer
 
-import           Data.Profunctor
 import           Data.Order
-import           Data.HashSet(HashSet)
+import           Data.Profunctor
 import qualified Data.HashSet as H
 import           Data.Identifiable
 import           Data.Coerce
+import           Data.Maybe(fromMaybe)
 
 import           Data.Abstract.Widening(Stable(..))
-import           Text.Printf
-
-newtype ChaoticT a b c x y = ChaoticT (WriterT (Component a) c x y)
-  deriving (Profunctor,Category,Arrow,ArrowChoice)
-
-type instance Fix (ChaoticT _ _ c) x y = ChaoticT x y c
-instance (Identifiable a, ArrowCacheRecurse a b c, ArrowChoice c) => ArrowFix (ChaoticT a b c a b) where
-  fix f = iterateInner (f (fix f))
-  {-# INLINABLE fix #-}
 
 -- | Iterate on the innermost fixpoint component.
-iterateInner :: (Identifiable a, ArrowCacheRecurse a b c, ArrowChoice c) => IterationStrategy (ChaoticT a b c) a b
+iterateInner :: (Identifiable a, LowerBounded b, ArrowStack a c, ArrowIterate a c, ArrowComponent a c, ArrowCache a b c, ArrowChoice c) => IterationStrategy c a b
 {-# INLINE iterateInner #-}
-iterateInner f = lift $ recurse $ proc (a,r) -> do
-  case r of
-    Cached (Stable,b) -> returnA -< (mempty,b)
-    Cached (Instable,b) -> returnA -< (Component {head = H.singleton a, body = H.empty},b)
-    Compute -> iterate -< a
+iterateInner = detectLoop . go
   where
-    iterate = proc a -> do
-      (component,b) <- unlift f -< a
+    go f = withComponent f $ proc (a,b,component) ->
+      -- The call did not depend on any unstable calls. This means
+      -- we are done and don't need to iterate.
       if H.null (head component)
       then do
         Cache.write -< (a,b,Stable)
-        returnA -< (mempty,b)
+        returnA -< b
       else do
         (stable,bNew) <- Cache.update -< (a,b)
         case stable of
-          Stable   -> returnA -< (component { head = H.delete a (head component) },bNew)
-          Instable -> iterate -< a
+          Stable   -> setComponent -< (component { head = H.delete a (head component) },bNew)
+          Instable -> go f -< a
 
 -- | Iterate on the outermost fixpoint component.