Commit c7cc105b authored by Sven Keidel's avatar Sven Keidel

move to recursion strategies

parent 20d72c90
Pipeline #15727 failed with stages
in 11 minutes and 29 seconds
......@@ -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
{-# 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)
{-# 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))
{-# 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 #-}
{-# 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 #-}
{-# 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)
{-# 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'
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
......
{-# 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)
......@@ -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 #-}
{-# 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 #-}
{-# 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 #-}
......@@ -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.
iterateOuter :: (Identifiable a, ArrowCacheRecurse a b c, ArrowChoice c) => IterationStrategy (ChaoticT a b c) a b
iterateOuter :: (Identifiable a, LowerBounded b, ArrowStack a c, ArrowIterate a c, ArrowComponent a c, ArrowCache a b c, ArrowChoice c) => IterationStrategy c a b
{-# INLINE iterateOuter #-}
iterateOuter f = lift $ recurse $ proc (a,r) -> case r of
-- If the cache contains a stable entry, just return it.
Cached (Stable,b) -> returnA -< (mempty,b)
-- If the cache contains an unstable entry, remember to iterate on this entry.
Cached (Instable,b) -> returnA -< (Component {head = H.singleton a, body = H.empty},b)
-- If we did not encounter the entry, register the entry and keep recursing.
Compute -> iterate -< a
iterateOuter = detectLoop . go
where
iterate = proc a -> do
(component,b) <- unlift f -< a
case () of
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.
() | H.null (head component) -> do
Cache.write -< (a,b,Stable)
returnA -< (mempty,b)
-- We are at the head of a fixpoint component. This means, we
-- have to iterate until the head stabilized.
| head component == H.singleton a -> do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
-- If the head of a fixpoint component is stable, set
-- all elements in the body of the component as stable
-- too and return.
Stable -> do
map Cache.setStable -< H.toList $ H.map (Stable,) (body component)
returnA -< (mempty,bNew)
-- If the head of a fixpoint component is not stable, keep iterating.