Commit a81e1636 authored by Sven Keidel's avatar Sven Keidel

fix context widening

parent b99feafa
Pipeline #26690 failed with stages
in 22 minutes and 50 seconds
......@@ -10,8 +10,6 @@ import Data.Profunctor
import Data.Abstract.Stable
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
type Widening c :: *
-- | Initializes a cache entry with 'bottom'.
initialize :: c a b
......
......@@ -250,7 +250,7 @@ traceCache showCache f = proc a -> do
f -< Debug.trace (printf "CACHE %s\n\n" (showCache cache)) a
{-# INLINE traceCache #-}
traceCtx :: (ArrowContext ctx a' c,ArrowState cache c) => (a -> String) -> (b -> String) -> (ctx -> String) -> (cache -> String) -> FixpointCombinator c a b
traceCtx :: (ArrowContext ctx c,ArrowState cache c) => (a -> String) -> (b -> String) -> (ctx -> String) -> (cache -> String) -> FixpointCombinator c a b
traceCtx showA showB showCtx showCache f = proc x -> do
ctx <- Ctx.askContext -< ()
cache <- State.get -< ()
......
......@@ -51,7 +51,7 @@ type Alloc var addr val c = EnvT var addr val c (var,val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc var addr val c) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans, ArrowLowerBounded,
ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowRun, ArrowCont,
ArrowContext ctx a)
ArrowContext ctx)
instance (Identifiable var, Identifiable addr, Complete val, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT var addr val c) where
type Join y (EnvT var addr val c) = ()
......
......@@ -26,7 +26,7 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype FixT a b c x y = FixT { unFixT :: ConstT (FixpointCombinator c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin, ArrowContext ctx u)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin, ArrowContext ctx)
runFixT :: FixpointCombinator c a b -> FixT a b c x y -> c x y
runFixT comb (FixT f) = runConstT comb f
......
......@@ -30,7 +30,7 @@ import Data.Identifiable
import Data.Coerce
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, ArrowJoinContext u)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowChaotic a (ChaoticT a c) where
iterate = lift (arr (first singleton))
......
......@@ -16,7 +16,7 @@ import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack(ArrowStack)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context(ArrowContext)
import Control.Arrow.Fix.Context(ArrowContext,ArrowJoinContext)
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
......@@ -42,7 +42,7 @@ instance IsEmpty (Stack a) where
{-# INLINE empty #-}
newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin,ArrowComplete z,ArrowCache a b,ArrowState s,ArrowTrans,ArrowContext ctx)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin,ArrowComplete z,ArrowCache a b,ArrowState s,ArrowTrans,ArrowContext ctx, ArrowJoinContext u)
instance (ArrowReuse a b c, ArrowStack a (StackT stack a c)) => ArrowReuse a b (StackT stack a c) where
reuse s f = StackT $ reuse s f
......
......@@ -172,7 +172,6 @@ instance ArrowContext ctx c => ArrowContext ctx (NoInlineT c) where
{-# NOINLINE localContext #-}
instance ArrowCache a b c => ArrowCache a b (NoInlineT c) where
type Widening (NoInlineT c) = Cache.Widening c
initialize = lift Cache.initialize
lookup = lift Cache.lookup
write = lift Cache.write
......
......@@ -171,5 +171,5 @@ instance ArrowContext ctx c => ArrowContext ctx (ReaderT r c) where
localContext f = lift $ lmap shuffle1 (localContext (unlift f))
{-# INLINE localContext #-}
instance (ArrowCache a b c) => ArrowCache a b (ReaderT r c) where
type Widening (ReaderT r c) = Cache.Widening c
instance ArrowJoinContext a c => ArrowJoinContext a (ReaderT r c)
instance (ArrowCache a b c) => ArrowCache a b (ReaderT r c)
......@@ -194,8 +194,7 @@ instance ArrowWidening y c => ArrowWidening y (StateT s c) where
widening = lift' widening
{-# INLINE widening #-}
instance (ArrowCache a b c) => ArrowCache a b (StateT s c) where
type Widening (StateT s c) = Cache.Widening c
instance (ArrowCache a b c) => ArrowCache a b (StateT s c)
instance (TypeError ('Text "StateT is not effect commutative since it allows non-monotonic changes to the state."), Arrow c, Profunctor c)
=> ArrowEffectCommutative (StateT s c)
......
......@@ -191,7 +191,6 @@ instance (Applicative f, ArrowStack a c) => ArrowStack a (StaticT f c) where
{-# SPECIALIZE instance ArrowStack a c => ArrowStack a (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowCache a b c) => ArrowCache a b (StaticT f c) where
type Widening (StaticT f c) = Cache.Widening c
{-# SPECIALIZE instance ArrowCache a b c => ArrowCache a b (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowChaotic a c) => ArrowChaotic a (StaticT f c) where
......
......@@ -191,5 +191,5 @@ instance (Monoid w, ArrowContext ctx c) => ArrowContext ctx (WriterT w c) where
localContext f = lift (Context.localContext (unlift f))
{-# INLINE localContext #-}
instance (Monoid w, ArrowCache a b c) => ArrowCache a b (WriterT w c) where
type Widening (WriterT w c) = Cache.Widening c
instance (Monoid w, ArrowJoinContext a c) => ArrowJoinContext a (WriterT w c)
instance (Monoid w, ArrowCache a b c) => ArrowCache a b (WriterT w c)
......@@ -31,7 +31,7 @@ import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Context
import qualified Data.Abstract.Boolean as Abs
......@@ -59,9 +59,9 @@ spec =
--describe "Parallel" (sharedSpec (\f -> snd . Arrow.run (toParallel f) (S.stackWidening ?stackWiden (S.parallel (T.widening ?widen)))))
describe "Chaotic" $ do
describe "iterate inner component" $
callsiteSpec (\f a -> snd $ Arrow.run (toChaotic f) (callsiteSensitive ?sensitivity fst ?widenA . iterateInner) (T.widening ?widenB) a)
callsiteSpec (\f a -> snd $ Arrow.run (toChaotic f) (callsiteSensitive ?sensitivity fst . iterateInner) (?widenA, T.widening ?widenB) a)
describe "iterate outer component" $
callsiteSpec (\f a -> snd $ Arrow.run (toChaotic f) (callsiteSensitive ?sensitivity fst ?widenA . iterateOuter) (T.widening ?widenB) a)
callsiteSpec (\f a -> snd $ Arrow.run (toChaotic f) (callsiteSensitive ?sensitivity fst . iterateOuter) (?widenA, T.widening ?widenB) a)
data Val = Num IV | Unit | Top deriving (Show,Eq,Generic,Hashable)
......@@ -69,7 +69,7 @@ type Line = Int
{-# INLINE callsiteSpec #-}
callsiteSpec :: (forall lab a b.
(Show lab, Show a, Show b, Identifiable lab, Identifiable a, PreOrd a, Complete b,
(Show lab, Show a, Show b, Identifiable lab, Identifiable a, PreOrd lab, PreOrd a, Complete b,
?sensitivity :: Int, ?widenA :: Widening a, ?widenB :: Widening b)
=> Arr (lab,a) b -> (lab,a) -> Terminating b) -> Spec
callsiteSpec run = do
......@@ -155,8 +155,8 @@ toChaotic :: (Identifiable lab, Identifiable a, Complete b)
(FixT (lab,a) (Terminating b)
(ChaoticT (lab,a)
(StackT Stack (lab,a)
(CacheT (Group Cache) (lab,a) (Terminating b)
(ContextT (CallString lab) a
(CacheT (Context (Proj2 (CtxCache (CallString lab))) Cache) (lab,a) (Terminating b)
(ContextT (CallString lab)
(->)))))) (lab,a) b
toChaotic x = x
{-# INLINE toChaotic #-}
......@@ -13,7 +13,7 @@ import qualified Control.Arrow.Trans as Arrow
import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Stack
-- import Control.Arrow.Transformer.Abstract.Fix.Trace
......@@ -34,7 +34,7 @@ main :: IO ()
main = hspec spec
spec :: Spec
spec = do
spec =
--describe "Parallel" (sharedSpec (\f -> snd . Arrow.run (toParallel f) (S.stackWidening ?stackWiden (S.parallel (T.widening ?widen)))))
describe "Chaotic" $ do
describe "iterate inner component" $
......
flags: {}
extra-package-dbs: []
resolver: lts-13.30
resolver: lts-14.15
packages:
- 'lib'
- 'pcf'
......@@ -8,6 +8,6 @@ packages:
# - 'stratego'
# - 'jimple'
# - 'tutorial'
extra-deps:
- dump-core-0.1.3.2
- monadLib-3.9
# extra-deps:
# - dump-core-0.1.3.2
# - monadLib-3.9
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment