Commit b258f02c authored by Sven Keidel's avatar Sven Keidel

fix bugs with context-sensitivity

parent 7eba3b90
Pipeline #16077 passed with stages
in 32 minutes and 26 seconds
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Context where
import Prelude hiding ((.))
import Control.Category
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
class (Arrow c, Profunctor c) => ArrowContext ctx a c | c -> ctx, c -> a where
type Widening c a :: *
askContext :: c () ctx
localContext :: c x y -> c (ctx,x) y
joinByContext :: Widening c a -> c a a
class ArrowJoinContext cache a b c where
type Widening cache a :: *
joinContexts' :: Widening cache a -> IterationStrategy c (cache a b, a) b
joinContexts :: forall a cache b c. (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 #-}
joinByContext' :: ArrowContext ctx a c => Widening c a -> IterationStrategy c a b
joinByContext' widen f = f . joinByContext widen
{-# INLINE joinByContext' #-}
......@@ -2,51 +2,73 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Reuse where
module Control.Arrow.Fix.Reuse
( ArrowReuse(..)
, reuseFirst
, reuseExact
, reuseByMetric
, reuseStableByMetric
)
where
import Prelude hiding (lookup)
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Data.Abstract.Stable
import Data.Metric
import Data.Profunctor
import Data.Monoid
import Data.Monoid (First(..))
import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where
type Dom c :: *
-- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => (Dom c -> Dom c -> Stable -> b -> m) -> c (a,Stable) m
reuse :: (Show m, Monoid m) => (a -> a -> Stable -> b -> m) -> c (a,Stable) m
reuseFirst :: (ArrowChoice c, ArrowReuse a b c) => IterationStrategy c a b
reuseFirst f = proc a -> do
m <- reuse (\_ _ _ b -> First (Just b)) -< (a,Stable)
reuseFirst :: (ArrowChoice c, ArrowReuse a b c, Show a, Show b) => Stable -> IterationStrategy c a b
reuseFirst st f = proc a -> do
m <- reuse (\_ a' s' b' -> First (Just (a',b',s'))) -< (a,st)
case getFirst m of
Just b -> returnA -< b
Just (_,b,Stable) -> returnA -< b
Just (a',_,Unstable) -> f -< a'
Nothing -> f -< a
{-# INLINE reuseFirst #-}
reuseExact :: (Eq (Dom c), ArrowChoice c, ArrowReuse a b c) => IterationStrategy c a b
reuseExact = reuseByMetric discrete
reuseExact :: (ArrowChoice c, ArrowCache a b c) => IterationStrategy c a b
reuseExact f = proc a -> do
m <- lookup -< a
case m of
Just (Stable,b) -> returnA -< b
_ -> f -< a
{-# INLINE reuseExact #-}
reuseByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric (Dom c) n -> IterationStrategy c a b
reuseByMetric metric f = proc a -> do
m <- reuse (\a a' _ b -> Just (Measured { measured = metric a a', argument = b })) -< (a,Stable)
reuseByMetric :: (Show a, Show b, Show n, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseByMetric metric = reuseByMetric_ (\s a a' -> Product s (metric a a')) Unstable
{-# INLINE reuseByMetric #-}
reuseStableByMetric :: (Show a, Show b, Show n, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseStableByMetric metric = reuseByMetric_ (const metric) Stable
{-# INLINE reuseStableByMetric #-}
reuseByMetric_ :: (Show a, Show b, Show n, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
reuseByMetric_ metric st f = proc a -> do
m <- reuse (\a a' s' b' -> Just (Measured { input = a', output = b', stable = s', measured = metric s' a a' })) -< (a,st)
case m of
Just n -> returnA -< argument n
Just Measured { stable = Stable, output = b } -> returnA -< b
Just Measured { stable = Unstable, input = a' } -> f -< a'
Nothing -> f -< a
{-# INLINE reuseByMetric #-}
{-# INLINE reuseByMetric_ #-}
data Measured a n = Measured { argument :: a, measured :: n }
data Measured a b n = Measured { input :: a, output :: b, stable :: Stable, measured :: n }
instance (Show a, Show n) => Show (Measured a n) where
show m = printf "%s@%s" (show (argument m)) (show (measured m))
instance (Show a, Show b, Show n) => Show (Measured a b n) where
show m = printf "%s@%s" (show (output m)) (show (measured m))
instance Ord n => Semigroup (Measured a n) where
instance Ord n => Semigroup (Measured a b n) where
m1 <> m2
| measured m1 <= measured m2 = m1
| otherwise = m2
......
......@@ -31,7 +31,7 @@ import Data.Coerce
-- | Allows to describe computations over non-completely ordered types.
-- E.g. allows to join a computation of type 'c x [y]'.
newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
......@@ -46,5 +46,5 @@ instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT
type instance Fix (CompletionT c) x y = CompletionT (Fix c x (FreeCompletion y))
deriving instance (ArrowFix (Underlying (CompletionT c) x y)) => ArrowFix (CompletionT c x y)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
bottom = lift $ bottom
deriving instance (ArrowChoice c, ArrowComplete (FreeCompletion y) c) => ArrowComplete y (CompletionT c)
deriving instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c)
......@@ -32,7 +32,7 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Except e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin, ArrowLowerBounded,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e')
......@@ -59,7 +59,4 @@ instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowApply c, Profunctor c) =>
type instance Fix (ExceptT e c) x y = ExceptT e (Fix c x (Except e y))
instance ArrowFix (Underlying (ExceptT e c) x y) => ArrowFix (ExceptT e c x y)
deriving instance (Complete e, ArrowChoice c, ArrowJoin c, ArrowComplete (Except e y) c) => ArrowComplete y (ExceptT e c)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
......@@ -11,9 +14,12 @@ import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,elem)
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Fix.Context as Context hiding (Widening)
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Const
......@@ -23,25 +29,34 @@ import Data.Profunctor.Unsafe
import Data.Empty
import Data.Order
import Data.Coerce
import Data.Abstract.Widening
import Data.Identifiable
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Monoidal
import Data.Maybe
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))
import Data.Abstract.Stable
import Data.Abstract.Widening as W
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))
import GHC.Exts
newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (W.Widening b) (StateT (cache a b) c) x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowState (cache a b))
runCacheT :: (IsEmpty (cache a b), Profunctor c) => W.Widening b -> CacheT cache a b c x y -> c x (cache a b,y)
runCacheT widen (CacheT f) = lmap (empty,) (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)))
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' :: Arrow c => CacheT cache' a' b c x y -> ConstT (W.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)
type Run (CacheT cache a b c) x y = W.Widening b -> Run c x (cache a b,y)
run f widen = run (runCacheT widen f)
{-# INLINE run #-}
......@@ -58,3 +73,95 @@ instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT cache a b c) where
{-# INLINE app #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT cache a b c)
----- Basic Cache -----
newtype Cache a b = Cache { getMap :: HashMap a (Stable,b)}
instance (Show a, Show b) => Show (Cache a b) where
show (Cache m) = show (M.toList m)
instance IsEmpty (Cache a b) where
empty = Cache M.empty
{-# INLINE empty #-}
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 (Unstable,b) cache)
returnA -< (Unstable,b)
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))
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx a (CacheT Cache a b c) where
type Widening (CacheT Cache a b c) a = Context.Widening c a
askContext = CacheT askContext
localContext (CacheT f) = CacheT (localContext f)
joinByContext widen = CacheT $ joinByContext widen
{-# INLINE askContext #-}
{-# INLINE localContext #-}
{-# INLINE joinByContext #-}
instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
reuse f = CacheT $ proc (a,s) -> do
Cache cache <- get -< ()
returnA -< M.foldlWithKey' (\m a' (s',b') -> if s' s && a a' then m <> f a a' s' b' else m) mempty cache
{-# INLINE reuse #-}
------ 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
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 (Arrow c, ArrowContext ctx a c) => ArrowContext ctx (k,a) (CacheT (Group cache) (k,a) b c) where
type Widening (CacheT (Group cache) (k,a) b c) (k,a) = Context.Widening c a
askContext = CacheT askContext
localContext (CacheT f) = CacheT (localContext f)
joinByContext widen = CacheT $ second (joinByContext widen)
{-# INLINE askContext #-}
{-# INLINE localContext #-}
{-# INLINE joinByContext #-}
instance (Identifiable k, IsEmpty (cache a b), ArrowApply c, Profunctor c, ArrowReuse a b (CacheT cache a b c)) => ArrowReuse (k,a) b (CacheT (Group cache) (k,a) b c) where
reuse f = proc ((k,a0),s) -> withCache (reuse (\a a' -> f (k,a) (k,a'))) -<< (k,(a0,s))
{-# INLINE reuse #-}
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 #-}
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)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Basic where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Control.Arrow
import Control.Arrow.Fix.Reuse
import Control.Arrow.Fix.Cache
import Control.Arrow.State
import Control.Arrow.Const
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Data.Order
import Data.Profunctor
import Data.Identifiable
import Data.Empty
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Abstract.Stable
newtype Cache a b = Cache { getMap :: HashMap a (Stable,b)}
instance (Show a, Show b) => Show (Cache a b) where
show (Cache m) = show (M.toList m)
instance IsEmpty (Cache a b) where
empty = Cache M.empty
{-# INLINE empty #-}
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 (Unstable,b) cache)
returnA -< (Unstable,b)
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))
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
type Dom (CacheT Cache a b c) = a
reuse f = CacheT $ proc (a,s) -> do
Cache cache <- get -< ()
returnA -< M.foldlWithKey' (\m a' (s',b') -> if s' s && a a' then m <> f a a' s' b' else m) mempty cache
{-# INLINE reuse #-}
{-# 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.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
Unstable -> 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,Unstable) cache), a'')
Nothing -> Left (Cache (M.insert ctx (a,bottom,Unstable) 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 (Unstable,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 Unstable) cache)
returnA -< (s,b'')
Nothing -> do
put -< Cache (M.insert ctx (a,b,Unstable) cache)
returnA -< (Unstable,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
type Dom (CacheT (Cache ctx) a b c) = a
reuse f = CacheT $ proc (a,s) -> do
Cache cache <- get -< ()
returnA -< M.foldl' (\m (a',b',s') -> if s' s && a a' then m <> f a a' s' b' else m) mempty cache
{-# INLINE reuse #-}
{-# 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 (Identifiable k, IsEmpty (cache a b), Arrow c, Profunctor c, ArrowReuse a b (CacheT cache a b c)) => ArrowReuse (k,a) b (CacheT (Group cache) (k,a) b c) where
type Dom (CacheT (Group cache) (k,a) b c) = Dom (CacheT cache a b c)
reuse f = lmap (\((k,a),s) -> (k,(a,s))) (withCache (reuse f))
{-# INLINE reuse #-}
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 #-}
......@@ -51,7 +51,15 @@ iterateInner = detectLoop . go
else do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
Stable -> setComponent -< (component { head = H.delete a (head component) },bNew)
Stable ->
if head component == H.singleton a
then do
map Cache.setStable -< (Stable,) <$> H.toList (body component)
setComponent -< (mempty, bNew)
else do
setStable -< (Unstable,a)
setComponent -< (component { head = H.delete a (head component)
, body = H.insert a (body component) }, bNew)
Unstable -> go f -< a
-- | Iterate on the outermost fixpoint component.
......@@ -103,7 +111,7 @@ detectLoop f = proc a -> do
{-# INLINE detectLoop #-}
newtype ChaoticT a c x y = ChaoticT (WriterT (Component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowCache a b,ArrowReuse a b,ArrowState s,ArrowContext ctx)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowCache a b,ArrowReuse a b,ArrowState s,ArrowContext ctx a)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowIterate a (ChaoticT a c) where
iterate = lift (arr (first singleton))
......
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -8,7 +8,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Context where
import Prelude hiding (lookup,truncate)
import Prelude hiding (lookup,truncate,(.))
import Control.Category
import Control.Arrow
......@@ -17,41 +17,91 @@ import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Cache
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Data.Abstract.CallString
import qualified Data.Abstract.Widening as W
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Profunctor.Unsafe
import Data.Coerce
import Data.Empty
import Data.Abstract.CallString
import Data.Order
import Data.Identifiable