Commit c3725e17 authored by Sven Keidel's avatar Sven Keidel

update fixpoint algorithms to match paper

parent 3bdad688
Pipeline #37988 passed with stages
in 72 minutes and 14 seconds
......@@ -7,19 +7,21 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),FixpointCombinator,transform,filter,trace,trace',traceShow,traceCache) where
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),FixpointCombinator,transform,filter,filter',trace,trace',traceShow,traceCache) where
import Prelude hiding (filter,pred)
import Prelude hiding (filter,pred)
import Control.Arrow
import Control.Arrow.State (ArrowState)
import Control.Arrow
import Control.Arrow.State (ArrowState)
import qualified Control.Arrow.State as State
import Control.Arrow.Trans
import Data.Profunctor
import Data.Lens(Iso',from,get,Prism',getMaybe,set)
import Control.Arrow.Trans
import Control.Arrow.Fix.Metrics
import Data.Profunctor
import Data.Lens(Iso',from,get,Prism',getMaybe,set)
import qualified Debug.Trace as Debug
import Text.Printf
import Text.Printf
-- | Type family that computes the type of the fixpoint.
type family Fix (c :: * -> * -> *) x y :: * -> * -> *
......@@ -52,6 +54,14 @@ filter pred strat f = proc a -> case getMaybe pred a of
Nothing -> f -< a
{-# INLINE filter #-}
filter' :: forall a a' b c. (ArrowChoice c, ArrowApply c, ArrowFiltered a' c) => Prism' a a' -> FixpointCombinator c a' b -> FixpointCombinator c a b
filter' pred strat f = proc a -> case getMaybe pred a of
Just a' -> do
filtered -< a'
strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
{-# INLINE filter' #-}
trace :: (Arrow c) => (a -> String) -> (b -> String) -> FixpointCombinator c a b
trace showA showB f = proc x -> do
y <- f -< Debug.trace (printf "CALL\n%s\n\n" (showA x)) x
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -9,7 +10,6 @@ module Control.Arrow.Fix.Chaotic where
import Prelude hiding (head,iterate,map)
import Control.Arrow hiding (loop)
import Control.Arrow.Trans
import Control.Arrow.Fix
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Cache as Cache
......@@ -21,78 +21,61 @@ import qualified Data.HashSet as H
import Data.Identifiable
import Data.Profunctor
import Data.Order
import Data.Empty
import Text.Printf
class (Arrow c, Profunctor c) => ArrowChaotic a c | c -> a where
setComponent :: c (Component a,y) y
getComponent :: c x y -> c x (Component a,y)
class (Arrow c, Profunctor c) => ArrowComponent component c | c -> component where
setComponent :: c x (component,y) -> c x y
getComponent :: c x y -> c x (component,y)
default setComponent :: (c ~ t c', ArrowLift t, ArrowChaotic a c') => c (Component a,y) y
setComponent = lift' setComponent
{-# INLINE setComponent #-}
chaotic :: forall a b c. (ArrowStack a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
chaotic f = proc a -> do
detectLoop :: (Identifiable a, ArrowComponent (Component a) c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => c a (Component a,b) -> c a b
detectLoop iterate = setComponent $ proc a -> do
loop <- Stack.elem -< a
if loop
then do
m <- Cache.lookup -< a
case m of
Just (_,b) -> returnA -< b
Nothing -> initialize -< a
Just (Stable,b) -> returnA -< (empty, b)
Just (Unstable,b) -> returnA -< (empty { head = H.singleton a }, b)
Nothing -> do
b <- Cache.initialize -< a
returnA -< (mempty { head = H.singleton a }, b)
else
Stack.push iterate -< a
where
iterate = proc a -> do
b <- f -< a
(stable,b') <- Cache.update -< (a,b)
case stable of
Stable -> returnA -< b'
Unstable -> iterate -< a
{-# INLINE chaotic #-}
iterate -< a
{-# INLINE detectLoop #-}
-- | Iterate on the innermost fixpoint component.
iterateInner :: forall a b c. (Identifiable a, ArrowChaotic a c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
{-# INLINE iterateInner #-}
iterateInner f = detectLoop (Stack.push iterate)
innermost :: forall a b c. (Identifiable a, ArrowComponent (Component a) c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
{-# INLINE innermost #-}
innermost f = detectLoop (Stack.push iterate)
where
iterate = proc a -> do
(component,b) <- getComponent f -< a
(comp,b) <- getComponent f -< a
-- 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 -< b
else do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
Stable ->
if head component == H.singleton a
then do
map Cache.setStable -< (Stable,) <$> H.toList (body component)
returnA -< bNew
else do
Cache.setStable -< (Unstable,a)
setComponent -< (component { head = H.delete a (head component)
, body = H.insert a (body component) }, bNew)
Unstable -> iterate -< a
case () of
() | H.null (head comp) -> returnA -< (empty, b)
| H.member a (head comp) -> do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
Stable -> returnA -< (Component { head = H.delete a (head comp), body = H.insert a (body comp) }, bNew)
Unstable -> iterate -< a
| otherwise ->
returnA -< (comp, b)
-- | Iterate on the outermost fixpoint component.
iterateOuter :: forall a b c. (Identifiable a, ArrowChaotic a c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
{-# INLINE iterateOuter #-}
iterateOuter f = detectLoop (Stack.push iterate)
outermost :: forall a b c. (Identifiable a, ArrowComponent (Component a) c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
{-# INLINE outermost #-}
outermost f = detectLoop (Stack.push iterate)
where
iterate = proc a -> do
(component,b) <- getComponent 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 -< b
() | H.null (head component) -> returnA -< (empty, b)
-- We are at the head of a fixpoint component. This means, we
-- have to iterate until the head stabilized.
......@@ -105,7 +88,7 @@ iterateOuter f = detectLoop (Stack.push iterate)
-- too and return.
Stable -> do
map Cache.setStable -< H.toList $ H.map (Stable,) (body component)
returnA -< bNew
returnA -< (empty, bNew)
-- If the head of a fixpoint component is not stable, keep iterating.
Unstable ->
......@@ -113,27 +96,8 @@ iterateOuter f = detectLoop (Stack.push iterate)
-- We are inside an fixpoint component, but its head has not stabilized.
| otherwise -> do
Cache.write -< (a,b,Unstable)
setComponent -< (component { head = H.delete a (head component)
, body = H.insert a (body component) }, b)
detectLoop :: (Identifiable a, ArrowChaotic a c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => c a b -> c a b
detectLoop iterate = proc a -> do
loop <- Stack.elem -< a
if loop
then do
m <- Cache.lookup -< a
case m of
Just (Stable,b) ->
returnA -< b
Just (Unstable,b) ->
setComponent -< (mempty { head = H.singleton a }, b)
Nothing -> do
b <- Cache.initialize -< a
setComponent -< (mempty { head = H.singleton a }, b)
else
iterate -< a
{-# INLINE detectLoop #-}
let comp = Component { head = H.delete a (head component), body = H.insert a (body component) }
returnA -< (comp, b)
data Component a = Component { head :: HashSet a, body :: HashSet a } deriving (Eq)
......@@ -149,8 +113,12 @@ instance Identifiable a => Semigroup (Component a) where
Component h1 b1 <> Component h2 b2 = Component { head = h1 <> h2, body = b1 <> b2 }
{-# INLINE (<>) #-}
instance IsEmpty (Component a) where
empty = Component { head = H.empty, body = H.empty }
{-# INLINE empty #-}
instance Identifiable a => Monoid (Component a) where
mempty = Component { head = H.empty, body = H.empty }
mempty = empty
mappend = (<>)
{-# INLINE mempty #-}
{-# INLINE mappend #-}
......
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Metrics where
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowFiltered a c | c -> a where
filtered :: c a ()
default filtered :: (c ~ t c', ArrowLift t, ArrowFiltered a c') => c a ()
filtered = lift' filtered
......@@ -24,9 +24,9 @@ class (Arrow c, Profunctor c) => ArrowParallel c where
{-# INLINE nextIteration #-}
parallel :: forall a b c. (ArrowParallel c, ArrowStack a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
parallel :: forall a b c. (ArrowParallel c, ArrowStack a c, ArrowStackDepth c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
parallel f = proc a -> do
n <- Stack.size -< ()
n <- Stack.depth -< ()
if n == 0
then iterate -< a
else update -< a
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
......@@ -20,33 +21,40 @@ import Text.Printf
class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
push :: c a b -> c a b
elem :: c a Bool
default elem :: (c ~ t c', ArrowLift t, ArrowStack a c') => c a Bool
elem = lift' elem
{-# INLINE elem #-}
class (Arrow c, Profunctor c) => ArrowStackDepth c where
depth :: c () Int
default depth :: (c ~ t c', ArrowLift t, ArrowStackDepth c') => c () Int
depth = lift' depth
{-# INLINE depth #-}
class (Arrow c, Profunctor c) => ArrowStackElements a c where
elems :: c () [a]
peek :: c () (Maybe a)
size :: c () Int
default elem :: (c ~ t c', ArrowLift t, ArrowStack a c') => c a Bool
default elems :: (c ~ t c', ArrowLift t, ArrowStack a c') => c () [a]
default peek :: (c ~ t c', ArrowLift t, ArrowStack a c') => c () (Maybe a)
default size :: (c ~ t c', ArrowLift t, ArrowStack a c') => c () Int
default elems :: (c ~ t c', ArrowLift t, ArrowStackElements a c') => c () [a]
default peek :: (c ~ t c', ArrowLift t, ArrowStackElements a c') => c () (Maybe a)
elem = lift' elem
elems = lift' elems
peek = lift' peek
size = lift' size
{-# INLINE elems #-}
{-# INLINE peek #-}
{-# INLINE size #-}
maxSize :: (ArrowChoice c, ArrowStack a c) => Int -> FixpointCombinator c a b -> FixpointCombinator c a b
maxSize limit strat f = proc a -> do
n <- size -< ()
maxDepth :: (ArrowChoice c, ArrowStackDepth c) => Int -> FixpointCombinator c a b -> FixpointCombinator c a b
maxDepth limit strat f = proc a -> do
n <- depth -< ()
if n < limit
then f -< a
else strat f -< a
{-# INLINE maxSize #-}
{-# INLINE maxDepth #-}
widenInput :: (Complete a, ArrowStack a c) => Widening a -> FixpointCombinator c a b
widenInput :: (Complete a, ArrowStackElements a c) => Widening a -> FixpointCombinator c a b
widenInput widen f = proc a -> do
m <- peek -< ()
f -< case m of
......@@ -54,13 +62,13 @@ widenInput widen f = proc a -> do
Just x -> snd $ x `widen` (x a)
{-# INLINE widenInput #-}
reuse :: (ArrowChoice c, ArrowStack a c) => (a -> [a] -> Maybe a) -> FixpointCombinator c a b
reuse :: (ArrowChoice c, ArrowStackElements a c) => (a -> [a] -> Maybe a) -> FixpointCombinator c a b
reuse select f = proc a -> do
xs <- elems -< ()
f -< fromMaybe a (select a xs)
{-# INLINE reuse #-}
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowStack a c) => FixpointCombinator c a b
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowStackElements a c) => FixpointCombinator c a b
reuseFirst = reuse find
where
find a (x:xs)
......@@ -69,7 +77,7 @@ reuseFirst = reuse find
find _ [] = Nothing
{-# INLINE reuseFirst #-}
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowStack a c) => Metric a n -> FixpointCombinator c a b
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowStackElements a c) => Metric a n -> FixpointCombinator c a b
reuseByMetric metric = reuse find
where
find a xs = element <$> foldMap (\a' -> if a a' then Just (Measured a' (metric a a')) else Nothing) xs
......
......@@ -8,7 +8,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT) where
module Control.Arrow.Transformer.Abstract.Fix.Component(ComponentT,runComponentT) where
import Prelude hiding (id,pred,lookup,map,head,iterate,(.),elem)
......@@ -29,34 +29,34 @@ import Data.Profunctor
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,
newtype ComponentT a c x y = ComponentT (WriterT (Component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowStackDepth,ArrowStackElements a,ArrowCache a b,
ArrowState s,ArrowContext ctx, ArrowJoinContext u, ArrowControlFlow stmt)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowChaotic a (ChaoticT a c) where
setComponent = lift id
instance (Identifiable a, Arrow c, Profunctor c) => ArrowComponent (Component a) (ComponentT a c) where
setComponent f = lift (rmap snd (unlift f))
getComponent f = lift $ proc a -> do
(component,b) <- unlift f -< a
returnA -< (mempty,(component,b))
{-# INLINE setComponent #-}
{-# INLINE getComponent #-}
runChaoticT :: Profunctor c => ChaoticT a c x y -> c x y
runChaoticT (ChaoticT f) = rmap snd (runWriterT f)
{-# INLINE runChaoticT #-}
runComponentT :: Profunctor c => ComponentT a c x y -> c x y
runComponentT (ComponentT f) = rmap snd (runWriterT f)
{-# INLINE runComponentT #-}
instance (Identifiable a, ArrowRun c) => ArrowRun (ChaoticT a c) where
type Run (ChaoticT a c) x y = Run c x y
run f = run (runChaoticT f)
instance (Identifiable a, ArrowRun c) => ArrowRun (ComponentT a c) where
type Run (ComponentT a c) x y = Run c x y
run f = run (runComponentT f)
{-# INLINE run #-}
instance ArrowTrans (ChaoticT a c) where
type Underlying (ChaoticT a c) x y = c x (Component a,y)
instance ArrowTrans (ComponentT a c) where
type Underlying (ComponentT a c) x y = c x (Component a,y)
instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ChaoticT a c) where
app = ChaoticT (lmap (first coerce) app)
instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ComponentT a c) where
app = ComponentT (lmap (first coerce) app)
{-# INLINE app #-}
deriving instance (Identifiable a, ArrowJoin c) => ArrowJoin (ChaoticT a c)
deriving instance (Identifiable a, ArrowComplete (Component a,y) c) => ArrowComplete y (ChaoticT a c)
instance (Identifiable a, ArrowEffectCommutative c) => ArrowEffectCommutative (ChaoticT a c)
deriving instance (Identifiable a, ArrowJoin c) => ArrowJoin (ComponentT a c)
deriving instance (Identifiable a, ArrowComplete (Component a,y) c) => ArrowComplete y (ComponentT a c)
instance (Identifiable a, ArrowEffectCommutative c) => ArrowEffectCommutative (ComponentT a c)
......@@ -16,6 +16,8 @@ import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Fix.Metrics (ArrowFiltered)
import qualified Control.Arrow.Fix.Metrics as F
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.Cache as Cache
......@@ -36,36 +38,48 @@ import Data.Coerce
import Text.Printf
newtype MetricsT a c x y = MetricsT (StateT (Metrics a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowChaotic a,ArrowControlFlow stmt)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComponent comp,ArrowControlFlow stmt,ArrowStackDepth,ArrowStackElements a)
data Metrics a = Metrics Int (HashMap a Metric)
data Metrics a = Metrics { iteration :: Int, metricCache :: HashMap a Metric }
data Metric = Metric { initializes :: Int, lookups :: Int, updates :: Int } deriving (Show)
data Metric = Metric { filtered :: Int, stackLookups :: Int, cacheEntries :: Int, cacheLookups :: Int, updates :: Int } deriving (Show)
instance Semigroup Metric where
Metric i1 l1 u1 <> Metric i2 l2 u2 = Metric (i1 + i2) (l1 + l2) (u1 + u2)
Metric f1 i1 l1 u1 s1 <> Metric f2 i2 l2 u2 s2 = Metric (f1 + f2) (i1 + i2) (l1 + l2) (u1 + u2) (s1 + s2)
instance Monoid Metric where
mempty = Metric 0 0 0
mempty = Metric 0 0 0 0 0
mappend = (<>)
{-# INLINE mappend #-}
csvHeader :: String
csvHeader = "Iterations,Filtered,Stack Lookups,Cache Entries,Cache Lookups,Cache Updates"
toCSV :: Metrics a -> String
toCSV (Metrics iter m) =
let Metric i l u = fold m
in printf "%d,%d,%d,%d" iter i l u
let Metric f i l u s = fold m
in printf "%d,%d,%d,%d,%d,%d" iter f i l u s
instance IsEmpty (Metrics a) where
empty = Metrics 1 empty
instance (ArrowApply c, ArrowStack a c) => ArrowStack a (MetricsT a c) where
instance (Identifiable a, Arrow c,Profunctor c) => ArrowFiltered a (MetricsT a c) where
filtered = MetricsT $ proc a ->
modifyMetric setFiltered -< a
instance (Identifiable a, ArrowApply c, ArrowStack a c) => ArrowStack a (MetricsT a c) where
elem = MetricsT $ proc a -> do
modifyMetric incrementStackLookups -< a
lift' elem -< a
push f = lift $ proc (m,a) ->
push (proc a' -> unlift f -< (m,a')) -<< a
{-# INLINE elem #-}
{-# INLINE push #-}
instance (Identifiable a, ArrowChoice c, Profunctor c, ArrowCache a b c) => ArrowCache a b (MetricsT a c) where
initialize = MetricsT $ proc a -> do
modifyMetric incrementInitializes -< a
initialize -< a
lookup = MetricsT $ proc a -> do
modifyMetric incrementLookups -< a
modifyMetric incrementCacheLookups -< a
Cache.lookup -< a
update = MetricsT $ proc (a,b) -> do
modifyMetric incrementUpdates -< a
......@@ -73,12 +87,10 @@ instance (Identifiable a, ArrowChoice c, Profunctor c, ArrowCache a b c) => Arro
write = MetricsT $ proc (a,b,s) -> do
modifyMetric incrementUpdates -< a
write -< (a,b,s)
setStable = MetricsT Cache.setStable
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
instance (Profunctor c, Arrow c, ArrowParallel c) => ArrowParallel (MetricsT a c) where
nextIteration = MetricsT $ proc () -> do
......@@ -88,16 +100,22 @@ instance (Profunctor c, Arrow c, ArrowParallel c) => ArrowParallel (MetricsT a c
modifyMetric :: (Identifiable a, ArrowState (Metrics a) c) => (Metric -> Metric) -> c a ()
modifyMetric f = modify' (\(a,Metrics iter m) -> ((),Metrics iter (upsert f a m)))
{-# INLINE modifyMetric #-}
setFiltered :: Metric -> Metric
setFiltered m = m { filtered = 1 }
incrementInitializes :: Metric -> Metric
incrementInitializes m@Metric{..} = m { initializes = initializes + 1 }
incrementInitializes m@Metric{..} = m { cacheEntries = 1 }
incrementCacheLookups :: Metric -> Metric
incrementCacheLookups m@Metric{..} = m { cacheEntries = 1, cacheLookups = cacheLookups + 1 }
incrementLookups :: Metric -> Metric
incrementLookups m@Metric{..} = m { lookups = lookups + 1 }
incrementStackLookups :: Metric -> Metric
incrementStackLookups m@Metric{..} = m { cacheEntries = 1, cacheLookups = cacheLookups + 1 }
incrementUpdates :: Metric -> Metric
incrementUpdates m@Metric{..} = m { updates = updates + 1 }
incrementUpdates m@Metric{..} = m { cacheEntries = 1, updates = updates + 1 }
incrementIterations :: ArrowState (Metrics a) c => c () ()
incrementIterations = modify' (\((),Metrics iter m) -> ((),Metrics (iter + 1) m))
......
......@@ -15,7 +15,7 @@ import Control.Arrow hiding (loop)
import Control.Arrow.Fix.ControlFlow as ControlFlow
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack (ArrowStack)
import Control.Arrow.Fix.Stack (ArrowStack,ArrowStackDepth,ArrowStackElements)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context (ArrowContext,ArrowJoinContext)
import Control.Arrow.State
......@@ -40,27 +40,33 @@ newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y)
data Stack a = Stack
{ elems :: HashSet a
, stack :: [a]
, size :: !Int
, depth :: !Int
}
instance IsEmpty (Stack a) where
empty = Stack { elems = empty, stack = empty, size = 0 }
empty = Stack { elems = empty, stack = empty, depth = 0 }
{-# INLINE empty #-}
instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a c) where
push f = lift $ proc (st,a) -> do
let st' = st { elems = Set.insert a (elems st)
, stack = a : stack st
, size = size st + 1
, depth = depth st + 1
}
unlift f -< (st', a)
elem = lift $ proc (st,a) -> returnA -< Set.member a (elems st)
{-# INLINE push #-}
{-# INLINE elem #-}
instance (Arrow c, Profunctor c) => ArrowStackDepth (StackT Stack a c) where
depth = lift $ proc (st,()) -> returnA -< depth st
{-# INLINE depth #-}
instance (Identifiable a, Arrow c, Profunctor c) => ArrowStackElements a (StackT Stack a c) where
peek = lift $ proc (st,()) -> returnA -< case stack st of [] -> Nothing; (x:_) -> Just x
elems = lift $ proc (st,()) -> returnA -< stack st
size = lift $ proc (st,()) -> returnA -< size st
{-# INLINE peek #-}
{-# INLINE push #-}
{-# INLINE size #-}
{-# INLINE elems #-}
runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y
runStackT (StackT f) = lmap (empty,) (runReaderT f)
......
......@@ -30,7 +30,7 @@ import Text.Printf
newtype TraceT c x y = TraceT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowComplete z,ArrowJoin,
ArrowEffectCommutative,ArrowChaotic a,ArrowStack a,ArrowContext ctx,ArrowState s,ArrowControlFlow stmt)
ArrowEffectCommutative,ArrowComponent a,ArrowStack a,ArrowContext ctx,ArrowState s,ArrowControlFlow stmt)
instance ArrowParallel c => ArrowParallel (TraceT c) where
nextIteration = TraceT $ proc () ->
......
......@@ -46,7 +46,7 @@ newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,
ArrowContext ctx, ArrowStack a, ArrowCache a b, ArrowChaotic a,ArrowControlFlow stmt)
ArrowContext ctx, ArrowStack a, ArrowCache a b, ArrowComponent a,ArrowControlFlow stmt)
constT :: (r -> c x y) -> ConstT r c x y
constT f = ConstT (StaticT f)
......
......@@ -18,6 +18,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.Cache as Cache
......@@ -200,9 +201,11 @@ instance ArrowWidening y c => ArrowWidening y (StateT s c) where
instance (ArrowCache a b c) => ArrowCache a b (StateT s c)
instance ArrowControlFlow stmt c => ArrowControlFlow stmt (StateT s c)
instance ArrowStackDepth c => ArrowStackDepth (StateT s c)
instance ArrowStackElements a c => ArrowStackElements a (StateT s c)
instance ArrowChaotic a c => ArrowChaotic a (StateT s c) where
setComponent = lift' setComponent
instance ArrowComponent a c => ArrowComponent a (StateT s c) where
setComponent f = lift $ setComponent (rmap shuffle1 (unlift f))
getComponent f = lift $ rmap shuffle1 (getComponent (unlift f))
{-# INLINE setComponent #-}
{-# INLINE getComponent #-}
......
......@@ -178,21 +178,18 @@ instance (Applicative f, ArrowContext ctx c) => ArrowContext ctx (StaticT f c) w
{-# SPECIALIZE instance ArrowContext ctx c => ArrowContext ctx (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowStack a c) => ArrowStack a (StaticT f c) where
peek = lift' peek
size = lift' size
push (StaticT f) = StaticT $ push <$> f
{-# INLINE peek #-}
{-# INLINE size #-}
{-# INLINE push #-}
{-# SPECIALIZE instance ArrowStack a c => ArrowStack a (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowCache a b c) => ArrowCache a b (StaticT f c) where
{-# SPECIALIZE instance ArrowCache a b c => ArrowCache a b (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowChaotic a c) => ArrowChaotic a (StaticT f c) where
instance (Applicative f, ArrowComponent comp c) => ArrowComponent comp (StaticT f c) where
getComponent (StaticT f) = StaticT $ Chaotic.getComponent <$> f
setComponent (StaticT f) = StaticT $ Chaotic.setComponent <$> f
{-# INLINE getComponent #-}
{-# SPECIALIZE instance ArrowChaotic a c => ArrowChaotic a (StaticT ((->) r) c) #-}
{-# SPECIALIZE instance ArrowComponent comp c => ArrowComponent comp (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (StaticT f c) where
{-# SPECIALIZE instance ArrowControlFlow stmt c => ArrowControlFlow stmt (StaticT ((->) r) c) #-}
......
......@@ -179,6 +179,9 @@ instance (Monoid w, ArrowStack a c) => ArrowStack a (WriterT w c) where
push f = lift $ Stack.push (unlift f)
{-# INLINE push #-}