Commit 5616e1e3 authored by Sven Keidel's avatar Sven Keidel

update stratego

parent e584c808
Pipeline #17324 failed with stages
in 80 minutes and 24 seconds
...@@ -18,6 +18,7 @@ import Control.Arrow.Fix.Cache ...@@ -18,6 +18,7 @@ import Control.Arrow.Fix.Cache
import Data.Abstract.Stable import Data.Abstract.Stable
import Data.Order
import Data.Metric import Data.Metric
import Data.Profunctor import Data.Profunctor
import Data.Monoid (First(..)) import Data.Monoid (First(..))
...@@ -27,11 +28,15 @@ import Text.Printf ...@@ -27,11 +28,15 @@ import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where class (Arrow c, Profunctor c) => ArrowReuse a b c where
-- | Reuse cached results at the cost of precision. -- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => (a -> a -> Stable -> b -> m) -> c (a,Stable) m reuse :: (Monoid m) => Stable -> (a -> a -> Stable -> b -> m -> m) -> c a m
reuseFirst :: (ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b reuseFirst :: (PreOrd a, ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b
reuseFirst st f = proc a -> do reuseFirst s f = proc a -> do
m <- reuse (\_ a' s' b' -> First (Just (a',b',s'))) -< (a,st) m <- reuse s (\a a' s' b' m -> case m of
First (Just _) -> m
First Nothing
| a a' -> First (Just (a',b',s'))
| otherwise -> m) -< a
case getFirst m of case getFirst m of
Just (_,b,Stable) -> returnA -< b Just (_,b,Stable) -> returnA -< b
Just (a',_,Unstable) -> f -< a' Just (a',_,Unstable) -> f -< a'
...@@ -46,17 +51,20 @@ reuseExact f = proc a -> do ...@@ -46,17 +51,20 @@ reuseExact f = proc a -> do
_ -> f -< a _ -> f -< a
{-# INLINE reuseExact #-} {-# INLINE reuseExact #-}
reuseByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b reuseByMetric :: (PreOrd a, 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 reuseByMetric metric = reuseByMetric_ (\s a a' -> Product s (metric a a')) Unstable
{-# INLINE reuseByMetric #-} {-# INLINE reuseByMetric #-}
reuseStableByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b reuseStableByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseStableByMetric metric = reuseByMetric_ (const metric) Stable reuseStableByMetric metric = reuseByMetric_ (const metric) Stable
{-# INLINE reuseStableByMetric #-} {-# INLINE reuseStableByMetric #-}
reuseByMetric_ :: (Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b reuseByMetric_ :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
reuseByMetric_ metric st f = proc a -> do reuseByMetric_ metric s 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) m <- reuse s (\a a' s' b' m ->
if a a'
then m <> Just (Measured { input = a', output = b', stable = s', measured = metric s' a a' })
else m) -< a
case m of case m of
Just Measured { stable = Stable, output = b } -> returnA -< b Just Measured { stable = Stable, output = b } -> returnA -< b
Just Measured { stable = Unstable, input = a' } -> f -< a' Just Measured { stable = Unstable, input = a' } -> f -< a'
......
...@@ -52,16 +52,19 @@ joinList empty f = proc (e,(l,s)) -> case l of ...@@ -52,16 +52,19 @@ joinList empty f = proc (e,(l,s)) -> case l of
[] -> empty -< (e,s) [] -> empty -< (e,s)
[x] -> f -< (e,(x,s)) [x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s))) (x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s)))
{-# INLINABLE joinList #-}
joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (e,(x,s)) y -> c (e,([x],s)) y joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 f = proc (e,(l,s)) -> case l of joinList1 f = proc (e,(l,s)) -> case l of
[] -> bottom -< () [] -> bottom -< ()
[x] -> f -< (e,(x,s)) [x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s))) (x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s)))
{-# INLINABLE joinList1 #-}
joinList1' :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (x,e) y -> c ([x],e) y joinList1' :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (x,e) y -> c ([x],e) y
joinList1' f = proc (l,e) -> case l of joinList1' f = proc (l,e) -> case l of
[] -> bottom -< () [] -> bottom -< ()
[x] -> f -< (x,e) [x] -> f -< (x,e)
(x:xs) -> (f -< (x,e)) <> (joinList1' f -< (xs,e)) (x:xs) -> (f -< (x,e)) <> (joinList1' f -< (xs,e))
{-# INLINABLE joinList1' #-}
...@@ -7,6 +7,7 @@ ...@@ -7,6 +7,7 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
module Control.Arrow.Transformer.Abstract.Environment where module Control.Arrow.Transformer.Abstract.Environment where
import Prelude hiding ((.),read,Maybe(..)) import Prelude hiding ((.),read,Maybe(..))
...@@ -26,6 +27,7 @@ import Control.Arrow.Closure as Cls ...@@ -26,6 +27,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Order import Control.Arrow.Order
import Data.Abstract.IntersectionSet (Set)
import Data.Abstract.Maybe import Data.Abstract.Maybe
import qualified Data.Abstract.StrongMap as SM import qualified Data.Abstract.StrongMap as SM
import qualified Data.Abstract.Environment.Flat as FM import qualified Data.Abstract.Environment.Flat as FM
...@@ -40,7 +42,7 @@ import Data.Coerce ...@@ -40,7 +42,7 @@ import Data.Coerce
import GHC.Exts import GHC.Exts
newtype EnvT env var val c x y = EnvT (ReaderT (env var val) c x y) newtype EnvT (env :: k1 -> k2 -> *) var val c x y = EnvT (ReaderT (env var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete z, deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete z,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun) ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun)
...@@ -66,7 +68,7 @@ instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => Ar ...@@ -66,7 +68,7 @@ instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => Ar
{-# INLINE lookup #-} {-# INLINE lookup #-}
{-# INLINE extend #-} {-# INLINE extend #-}
instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT FM.Env var val c) where instance (Identifiable var, Traversable val, Complete (val (Set var)), ArrowChoice c, Profunctor c) => ArrowEnv var (val (FM.Env var val)) (EnvT FM.Env var val c) where
type Join y (EnvT FM.Env var val c) = ArrowComplete y c type Join y (EnvT FM.Env var val c) = ArrowComplete y c
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< () env <- Reader.ask -< ()
...@@ -80,7 +82,7 @@ instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowC ...@@ -80,7 +82,7 @@ instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowC
{-# INLINE lookup #-} {-# INLINE lookup #-}
{-# INLINE extend #-} {-# INLINE extend #-}
instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT FM.Env var val c) where instance (Identifiable var, Traversable val, Complete (val (Set var)), ArrowChoice c, Profunctor c) => ArrowLetRec var (val (FM.Env var val)) (EnvT FM.Env var val c) where
letRec (EnvT f) = EnvT $ proc (ls,x) -> do letRec (EnvT f) = EnvT $ proc (ls,x) -> do
env <- Reader.ask -< () env <- Reader.ask -< ()
Reader.local f -< (FM.insertRec ls env,x) Reader.local f -< (FM.insertRec ls env,x)
......
...@@ -40,6 +40,7 @@ instance ArrowRun c => ArrowRun (FixT a b c) where ...@@ -40,6 +40,7 @@ instance ArrowRun c => ArrowRun (FixT a b c) where
type instance Fix (FixT _ _ c) x y = FixT x y c type instance Fix (FixT _ _ c) x y = FixT x y c
instance (Profunctor c,ArrowChoice c) => ArrowFix (FixT a b c a b) where instance (Profunctor c,ArrowChoice c) => ArrowFix (FixT a b c a b) where
fix f = iterationStrategy (f (fix f)) fix f = iterationStrategy (f (fix f))
{-# NOINLINE fix #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
app = FixT (app .# first coerce) app = FixT (app .# first coerce)
......
...@@ -115,10 +115,10 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx a (CacheT Cache a b ...@@ -115,10 +115,10 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx a (CacheT Cache a b
{-# INLINE localContext #-} {-# INLINE localContext #-}
{-# INLINE joinByContext #-} {-# INLINE joinByContext #-}
instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where instance (Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
reuse f = CacheT $ proc (a,s) -> do reuse s f = CacheT $ proc a -> do
Cache cache <- get -< () 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 returnA -< M.foldlWithKey' (\m a' (s',b') -> if s' s then f a a' s' b' m else m) mempty cache
{-# INLINE reuse #-} {-# INLINE reuse #-}
instance Identifiable a => IsList (Cache a b) where instance Identifiable a => IsList (Cache a b) where
...@@ -154,7 +154,7 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx (k,a) (CacheT (Grou ...@@ -154,7 +154,7 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx (k,a) (CacheT (Grou
{-# INLINE joinByContext #-} {-# 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 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)) reuse s f = proc (k,a0) -> withCache (reuse s (\a a' -> f (k,a) (k,a'))) -<< (k,a0)
{-# INLINE reuse #-} {-# 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 :: (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
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
...@@ -33,8 +33,6 @@ import Data.Order hiding (top) ...@@ -33,8 +33,6 @@ import Data.Order hiding (top)
import Data.Abstract.Widening (Widening) import Data.Abstract.Widening (Widening)
import Data.HashSet(HashSet) import Data.HashSet(HashSet)
import qualified Data.HashSet as H import qualified Data.HashSet as H
import Data.Abstract.Stable
import Data.Foldable
maxSize :: (ArrowChoice c, ArrowStack a c) => Int -> IterationStrategy c a b -> IterationStrategy c a b maxSize :: (ArrowChoice c, ArrowStack a c) => Int -> IterationStrategy c a b -> IterationStrategy c a b
maxSize limit strat f = proc a -> do maxSize limit strat f = proc a -> do
...@@ -65,14 +63,9 @@ instance IsEmpty (Stack a) where ...@@ -65,14 +63,9 @@ instance IsEmpty (Stack a) where
newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y) 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 a) deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin,ArrowComplete z,ArrowCache a b,ArrowState s,ArrowTrans,ArrowContext ctx a)
instance (PreOrd a, LowerBounded b, ArrowChoice c, ArrowReuse a b c, ArrowStack a (StackT stack a c)) => ArrowReuse a b (StackT stack a c) where instance (ArrowReuse a b c, ArrowStack a (StackT stack a c)) => ArrowReuse a b (StackT stack a c) where
reuse f = proc (a,s) -> case s of reuse s f = StackT $ reuse s f
Unstable -> do {-# INLINABLE reuse #-}
m0 <- StackT (reuse f) -< (a,Unstable)
stack <- Stack.elems -< ()
returnA -< foldl' (\m a' -> if a a' then m <> f a a' Unstable bottom else m) m0 stack
Stable ->
StackT (reuse f) -< (a,Stable)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a c) where instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a c) where
peek = lift $ proc (stack,()) -> returnA -< top stack peek = lift $ proc (stack,()) -> returnA -< top stack
...@@ -87,7 +80,7 @@ instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a ...@@ -87,7 +80,7 @@ instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a
{-# INLINE size #-} {-# INLINE size #-}
runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y
runStackT (StackT f) = lmap (\x -> (empty,x)) (runReaderT f) runStackT (StackT f) = lmap (empty,) (runReaderT f)
{-# INLINE runStackT #-} {-# INLINE runStackT #-}
instance (IsEmpty (stack a), ArrowRun c) => ArrowRun (StackT stack a c) where instance (IsEmpty (stack a), ArrowRun c) => ArrowRun (StackT stack a c) where
......
...@@ -15,7 +15,7 @@ import Control.Arrow ...@@ -15,7 +15,7 @@ import Control.Arrow
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Fix.Chaotic import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Reuse as Reuse import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Fix.Cache as Cache -- import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context as Context import Control.Arrow.Fix.Context as Context
import Control.Arrow.State import Control.Arrow.State
...@@ -34,6 +34,20 @@ trace showA showB f = proc x -> do ...@@ -34,6 +34,20 @@ trace showA showB f = proc x -> do
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y
{-# INLINE trace #-} {-# INLINE trace #-}
trace' :: (Eq a, ArrowApply c) => (a -> String) -> (b -> String) -> IterationStrategy c a b -> IterationStrategy c a b
trace' showA showB strat f = proc x -> do
y <- strat (proc x' -> f -< Debug.trace (if x == x'
then printf "CALL\n%s\n\n" (showA x)
else printf "CALL\n%s~>\n%s\n\n" (showA x) (showA x')) x') -<< x
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y
{-# INLINE trace' #-}
traceCache :: ArrowState cache c => (cache -> String) -> IterationStrategy c a b
traceCache showCache f = proc a -> do
cache <- get -< ()
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) -> IterationStrategy c a b traceCtx :: (ArrowContext ctx a' c,ArrowState cache c) => (a -> String) -> (b -> String) -> (ctx -> String) -> (cache -> String) -> IterationStrategy c a b
traceCtx showA showB showCtx showCache f = proc x -> do traceCtx showA showB showCtx showCache f = proc x -> do
ctx <- askContext -< () ctx <- askContext -< ()
...@@ -56,26 +70,26 @@ newtype TraceT c x y = TraceT (c x y) ...@@ -56,26 +70,26 @@ newtype TraceT c x y = TraceT (c x y)
-- m <- Reuse.reuse f -< (a,s) -- m <- Reuse.reuse f -< (a,s)
-- returnA -< Debug.trace (printf "REUSE\nx: %s\n%s\n\n" (show a) (show m)) m -- returnA -< Debug.trace (printf "REUSE\nx: %s\n%s\n\n" (show a) (show m)) m
instance (Show a, ArrowIterate a c) => ArrowIterate a (TraceT c) where -- instance (Show a, ArrowIterate a c) => ArrowIterate a (TraceT c) where
iterate = TraceT $ proc (a,b) -> -- iterate = TraceT $ proc (a,b) ->
iterate -< Debug.trace (printf "ITERATE\n\tx: %s\n\n" (show a)) (a,b) -- iterate -< Debug.trace (printf "ITERATE\n\tx: %s\n\n" (show a)) (a,b)
instance (Show a, Show b, ArrowCache a b c) => ArrowCache a b (TraceT c) where -- instance (Show a, Show b, ArrowCache a b c) => ArrowCache a b (TraceT c) where
lookup = TraceT $ proc a -> do -- lookup = TraceT $ proc a -> do
b <- lookup -< a -- b <- lookup -< a
returnA -< Debug.trace (printf "LOOKUP\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) b -- returnA -< b -- Debug.trace (printf "LOOKUP\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) b
update = TraceT $ proc (a,b) -> do -- update = TraceT $ proc (a,b) -> do
bOld <- lookup -< a -- bOld <- lookup -< a
(s,b') <- update -< (a,b) -- (s,b') <- update -< (a,b)
returnA -< Debug.trace (printf "UPDATE\n\tx: %s\n\ty: %s -> %s, %s\n\n" (show a) (show bOld) (show b') (show s)) (s,b') -- returnA -< Debug.trace (printf "UPDATE\n\tx: %s\n\ty: %s -> %s, %s\n\n" (show a) (show bOld) (show b') (show s)) (s,b')
write = TraceT $ proc (a,b,s) -> do -- write = TraceT $ proc (a,b,s) -> do
write -< Debug.trace (printf "WRITE\n\tx: %s\n\ty: %s\n\t%s\n\t\n\n" (show a) (show b) (show s)) (a,b,s) -- write -< (a,b,s) -- Debug.trace (printf "WRITE\n\tx: %s\n\ty: %s\n\t%s\n\t\n\n" (show a) (show b) (show s)) (a,b,s)
setStable = TraceT $ proc (s,a) -> -- setStable = TraceT $ proc (s,a) ->
setStable -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a) -- setStable -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a)
{-# INLINE lookup #-} -- {-# INLINE lookup #-}
{-# INLINE update #-} -- {-# INLINE update #-}
{-# INLINE write #-} -- {-# INLINE write #-}
{-# INLINE setStable #-} -- {-# INLINE setStable #-}
runTraceT :: TraceT c x y -> c x y runTraceT :: TraceT c x y -> c x y
runTraceT (TraceT f) = f runTraceT (TraceT f) = f
......
...@@ -68,9 +68,9 @@ instance (ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashM ...@@ -68,9 +68,9 @@ instance (ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashM
instance (Identifiable var, IsClosure val (HashMap var val), ArrowChoice c, Profunctor c) instance (Identifiable var, IsClosure val (HashMap var val), ArrowChoice c, Profunctor c)
=> ArrowLetRec var val (EnvT var val c) where => ArrowLetRec var val (EnvT var val c) where
letRec (EnvT f) = EnvT $ proc (ls,x) -> do letRec (EnvT f) = EnvT $ proc (bindings,x) -> do
env <- Reader.ask -< () env <- Reader.ask -< ()
let env' = foldr (\(var,val) -> M.insert var (setEnvironment env' val)) env ls let env' = foldr (\(var,val) -> M.insert var (setEnvironment env' val)) env bindings
Reader.local f -< (env',x) Reader.local f -< (env',x)
instance (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where instance (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where
......
...@@ -34,7 +34,7 @@ import Data.Coerce ...@@ -34,7 +34,7 @@ import Data.Coerce
-- | Passes along constant data. -- | Passes along constant data.
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y) newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin, deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,
ArrowState s,ArrowReader r',ArrowWriter w, ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val, ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,ArrowContext ctx a) ArrowFail e, ArrowExcept e,ArrowContext ctx a)
......
...@@ -50,7 +50,7 @@ instance (Identifiable var, ArrowEnv var val c, Profunctor c) => ArrowEnv var va ...@@ -50,7 +50,7 @@ instance (Identifiable var, ArrowEnv var val c, Profunctor c) => ArrowEnv var va
lookup (FreeVarsT f) (FreeVarsT g) = FreeVarsT $ proc (var,x) -> do lookup (FreeVarsT f) (FreeVarsT g) = FreeVarsT $ proc (var,x) -> do
tell -< H.singleton var tell -< H.singleton var
Env.lookup f g -< (var,x) Env.lookup f g -< (var,x)
extend (FreeVarsT f) = FreeVarsT $ proc (var,val,x) -> do extend (FreeVarsT f) = FreeVarsT $ proc (var,val,x) ->
censor (\(var,_,_) -> H.delete var) (Env.extend f) -< (var,val,x) censor (\(var,_,_) -> H.delete var) (Env.extend f) -< (var,val,x)
instance (Identifiable var,ArrowApply c, Profunctor c) => ArrowApply (FreeVarsT var c) where instance (Identifiable var,ArrowApply c, Profunctor c) => ArrowApply (FreeVarsT var c) where
......
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.NoInline where
import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Order
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
import Control.Arrow.Trans
import Control.Arrow.Writer
import Data.Profunctor
import Data.Profunctor.Unsafe
import Unsafe.Coerce
newtype NoInlineT c x y = NoInlineT { runNoInlineTT :: c x y }
instance ArrowRun c => ArrowRun (NoInlineT c) where type Run (NoInlineT c) x y = Run c x y
instance ArrowTrans (NoInlineT c) where type Underlying (NoInlineT c) x y = c x y
instance Profunctor c => Profunctor (NoInlineT c) where
dimap f g h = lift $ dimap f g (unlift h)
lmap f h = lift $ lmap f (unlift h)
rmap g h = lift $ rmap g (unlift h)
f .# _ = f `seq` unsafeCoerce f
_ #. g = g `seq` unsafeCoerce g
{-# NOINLINE dimap #-}
{-# NOINLINE lmap #-}
{-# NOINLINE rmap #-}
{-# NOINLINE (.#) #-}
{-# NOINLINE (#.) #-}
-- instance ArrowLift NoInlineT where
-- lift' = lift
-- {-# NOINLINE lift' #-}
instance Category c => Category (NoInlineT c) where
id = lift id
f . g = lift (unlift f . unlift g)
{-# NOINLINE id #-}
{-# NOINLINE (.) #-}
instance Arrow c => Arrow (NoInlineT c) where
arr f = lift (arr f)
first f = lift $ first (unlift f)
second f = lift $ second (unlift f)
f &&& g = lift $ unlift f &&& unlift g
f *** g = lift $ unlift f *** unlift g
{-# NOINLINE arr #-}
{-# NOINLINE first #-}
{-# NOINLINE second #-}
{-# NOINLINE (&&&) #-}
{-# NOINLINE (***) #-}
instance (ArrowChoice c) => ArrowChoice (NoInlineT c) where
left f = lift $ left (unlift f)
right f = lift $ right (unlift f)
f +++ g = lift $ unlift f +++ unlift g
f ||| g = lift $ unlift f ||| unlift g
{-# NOINLINE left #-}
{-# NOINLINE right #-}
{-# NOINLINE (+++) #-}
{-# NOINLINE (|||) #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (NoInlineT c) where
app = lift $ lmap (\(f,b) -> (unlift f,b)) app
{-# NOINLINE app #-}
instance ArrowReader r c => ArrowReader r (NoInlineT c) where
ask = lift ask
local f = lift $ local (unlift f)
{-# NOINLINE ask #-}
{-# NOINLINE local #-}
instance ArrowState s c => ArrowState s (NoInlineT c) where
get = lift State.get
put = lift State.put
modify f = lift (State.modify (unlift f))
{-# NOINLINE get #-}
{-# NOINLINE put #-}
{-# NOINLINE modify #-}
instance ArrowWriter w c => ArrowWriter w (NoInlineT c) where
tell = lift tell
{-# NOINLINE tell #-}
instance ArrowFail e c => ArrowFail e (NoInlineT c) where
fail = lift fail
{-# NOINLINE fail #-}
instance ArrowEnv var val c => ArrowEnv var val (NoInlineT c) where
type Join y (NoInlineT c) = Env.Join y c
lookup f g = lift (Env.lookup (unlift f) (unlift g))
extend f = lift (Env.extend (unlift f))
{-# NOINLINE lookup #-}
{-# NOINLINE extend #-}
instance ArrowLetRec var val c => ArrowLetRec var val (NoInlineT c) where
letRec f = lift (letRec (unlift f))
{-# NOINLINE letRec #-}
instance ArrowClosure expr cls c => ArrowClosure expr cls (NoInlineT c) where
type Join y (NoInlineT c) = Cls.Join y c
closure = lift Cls.closure
apply f = lift $ Cls.apply (unlift f)
{-# NOINLINE closure #-}
{-# NOINLINE apply #-}
instance ArrowStore var val c => ArrowStore var val (NoInlineT c) where
type Join y (NoInlineT c) = Store.Join y c
read f g = lift $ Store.read (unlift f) (unlift g)
write = lift Store.write
{-# NOINLINE read #-}
{-# NOINLINE write #-}
type instance Fix (NoInlineT c) x y = NoInlineT (Fix c x y)
instance ArrowFix (Underlying (NoInlineT c) x y) => ArrowFix (NoInlineT c x y)
instance ArrowExcept e c => ArrowExcept e (NoInlineT c) where
type Join z (NoInlineT c) = Exc.Join z c
throw = lift throw
try f g h = lift $ try (unlift f) (unlift g) (unlift h)
{-# NOINLINE throw #-}
{-# NOINLINE try #-}
instance ArrowLowerBounded c => ArrowLowerBounded (NoInlineT c) where
bottom = lift bottom
{-# NOINLINE bottom #-}
instance ArrowJoin c => ArrowJoin (NoInlineT c) where
joinSecond lub f g = lift $ joinSecond lub f (unlift g)
{-# NOINLINE joinSecond #-}
instance ArrowComplete y c => ArrowComplete y (NoInlineT c) where
f <> g = lift $ unlift f <> unlift g
{-# NOINLINE (<⊔>) #-}
instance ArrowConst x c => ArrowConst x (NoInlineT c) where
askConst f = lift (askConst (unlift . f))
{-# NOINLINE askConst #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (NoInlineT c)
instance ArrowReuse a b c => ArrowReuse a b (NoInlineT c) where
reuse s f = lift $ reuse s f
{-# NOINLINE reuse #-}
instance ArrowContext ctx a c => ArrowContext ctx a (NoInlineT c) where
type Widening (NoInlineT c) a = Widening c a
askContext = Context.askContext
localContext f = lift (localContext (unlift f))
joinByContext widen = lift $ joinByContext widen
{-# NOINLINE askContext #-}
{-# NOINLINE localContext #-}
{-# NOINLINE joinByContext #-}
instance ArrowCache a b c => ArrowCache a b (NoInlineT c) where
lookup = lift Cache.lookup
write = lift Cache.write
update = lift Cache.update
setStable = lift Cache.setStable
{-# NOINLINE lookup #-}
{-# NOINLINE write #-}
{-# NOINLINE update #-}
{-# NOINLINE setStable #-}
...@@ -157,7 +157,7 @@ instance ArrowConst x c => ArrowConst x (ReaderT r c) where ...@@ -157,7 +157,7 @@ instance ArrowConst x c => ArrowConst x (ReaderT r c) where
instance ArrowEffectCommutative c => ArrowEffectCommutative (ReaderT r c) instance ArrowEffectCommutative c => ArrowEffectCommutative (ReaderT r c)