Verified Commit 34d54bf1 authored by Sven Keidel's avatar Sven Keidel
Browse files

refactor context sensitivity interfaces

parent 721273b8
Pipeline #79266 failed with stages
in 63 minutes and 45 seconds
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Trans where
......
......@@ -6,16 +6,10 @@ module Control.Arrow.Transformer.Mealy where
import Prelude hiding (id,(.))
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Trans
import Control.Arrow.Writer
import Unsafe.Coerce
import Data.Monoidal
import Data.Profunctor hiding (Strong(..))
import Data.Profunctor.Unsafe
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Fix.CallCount where
import Prelude hiding ((.))
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Monad
import Control.Arrow.Fix
import Control.Arrow.Fix.Context
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Writer
import Data.Profunctor
import Data.Monoidal
class (Arrow c, Profunctor c) => ArrowCallCount a c | c -> a where
getCallCount :: c a Int
incrementCallCount :: c x y -> c (a,x) y
default getCallCount :: (c ~ t c', ArrowTrans t, ArrowCallCount a c') => c a Int
getCallCount = lift' getCallCount
{-# INLINE getCallCount #-}
unroll :: (?contextWidening :: Widening c, ArrowChoice c,
ArrowCallCount label c, ArrowContext label a c)
=> Int -> (a -> label) -> FixpointCombinator c a b
unroll k getLabel f = proc a -> do
let lab = getLabel a
count <- getCallCount -< lab
if count < k
then incrementCallCount f -< (lab, a)
else do
a' <- joinByContext -< (lab, a)
incrementCallCount f -< (lab, a')
{-# INLINE unroll #-}
------------- Instances --------------
instance ArrowCallCount label c => ArrowCallCount label (ConstT r c) where
incrementCallCount f = lift $ \r -> incrementCallCount (unlift f r)
{-# INLINE incrementCallCount #-}
instance (ArrowMonad f c, ArrowCallCount callSite c) => ArrowCallCount callSite (KleisliT f c) where
incrementCallCount f = lift $ incrementCallCount (unlift f)
{-# INLINE incrementCallCount #-}
instance ArrowCallCount label c => ArrowCallCount label (ReaderT r c) where
incrementCallCount f = lift $ lmap shuffle1 (incrementCallCount (unlift f))
{-# INLINE incrementCallCount #-}
instance ArrowCallCount label c => ArrowCallCount label (StateT s c) where
incrementCallCount f = lift $ lmap shuffle1 (incrementCallCount (unlift f))
{-# INLINE incrementCallCount #-}
instance (Applicative f, ArrowCallCount label c) => ArrowCallCount label (StaticT f c) where
incrementCallCount (StaticT f) = StaticT $ incrementCallCount <$> f
{-# INLINE incrementCallCount #-}
instance (Monoid w, ArrowCallCount label c) => ArrowCallCount label (WriterT w c) where
incrementCallCount f = lift $ incrementCallCount (unlift f)
{-# INLINE incrementCallCount #-}
......@@ -10,7 +10,6 @@
module Control.Arrow.Fix.Context where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Monad
import Control.Arrow.Fix
......@@ -26,71 +25,75 @@ import Data.Profunctor
import Data.Monoidal
import Data.Abstract.CallString as CallString
class (Arrow c, Profunctor c) => ArrowContext ctx c | c -> ctx where
askContext :: c () ctx
localContext :: c x y -> c (ctx,x) y
default askContext :: (c ~ t c', ArrowTrans t, ArrowContext ctx c') => c () ctx
askContext = lift' askContext
{-# INLINE askContext #-}
class (Arrow c, Profunctor c) => ArrowJoinContext a c | c -> a where
class (Arrow c, Profunctor c) => ArrowContext ctx a c | c -> a, c -> ctx where
type Widening c
joinByContext :: (?contextWidening :: Widening c) => c (ctx,a) a
joinByContext :: (?contextWidening :: Widening c) => c a a
default joinByContext :: (c ~ t c', ArrowTrans t, ArrowJoinContext a c', ?contextWidening :: Widening c') => c a a
default joinByContext :: (c ~ t c', ArrowTrans t, ArrowContext ctx a c', ?contextWidening :: Widening c') => c (ctx,a) a
joinByContext = lift' joinByContext
{-# INLINE joinByContext #-}
callsiteSensitive :: forall a lab b c. (?contextWidening :: Widening c, ArrowContext (CallString lab) c, ArrowJoinContext a c) => Int -> (a -> lab) -> FixpointCombinator c a b
callsiteSensitive k getLabel = callsiteSensitive' k (Just . getLabel)
class (Arrow c, Profunctor c) => ArrowCallSite label c | c -> label where
getCallSite :: c () (CallString label)
pushLabel :: Int -> c x y -> c (label, x) y
default getCallSite :: (c ~ t c', ArrowTrans t, ArrowCallSite label c') => c () (CallString label)
getCallSite = lift' getCallSite
{-# INLINE getCallSite #-}
callsiteSensitive :: (?contextWidening :: Widening c,
ArrowCallSite lab c,
ArrowContext (CallString lab) a c)
=> Int -> (a -> lab) -> FixpointCombinator c a b
callsiteSensitive k getLabel = callsiteSensitive' k getLabel
{-# INLINE callsiteSensitive #-}
callsiteSensitive' :: forall a lab b c. (?contextWidening :: Widening c, ArrowContext (CallString lab) c, ArrowJoinContext a c) => Int -> (a -> Maybe lab) -> FixpointCombinator c a b
callsiteSensitive' k getLabel f = recordCallsite k getLabel $ f . joinByContext
callsiteSensitive' :: (?contextWidening :: Widening c,
ArrowCallSite lab c,
ArrowContext (CallString lab) a c)
=> Int -> (a -> lab) -> FixpointCombinator c a b
callsiteSensitive' k getLabel f = recordCallSite k getLabel $ proc a -> do
callSite <- getCallSite -< ()
a' <- joinByContext -< (callSite, a)
f -< a'
{-# INLINE callsiteSensitive' #-}
recordCallsite :: forall a lab b c. ArrowContext (CallString lab) c => Int -> (a -> Maybe lab) -> FixpointCombinator c a b
recordCallsite k getLabel g = proc a -> do
callString <- askContext -< ()
let callString' = case getLabel a of
Just lab -> CallString.truncate k (CallString.push lab callString)
Nothing -> callString
localContext g -< (callString',a)
{-# INLINE recordCallsite #-}
recordCallSite :: (ArrowCallSite lab c) => Int -> (a -> lab) -> FixpointCombinator c a b
recordCallSite k getLabel f = proc a -> do
pushLabel k f -< (getLabel a, a)
{-# INLINE recordCallSite #-}
------------- Instances --------------
instance ArrowContext ctx c => ArrowContext ctx (ConstT r c) where
localContext f = lift $ \r -> localContext (unlift f r)
{-# INLINE localContext #-}
instance ArrowCallSite label c => ArrowCallSite label (ConstT r c) where
pushLabel k f = lift $ \r -> pushLabel k (unlift f r)
{-# INLINE pushLabel #-}
instance (ArrowMonad f c, ArrowContext ctx c) => ArrowContext ctx (KleisliT f c) where
localContext (KleisliT f) = KleisliT (localContext f)
{-# INLINE localContext #-}
instance (ArrowMonad f c, ArrowCallSite callSite c) => ArrowCallSite callSite (KleisliT f c) where
pushLabel k f = lift $ pushLabel k (unlift f)
{-# INLINE pushLabel #-}
instance ArrowContext ctx c => ArrowContext ctx (ReaderT r c) where
localContext f = lift $ lmap shuffle1 (localContext (unlift f))
{-# INLINE localContext #-}
instance ArrowCallSite label c => ArrowCallSite label (ReaderT r c) where
pushLabel k f = lift $ lmap shuffle1 (pushLabel k (unlift f))
{-# INLINE pushLabel #-}
instance ArrowJoinContext a c => ArrowJoinContext a (ReaderT r c) where
instance ArrowContext ctx a c => ArrowContext ctx a (ReaderT r c) where
type Widening (ReaderT r c) = Widening c
instance ArrowContext ctx c => ArrowContext ctx (StateT s c) where
localContext f = lift (lmap shuffle1 (localContext (unlift f)))
{-# INLINE localContext #-}
instance ArrowCallSite label c => ArrowCallSite label (StateT s c) where
pushLabel k f = lift $ lmap shuffle1 (pushLabel k (unlift f))
{-# INLINE pushLabel #-}
instance ArrowJoinContext a c => ArrowJoinContext a (StateT s c) where
instance ArrowContext ctx a c => ArrowContext ctx a (StateT s c) where
type Widening (StateT s c) = Widening c
instance (Applicative f, ArrowContext ctx c) => ArrowContext ctx (StaticT f c) where
localContext (StaticT f) = StaticT $ localContext <$> f
{-# INLINE localContext #-}
{-# SPECIALIZE instance ArrowContext ctx c => ArrowContext ctx (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowCallSite label c) => ArrowCallSite label (StaticT f c) where
pushLabel k (StaticT f) = StaticT $ pushLabel k <$> f
{-# INLINE pushLabel #-}
instance (Monoid w, ArrowContext ctx c) => ArrowContext ctx (WriterT w c) where
localContext f = lift (localContext (unlift f))
{-# INLINE localContext #-}
instance (Monoid w, ArrowCallSite label c) => ArrowCallSite label (WriterT w c) where
pushLabel k f = lift $ pushLabel k (unlift f)
{-# INLINE pushLabel #-}
instance (Monoid w, ArrowJoinContext a c) => ArrowJoinContext a (WriterT w c) where
instance (Monoid w, ArrowContext ctx a c) => ArrowContext ctx a (WriterT w c) where
type Widening (WriterT w c) = Widening c
......@@ -31,7 +31,7 @@ type StackPointer = Int
data RecurrentCall = RecurrentCall StackPointer | NoLoop deriving (Show)
class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
push :: c x y -> c (a, x) (y)
push :: c x y -> c (a, x) y
elem :: c a RecurrentCall
default elem :: (c ~ t c', ArrowTrans t, ArrowStack a c') => c a RecurrentCall
......
......@@ -37,7 +37,7 @@ newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, ArrowTrans, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowFail e, ArrowExcept e, ArrowContext ctx)
ArrowFail e, ArrowExcept e, ArrowCallSite ctx)
runCompletionT :: CompletionT c x y -> c x (FreeCompletion y)
runCompletionT = coerce
......
......@@ -38,7 +38,7 @@ import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, ArrowTrans, ArrowRun,
ArrowCont, ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowLetRec var val, ArrowClosure expr cls, ArrowStore a b, ArrowContext ctx,
ArrowEnv var val, ArrowLetRec var val, ArrowClosure expr cls, ArrowStore a b, ArrowCallSite ctx,
ArrowExcept e', ArrowLowerBounded a)
runErrorT :: ErrorT e c x y -> c x (Error e y)
......
......@@ -36,7 +36,7 @@ newtype FailureT e c x y = FailureT (KleisliT (Failure e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, ArrowTrans, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowExcept e', ArrowContext ctx)
ArrowExcept e', ArrowCallSite ctx)
runFailureT :: FailureT e c x y -> c x (Failure e y)
runFailureT = coerce
......
......@@ -58,7 +58,7 @@ newtype EnvStoreT var addr val c x y =
c) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLowerBounded a,
ArrowFail e, ArrowExcept e, ArrowRun, ArrowCont,
ArrowContext ctx, ArrowControlFlow stmt)
ArrowCallSite ctx, ArrowControlFlow stmt)
instance ArrowLift (EnvStoreT var addr val c) where
type Underlying (EnvStoreT var addr val c) x y =
......
......@@ -53,7 +53,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, Widening val) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift, ArrowLowerBounded a,
ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowRun, ArrowCont,
ArrowContext ctx)
ArrowCallSite ctx)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT var addr val c) where
type Join y (EnvT var addr val c) = ()
......
......@@ -19,6 +19,7 @@ import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Control.Arrow.Fix.CallCount
import Control.Arrow.Fix.SCC
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Context
......@@ -36,10 +37,10 @@ import Control.Arrow.State
newtype FixT c x y = FixT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,
ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a,
ArrowCallSite ctx, ArrowContext ctx a, ArrowControlFlow a,
ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowSCC a,
ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a, ArrowCallCount a)
runFixT :: FixT c x y -> c x y
runFixT (FixT f) = f
......
......@@ -24,6 +24,7 @@ import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Fix.CallCount as CallCount
import Control.Arrow.Fix.ControlFlow as ControlFlow
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Cache as Cache
......@@ -49,7 +50,8 @@ import GHC.Exts
newtype CacheT cache a b c x y = CacheT { unCacheT :: StateT (cache a b) c x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,ArrowTrans,
ArrowState (cache a b),ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
ArrowState (cache a b),ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph,
ArrowCallCount a', ArrowCallSite ctx, ArrowContext ctx a')
instance (IsEmpty (cache a b), ArrowRun c) => ArrowRun (CacheT cache a b c) where
type Run (CacheT cache a b c) x y = Run c x (cache a b,y)
......@@ -62,10 +64,6 @@ instance ArrowLift (CacheT cache a b c) where
instance (Arrow c, Profunctor c) => ArrowGetCache (cache a b) (CacheT cache a b c) where
getCache = CacheT get
instance (Arrow c, ArrowContext ctx c) => ArrowContext ctx (CacheT cache a b c) where
localContext (CacheT f) = CacheT (localContext f)
{-# INLINE localContext #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT cache a b c) where
app = CacheT (app .# first coerce)
{-# INLINE app #-}
......@@ -162,13 +160,6 @@ instance (Identifiable k, Arrow c, Profunctor c, ArrowCache a b (CacheT cache a
{-# SCC update #-}
{-# SCC setStable #-}
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
type Widening (CacheT (Group cache) (k,a) b c) = Context.Widening (CacheT cache a b c)
joinByContext = proc (k,a) -> do
a' <- withGroup joinByContext -< (k,a)
returnA -< (k,a')
{-# INLINE joinByContext #-}
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
......@@ -449,142 +440,3 @@ instance (Arrow c, Profunctor c) => ArrowIterateCache (s,a) (s,b) (CacheT Monoto
put -< MonotoneFactor sNew empty
returnA -< ((sNew,a),(sNew,b))
{-# INLINE nextIteration #-}
------ Product Cache ------
-- 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 #-}
-- (**) :: (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 (**) #-}
-- 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
-- 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 #-}
------ Second Projection ------
data Proj2 cache a b where
Proj2 :: cache a b -> Proj2 cache (u,a) b
-- type instance Widening (Proj2 cache (u,a) b) = Widening (cache a b)
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
type Widening (CacheT (Proj2 cache) (u,a) b c) = Context.Widening (CacheT cache a b c)
joinByContext = lift $
dimap (\(Proj2 cache,(u,a)) -> (u,(cache,a))) (\(u,(cache,a)) -> (Proj2 cache,(u,a)))
(second (unlift (joinByContext :: CacheT cache a b c a a)))
{-# INLINE joinByContext #-}
------ 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 #-}
instance (Arrow c, Profunctor c, ArrowCache a b (CacheT cache a b c)) => ArrowCache a b (CacheT (Context ctx cache) a b c) where
type Widening (CacheT (Context ctx cache) a b c) = Cache.Widening (CacheT cache a b c)
initialize = withCache initialize
lookup = withCache lookup
update = withCache update
write = withCache write
setStable = withCache setStable
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
-- 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 #-}
instance (Arrow c, Profunctor c, ArrowJoinContext a (CacheT ctx a b c)) => ArrowJoinContext a (CacheT (Context ctx cache) a b c) where
type Widening (CacheT (Context ctx cache) a b c) = Context.Widening (CacheT ctx a b c)
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
withCache f = lift $ dimap (\(Context ctx cache,x) -> (ctx,(cache,x))) (\(ctx,(cache,x2)) -> (Context ctx cache,x2)) (second (unlift f))
{-# INLINE withCache #-}
withCtx :: (Profunctor c, Arrow c) => CacheT ctx a b c x y -> CacheT (Context ctx cache) a b c x y
withCtx f = lift $ dimap (\(Context ctx cache, a) -> (cache,(ctx,a))) (\(cache,(ctx,a)) -> (Context ctx cache,a)) (second (unlift f))
{-# INLINE withCtx #-}
------ Context Cache ------
newtype CtxCache ctx a b = CtxCache (HashMap ctx a)
-- type instance Widening (CtxCache ctx a b) = W.Widening a
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
type Widening (CacheT (CtxCache ctx) a b c) = W.Widening a
joinByContext = lift $ proc (CtxCache cache, a) -> do
ctx <- Context.askContext -< ()
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 input.
Just a'
| a a' -> (CtxCache cache, a')
| otherwise ->
-- If there exists the actual input is not smaller than the cached
-- input, widen the input.
let (_,a'') = ?contextWidening a' a
in (CtxCache (M.insert ctx a'' cache),a'')
Nothing -> (CtxCache (M.insert ctx a cache),a)
{-# INLINE joinByContext #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.CallCount(CallCountT) where
import Prelude hiding (pred,lookup,map,head,iterate,(.),elem)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Fix.ControlFlow as ControlFlow
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack (ArrowStack)
import Control.Arrow.Fix.Context (ArrowContext)
import Control.Arrow.Fix.CallCount
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Order (ArrowLowerBounded)
import Control.Arrow.Transformer.Reader
import Data.Profunctor
import Data.Profunctor.Unsafe ((.#))
import Data.Coerce
import Data.Identifiable
import Data.Empty
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as Map
newtype CallCountT label c x y = StackT (ReaderT (HashMap label Int) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,
ArrowStrict,ArrowTrans, ArrowLowerBounded z,
ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowState s, ArrowStack a, ArrowContext ctx a',
ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
instance Profunctor c => ArrowLift (CallCountT label c) where
type Underlying (CallCountT label c) x y = c (HashMap label Int, x) y
instance (ArrowRun c) => ArrowRun (CallCountT label c) where
type Run (CallCountT label c) x y = Run c x y
run f = run (lmap (\x -> (empty,x)) (unlift f))
{-# INLINE run #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (CallCountT label c) where
app = StackT (app .# first coerce)
{-# INLINE app #-}
instance ArrowCache a b c => ArrowCache a b (CallCountT label c) where
type Widening (CallCountT label c) = Widening c
instance (Identifiable label, Arrow c, Profunctor c) => ArrowCallCount label (CallCountT label c) where
getCallCount = lift $ arr (\(callCount, label) -> Map.lookupDefault 0 label callCount)