update stratego

lib/src/Control/Arrow/Fix/Reuse.hs

@@ -18,6 +18,7 @@ import Control.Arrow.Fix.Cache
 
 import Data.Abstract.Stable
 
+import Data.Order
 import Data.Metric
 import Data.Profunctor
 import Data.Monoid (First(..))
@@ -27,11 +28,15 @@ import Text.Printf
 class (Arrow c, Profunctor c) => ArrowReuse a b c where
 
   -- | 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 st f = proc a -> do
-  m <- reuse (\_ a' s' b' -> First (Just (a',b',s'))) -< (a,st)
+reuseFirst :: (PreOrd a, ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b
+reuseFirst s f = proc a -> do
+  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
     Just (_,b,Stable) -> returnA -< b
     Just (a',_,Unstable) -> f -< a'
@@ -46,17 +51,20 @@ reuseExact f = proc a -> do
     _ -> f -< a
 {-# 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
 {-# 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
 {-# INLINE reuseStableByMetric #-}
 
-reuseByMetric_ :: (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)
+reuseByMetric_ :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
+reuseByMetric_ metric s f = proc a -> do
+  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
     Just Measured { stable = Stable, output = b } -> returnA -< b
     Just Measured { stable = Unstable, input = a' } -> f -< a'

lib/src/Control/Arrow/Order.hs

@@ -52,16 +52,19 @@ joinList empty f = proc (e,(l,s)) -> case l of
   []     -> empty -< (e,s)
   [x]    -> f -< (e,(x,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 f = proc (e,(l,s)) -> case l of
   []     -> bottom -< ()
   [x]    -> f -< (e,(x,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' f = proc (l,e) -> case l of
   []     -> bottom -< ()
   [x]    -> f -< (x,e)
   (x:xs) -> (f -< (x,e)) <⊔> (joinList1' f -< (xs,e))
+{-# INLINABLE joinList1' #-}
 

lib/src/Control/Arrow/Transformer/Abstract/Environment.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
 module Control.Arrow.Transformer.Abstract.Environment where
 
 import Prelude hiding ((.),read,Maybe(..))
@@ -26,6 +27,7 @@ import Control.Arrow.Closure as Cls
 import Control.Arrow.Fix
 import Control.Arrow.Order
 
+import Data.Abstract.IntersectionSet (Set)
 import Data.Abstract.Maybe
 import qualified Data.Abstract.StrongMap as SM
 import qualified Data.Abstract.Environment.Flat as FM
@@ -40,7 +42,7 @@ import Data.Coerce
 
 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,
             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
   {-# INLINE lookup #-}
   {-# 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
   lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
     env <- Reader.ask -< ()
@@ -80,7 +82,7 @@ instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowC
   {-# INLINE lookup #-}
   {-# 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
     env <- Reader.ask -< ()
     Reader.local f -< (FM.insertRec ls env,x)

lib/src/Control/Arrow/Transformer/Abstract/Fix.hs

@@ -40,6 +40,7 @@ instance ArrowRun c => ArrowRun (FixT a b c) where
 type instance Fix (FixT _ _ c) x y = FixT x y c
 instance (Profunctor c,ArrowChoice c) => ArrowFix (FixT a b c a b) where
   fix f = iterationStrategy (f (fix f))
+  {-# NOINLINE fix #-}
 
 instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
   app = FixT (app .# first coerce)

lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache.hs

@@ -115,10 +115,10 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx a (CacheT Cache a b
   {-# 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
+instance (Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
+  reuse s f = CacheT $ proc a -> 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
+    returnA -< M.foldlWithKey' (\m a' (s',b') -> if s' ⊑ s then f a a' s' b' m else m) mempty cache
   {-# INLINE reuse #-}
 
 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
   {-# 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))
+  reuse s f = proc (k,a0) -> withCache (reuse s (\a a' -> f (k,a) (k,a'))) -<< (k,a0)
   {-# 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

lib/src/Control/Arrow/Transformer/Abstract/Fix/Stack.hs

-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -33,8 +33,6 @@ import Data.Order hiding (top)
 import Data.Abstract.Widening (Widening)
 import Data.HashSet(HashSet)
 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 limit strat f = proc a -> do
@@ -65,14 +63,9 @@ instance IsEmpty (Stack a) where
 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)
 
-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
-  reuse f = proc (a,s) -> case s of
-    Unstable -> do
-      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 (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
+  {-# INLINABLE reuse #-}
 
 instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a c) where
   peek = lift $ proc (stack,()) -> returnA -< top stack
@@ -87,7 +80,7 @@ instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a
   {-# INLINE size #-}
 
 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 #-}
 
 instance (IsEmpty (stack a), ArrowRun c) => ArrowRun (StackT stack a c) where

lib/src/Control/Arrow/Transformer/Abstract/Fix/Trace.hs

@@ -15,7 +15,7 @@ import Control.Arrow
 import Control.Arrow.Fix
 import Control.Arrow.Fix.Chaotic
 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.Context as Context
 import Control.Arrow.State
@@ -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
 {-# 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 showA showB showCtx showCache f = proc x -> do
   ctx <- askContext -< ()
@@ -56,26 +70,26 @@ newtype TraceT c x y = TraceT (c x y)
 --     m <- Reuse.reuse f -< (a,s)
 --     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
-  iterate = TraceT $ proc (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
-  lookup = TraceT $ proc a -> do
-    b  <- lookup -< a
-    returnA -< Debug.trace (printf "LOOKUP\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) b
-  update = TraceT $ proc (a,b) -> do
-    bOld  <- lookup -< a
-    (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')
-  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)
-  setStable = TraceT $ proc (s,a) ->
-    setStable -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a)
-  {-# INLINE lookup #-}
-  {-# INLINE update #-}
-  {-# INLINE write #-}
-  {-# INLINE setStable #-}
+-- instance (Show a, ArrowIterate a c) => ArrowIterate a (TraceT c) where
+--   iterate = TraceT $ proc (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
+--   lookup = TraceT $ proc a -> do
+--     b  <- lookup -< a
+--     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
+--     bOld  <- lookup -< a
+--     (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')
+--   write = TraceT $ proc (a,b,s) -> do
+--     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 -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a)
+--   {-# INLINE lookup #-}
+--   {-# INLINE update #-}
+--   {-# INLINE write #-}
+--   {-# INLINE setStable #-}
 
 runTraceT :: TraceT c x y -> c x y
 runTraceT (TraceT f) = f

lib/src/Control/Arrow/Transformer/Concrete/Environment.hs

@@ -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)
   => 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 -< ()
-    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)
 
 instance (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where

lib/src/Control/Arrow/Transformer/Const.hs

@@ -34,7 +34,7 @@ import Data.Coerce
 -- | Passes along constant data.
 newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
   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,
             ArrowFail e, ArrowExcept e,ArrowContext ctx a)
 

lib/src/Control/Arrow/Transformer/FreeVars.hs

@@ -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
     tell -< H.singleton var
     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)
 
 instance (Identifiable var,ArrowApply c, Profunctor c) => ArrowApply (FreeVarsT var c) where

lib/src/Control/Arrow/Transformer/NoInline.hs

+{-# 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 #-}

lib/src/Control/Arrow/Transformer/Reader.hs

@@ -157,7 +157,7 @@ instance ArrowConst x c => ArrowConst x (ReaderT r c) where
 instance ArrowEffectCommutative c => ArrowEffectCommutative (ReaderT r c)
 
 instance ArrowReuse a b c => ArrowReuse a b (ReaderT r c) where
-  reuse f = lift' $ reuse f
+  reuse s f = lift' $ reuse s f
   {-# INLINE reuse #-}
 
 instance ArrowContext ctx a c => ArrowContext ctx a (ReaderT r c) where

lib/src/Control/Arrow/Transformer/Static.hs

@@ -135,6 +135,11 @@ instance (Applicative f, ArrowClosure expr cls c) => ArrowClosure expr cls (Stat
   {-# INLINE apply #-}
   {-# SPECIALIZE instance ArrowClosure expr cls c => ArrowClosure expr cls (StaticT ((->) r) c) #-}
 
+instance (Applicative f, ArrowLetRec var val c) => ArrowLetRec var val (StaticT f c) where
+  letRec (StaticT f) = StaticT $ Env.letRec <$> f
+  {-# INLINE letRec #-}
+  {-# SPECIALIZE instance ArrowLetRec var val c => ArrowLetRec var val (StaticT ((->) r) c) #-}
+
 instance (Applicative f, ArrowStore var val c) => ArrowStore var val (StaticT f c) where
   type Join y (StaticT f c) = Store.Join y c
   read (StaticT f) (StaticT g) = StaticT $ Store.read <$> f <*> g

lib/src/Control/Arrow/Transformer/Writer.hs

@@ -184,7 +184,7 @@ instance (Monoid w, ArrowStack a c) => ArrowStack a (WriterT w c) where
   {-# INLINE size #-}
 
 instance (Monoid w, ArrowReuse a b c) => ArrowReuse a b (WriterT w c) where
-  reuse f = lift' (Reuse.reuse f)
+  reuse s f = lift' (Reuse.reuse s f)
   {-# INLINE reuse #-}
 
 instance (Monoid w, ArrowContext ctx a c) => ArrowContext ctx a (WriterT w c) where

lib/src/Data/Abstract/Closure.hs

@@ -26,15 +26,19 @@ newtype Closure expr env = Closure (HashMap expr env)
 instance (Identifiable expr, PreOrd env) => PreOrd (Closure expr env) where
   (⊑) = withCls $ \m1 m2 -> M.keysSet m1 ⊑ M.keysSet m2
                          && and (M.intersectionWith (⊑) m1 m2)
+  {-# INLINE (⊑) #-}
 
 instance (Identifiable expr, Complete env) => Complete (Closure expr env) where
   (⊔) = withCls $ M.unionWith (⊔)
+  {-# INLINE (⊔) #-}
 
 instance Foldable (Closure expr) where
   foldMap = foldMapDefault
+  {-# INLINE foldMap #-}
 
 instance Traversable (Closure expr) where
   traverse f (Closure m) = Closure <$> traverse f m
+  {-# INLINE traverse #-}
 
 instance (Show a,Show b) => Show (Closure a b) where
   show (Closure h)
@@ -48,15 +52,18 @@ instance (Identifiable expr, Complete env) => IsList (Closure expr env) where
 
 closure :: Identifiable expr => expr -> env -> Closure expr env
 closure expr env = Closure $ M.singleton expr env
+{-# INLINE closure #-}
 
 apply :: (O.ArrowComplete y c, O.ArrowLowerBounded c, ArrowChoice c)
       => c ((expr,env),x) y -> c (Closure expr env,x) y
 apply f = lmap (first (\(Closure m) -> M.toList m)) (O.joinList1' f)
+{-# INLINE apply #-}
 
 widening :: Identifiable expr => Widening env -> Widening (Closure expr env)
 widening w = withCls $ \m1 m2 ->
   (fold $ M.intersectionWith (\x y -> fst (w x y)) m1 m2,
    M.unionWith (\x y -> snd (w x y)) m1 m2)
+{-# INLINE widening #-}
 
 withCls :: Coercible x x' => (HashMap expr env -> x') -> (Closure expr env -> x)
 withCls = coerce

lib/src/Data/Abstract/Constructor.hs

@@ -33,13 +33,10 @@ instance PreOrd n => PreOrd (Constr n) where
 instance Complete n => Complete (Constr n) where
   Constr m1 ⊔ Constr m2 = Constr (M.unionWith (IM.unionWith (zipWith (⊔))) m1 m2)
 
-widening :: (Identifiable n,Complete n) => Widening n -> Widening (Constr n)
+widening :: (Complete n) => Widening n -> Widening (Constr n)
 widening w c1@(Constr m1) c2@(Constr m2) =
-  ( if size c1 < size c2 then Unstable else fst (sequenceA (M.intersectionWith (sequenceA <.> IM.intersectionWith (sequenceA <.> zipWith w)) m1 m2))
-  , c1 ⊔ c2)
-  where
-    (<.>) = (.) . (.)
-    infixr 9 <.>
+  let c3 = Constr (M.unionWith (IM.unionWith (zipWith (\x y -> snd (w x y)))) m1 m2)
+  in (if c3 ⊑ c1 && c3 ⊑ c2 then Stable else Unstable, c3)
 
 instance PreOrd n => LowerBounded (Constr n) where
   bottom = Constr M.empty
@@ -59,10 +56,10 @@ isEmpty :: Constr n -> Bool
 isEmpty (Constr n) = M.null n
 
 isSingleton :: (n -> Bool) -> Constr n -> Bool
-isSingleton isSing (Constr n) = M.size n == 1 && forAll n (\a -> IM.size a == 1 && forAll a (\l -> all isSing l))
+isSingleton isSing (Constr n) = M.size n == 1 && forAll n (\a -> IM.size a == 1 && forAll a (all isSing))
 
-size :: (Identifiable n, Complete n) => Constr n -> Int
-size c = length (toList c)
+-- size :: (Identifiable n, Complete n) => Constr n -> Int
+-- size c = length (toList c)
 
 removeEmpty :: Constr n -> Constr n
 removeEmpty (Constr m) = Constr (M.mapMaybe (\a -> if IM.null a then Nothing else Just a) m)

lib/src/Data/Abstract/DiscretePowerset.hs

@@ -87,6 +87,7 @@ widening (Pow xs) (Pow ys) = let zs = H.union xs ys in (if H.size zs == H.size x
 widening Top (Pow _) = (Unstable,Top)
 widening (Pow _) Top = (Unstable,Top)
 widening Top Top = (Stable,Top)
+{-# INLINABLE widening #-}
 
 instance Identifiable x => Complete (FreeCompletion (Pow x)) where
   F.Top ⊔ _ = F.Top

lib/src/Data/Abstract/Environment/Flat.hs

@@ -21,14 +21,12 @@ module Data.Abstract.Environment.Flat
 
 import           Prelude hiding (lookup)
 
-import           Control.Arrow.Closure
-
-import           Data.Abstract.IntersectionSet (Set)
-import qualified Data.Abstract.IntersectionSet as H
 import qualified Data.Abstract.Maybe as A