Commit 4fe6f30f authored by Sven Keidel's avatar Sven Keidel

improve performance of arrow transformers

parent 277199d3
Pipeline #14169 passed with stages
in 20 minutes and 29 seconds
......@@ -5,7 +5,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
-- {-# OPTIONS_GHC -ddump-rule-firings #-}
{-# OPTIONS_GHC -funfolding-use-threshold=1500 #-}
module Main where
import Prelude hiding (id,(.))
......@@ -14,13 +14,20 @@ import Criterion
import Criterion.Main
import Data.Profunctor
import Control.DeepSeq
import Data.Abstract.Error
import Data.Abstract.Except
import Data.Abstract.Cache
import Control.DeepSeq
import Control.Arrow
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Writer
import Control.Arrow.Transformer.Abstract.Error
import Control.Arrow.Transformer.Abstract.Except
import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
data Expr = Num Int | Add Expr Expr | Mul Expr Expr
data Val = Val !Int
......@@ -49,6 +56,36 @@ eval = proc e -> case e of
Val n2 <- eval -< e2
returnA -< Val (n1 * n2)
{-# SPECIALIZE eval :: ConstT () (->) Expr Val #-}
{-# SPECIALIZE eval :: ConstT () (ConstT () (->)) Expr Val #-}
{-# SPECIALIZE eval :: ConstT () (ConstT () (ConstT () (->))) Expr Val #-}
{-# SPECIALIZE eval :: ReaderT () (->) Expr Val #-}
{-# SPECIALIZE eval :: ReaderT () (ReaderT () (->)) Expr Val #-}
{-# SPECIALIZE eval :: ReaderT () (ReaderT () (ReaderT () (->))) Expr Val #-}
{-# SPECIALIZE eval :: StateT () (->) Expr Val #-}
{-# SPECIALIZE eval :: StateT () (StateT () (->)) Expr Val #-}
{-# SPECIALIZE eval :: StateT () (StateT () (StateT () (->))) Expr Val #-}
{-# SPECIALIZE eval :: WriterT () (->) Expr Val #-}
{-# SPECIALIZE eval :: WriterT () (WriterT () (->)) Expr Val #-}
{-# SPECIALIZE eval :: WriterT () (WriterT () (WriterT () (->))) Expr Val #-}
{-# SPECIALIZE eval :: ErrorT () (->) Expr Val #-}
{-# SPECIALIZE eval :: ErrorT () (ErrorT () (->)) Expr Val #-}
{-# SPECIALIZE eval :: ErrorT () (ErrorT () (ErrorT () (->))) Expr Val #-}
{-# SPECIALIZE eval :: ExceptT () (->) Expr Val #-}
{-# SPECIALIZE eval :: ExceptT () (ExceptT () (->)) Expr Val #-}
{-# SPECIALIZE eval :: ExceptT () (ExceptT () (ExceptT () (->))) Expr Val #-}
{-# SPECIALIZE eval :: TerminatingT (->) Expr Val #-}
{-# SPECIALIZE eval :: TerminatingT (TerminatingT (->)) Expr Val #-}
{-# SPECIALIZE eval :: TerminatingT (TerminatingT (TerminatingT (->))) Expr Val #-}
{-# SPECIALIZE eval :: ConstT () (ReaderT () (StateT () (ExceptT () (ErrorT () (TerminatingT (->)))))) Expr Val #-}
addN :: Int -> Expr -> Expr
addN 0 e = e
addN n e = Add (addN (n-1) e) (addN (n-1) e)
......@@ -62,35 +99,51 @@ main = do
bench "eval (->)" $ nf eval expr
],
bgroup "ConstT" [
bgroup "eval" [
bench "ConstT¹" $ nf (runConstT () eval) expr,
bench "ConstT²" $ nf (runConstT () (runConstT () eval)) expr,
bench "ConstT³" $ nf (runConstT () (runConstT () (runConstT () eval))) expr
]
bench "ConstT¹" $ nf (runConstT () eval) expr,
bench "ConstT²" $ nf (runConstT () (runConstT () eval)) expr,
bench "ConstT³" $ nf (runConstT () (runConstT () (runConstT () eval))) expr
],
bgroup "ReaderT" [
bgroup "eval" [
bench "ReaderT¹" $ nf (runReaderT' eval) expr,
bench "ReaderT²" $ nf (runReaderT' (runReaderT' eval)) expr,
bench "ReaderT³" $ nf (runReaderT' (runReaderT' (runReaderT' eval))) expr
]
bench "ReaderT¹" $ nf (runReaderT' eval) expr,
bench "ReaderT²" $ nf (runReaderT' (runReaderT' eval)) expr,
bench "ReaderT³" $ nf (runReaderT' (runReaderT' (runReaderT' eval))) expr
],
bgroup "StateT" [
bgroup "eval" [
bench "StateT¹" $ whnf (runStateT' eval) expr,
bench "StateT²" $ whnf (runStateT' (runStateT' eval)) expr,
bench "StateT³" $ whnf (runStateT' (runStateT' (runStateT' eval))) expr
]
bench "StateT¹" $ whnf (runStateT' eval) expr,
bench "StateT²" $ whnf (runStateT' (runStateT' eval)) expr,
bench "StateT³" $ whnf (runStateT' (runStateT' (runStateT' eval))) expr
],
bgroup "WriterT" [
bgroup "eval" [
bench "WriterT¹" $ nf (runWriterT' eval) expr,
bench "WriterT²" $ nf (runWriterT' (runWriterT' eval)) expr,
bench "WriterT³" $ nf (runWriterT' (runWriterT' (runWriterT' eval))) expr
]
bench "WriterT¹" $ nf (runWriterT' eval) expr,
bench "WriterT²" $ nf (runWriterT' (runWriterT' eval)) expr,
bench "WriterT³" $ nf (runWriterT' (runWriterT' (runWriterT' eval))) expr
],
bgroup "ErrorT" [
bench "ErrorT¹" $ nf (runErrorT' eval) expr,
bench "ErrorT²" $ nf (runErrorT' (runErrorT' eval)) expr,
bench "ErrorT³" $ nf (runErrorT' (runErrorT' (runErrorT' eval))) expr
],
bgroup "ExceptT" [
bench "ExceptT¹" $ nf (runExceptT' eval) expr,
bench "ExceptT²" $ nf (runExceptT' (runExceptT' eval)) expr,
bench "ExceptT³" $ nf (runExceptT' (runExceptT' (runExceptT' eval))) expr
],
bgroup "TerminatingT" [
bench "TerminatingT¹" $ nf (runTerminatingT eval) expr,
bench "TerminatingT²" $ nf (runTerminatingT (runTerminatingT eval)) expr,
bench "TerminatingT³" $ nf (runTerminatingT (runTerminatingT (runTerminatingT eval))) expr
],
bgroup "Stack" [
bench "ConstT (ReaderT (StateT (ExceptT (ErrorT (TerminatingT (->))))))" $
nf (runTerminatingT (runErrorT' (runExceptT' (runStateT' (runReaderT' (runConstT' eval)))))) expr
]
]
where
runConstT' :: Profunctor c => ConstT () c x y -> c x y
runConstT' f = runConstT () f
{-# INLINE runConstT' #-}
runReaderT' :: Profunctor c => ReaderT () c x y -> c x y
runReaderT' f = lmap (\x -> ((),x)) (runReaderT f)
{-# INLINE runReaderT' #-}
......@@ -101,6 +154,18 @@ main = do
runWriterT' :: Profunctor c => WriterT () c x y -> c x y
runWriterT' f = rmap snd (runWriterT f)
{-# INLINE runWriterT' #-}
runErrorT' :: Profunctor c => ErrorT () c x y -> c x (Error () y)
runErrorT' = runErrorT
{-# INLINE runErrorT' #-}
runExceptT' :: Profunctor c => ExceptT () c x y -> c x (Except () y)
runExceptT' = runExceptT
{-# INLINE runExceptT' #-}
runChaoticT'' :: Profunctor c => ChaoticT Cache () () c x y -> c x y
runChaoticT'' = runChaoticT'
{-# INLINE runChaoticT'' #-}
expr = addN 20 (Num 1)
......
......@@ -22,9 +22,6 @@ library:
ghc-options: -Wall
source-dirs:
- src
when:
- condition: flag(trace)
cpp-options: -DTRACE
tests:
spec:
......@@ -44,3 +41,5 @@ benchmarks:
dependencies:
- sturdy-lib
- criterion
- dump-core
ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -O2
......@@ -5,10 +5,10 @@ import Control.Arrow
import Control.Monad (join)
import Data.Profunctor
class (Functor f, Arrow c, Profunctor c, Arrow d, Profunctor d) => ArrowFunctor f c d where
mapA :: c x y -> d (f x) (f y)
class (Functor f, Arrow c, Profunctor c) => ArrowFunctor f c where
mapA :: c x y -> c (f x) (f y)
class (Monad f, ArrowFunctor f c c) => ArrowMonad f c where
class (Monad f, ArrowFunctor f c) => ArrowMonad f c where
unitA :: c x (f x)
unitA = arr return
......
......@@ -36,13 +36,11 @@ class (Arrow c, Profunctor c) => ArrowEffectCommutative c
instance ArrowEffectCommutative (->)
class (Arrow c, Profunctor c) => ArrowJoin c where
join :: (y -> y -> y) -> c x y -> c x y -> c x y
joinSecond :: c x y -> c (z,x) (z,y)
instance ArrowJoin (->) where
join lub f g = \x -> f x `lub` g x
join' :: (ArrowJoin c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
join' lub f g = join lub (lmap fst f) (lmap snd g)
joinSecond g = \(z,x) -> (z,g x)
{-# INLINE joinSecond #-}
-- | Joins a list of arguments. Use it with idiom brackets:
-- @
......
......@@ -32,7 +32,7 @@ import Data.Coerce
-- | Allows to describe computations over non-completely ordered types.
-- E.g. allows to join a computation of type 'c x [y]'.
newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e, ArrowExcept e)
......@@ -48,9 +48,3 @@ deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (Complet
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
bottom = lift $ bottom
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where
join lub f g = lift $ join joinVal (unlift f) (unlift g)
where joinVal (Lower x) (Lower y) = Lower (lub x y)
joinVal Top _ = Top
joinVal _ Top = Top
......@@ -25,15 +25,13 @@ import Control.Arrow.Transformer.Kleisli
import Control.Category
import Data.Abstract.Error
import Data.Abstract.Widening (toJoin2)
import qualified Data.Order as O
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowExcept e')
......@@ -54,8 +52,5 @@ deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (ErrorT e c) where
bottom = lift bottom
instance (O.Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ErrorT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
deriving instance (ArrowChoice c, ArrowComplete (Error e y) c) => ArrowComplete y (ErrorT e c)
......@@ -10,31 +10,29 @@ module Control.Arrow.Transformer.Abstract.Except(ExceptT,runExceptT) where
import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow
import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Trans
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Trans
import Control.Arrow.Transformer.Kleisli
import Control.Category
import Data.Abstract.Except
import Data.Abstract.Widening (toJoin2)
import Data.Order(Complete)
import qualified Data.Order as O
import Data.Order(Complete(..))
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Except e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e')
......@@ -52,16 +50,16 @@ instance (Complete e, ArrowChoice c, ArrowJoin c) => ArrowExcept e (ExceptT e c)
Success y -> unlift g -< y
Fail er -> unlift h -< (x,er)
SuccessOrFail er y -> (unlift g -< y) <> (unlift h -< (x,er))
{-# INLINE throw #-}
{-# INLINE try #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where
app = lift (app .# first coerce)
{-# INLINE app #-}
type instance Fix x y (ExceptT e c) = ExceptT e (Fix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c)
deriving instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c)
instance (Complete e, ArrowChoice c, ArrowJoin c) => ArrowJoin (ExceptT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
deriving instance (Complete e, ArrowChoice c, ArrowJoin c, ArrowComplete (Except e y) c) => ArrowComplete y (ExceptT e c)
......@@ -25,7 +25,6 @@ import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli
import Data.Abstract.Failure
import Data.Abstract.Widening (toJoin)
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
......@@ -33,7 +32,7 @@ import Data.Coerce
-- | Describes computations that can fail.
newtype FailureT e c x y = FailureT (KleisliT (Failure e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowExcept e')
......@@ -51,6 +50,3 @@ instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FailureT e c
type instance Fix x y (FailureT e c) = FailureT e (Fix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) =>
ArrowFix x y (FailureT e c)
instance (ArrowChoice c,ArrowJoin c) => ArrowJoin (FailureT e c) where
join lub f g = lift $ join (toJoin widening lub) (unlift f) (unlift g)
......@@ -30,10 +30,6 @@ import Data.Coerce
newtype FixT a b c x y = FixT { unFixT :: ConstT (IterationStrategy c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin)
-- runFixT :: (Identifiable a, PreOrd b, Profunctor c, ArrowRun t)
-- => IterationStrategy (t c) a b -> FixT a b (t c) x y -> c x y
-- runFixT iterationStrat f = run (runFixT' iterationStrat f)
runFixT :: (Identifiable a, PreOrd b)
=> IterationStrategy c a b -> FixT a b c x y -> c x y
runFixT iterationStrat (FixT f) = runConstT iterationStrat f
......@@ -50,12 +46,16 @@ instance (Profunctor c,ArrowChoice c,ArrowApply c) => ArrowFix a b (FixT a b c)
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
app = FixT (app .# first coerce)
{-# INLINE app #-}
instance ArrowLift (FixT a b) where
lift' = FixT . lift'
{-# INLINE lift' #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (FixT a b c)
----- Helper functions -----
iterationStrategy :: FixT a b c a b -> FixT a b c a b
iterationStrategy (FixT (ConstT (StaticT f))) = FixT $ ConstT $ StaticT $ \strat -> strat (f strat)
{-# INLINE iterationStrategy #-}
......@@ -42,9 +42,11 @@ newtype ChaoticT cache a b c x y =
runChaoticT :: (IsCache cache a b, Profunctor c) => ChaoticT cache a b c x y -> c x (cache a b,y)
runChaoticT (ChaoticT f) = dimap (\a -> (empty,(empty,a))) (second snd) (runReaderT (runStateT (runWriterT f)))
{-# INLINE runChaoticT #-}
runChaoticT' :: (IsCache cache a b, Profunctor c) => ChaoticT cache a b c x y -> c x y
runChaoticT' f = rmap snd (runChaoticT f)
{-# INLINE runChaoticT' #-}
chaotic :: (Identifiable a, IsCache cache a b, Profunctor c, ArrowChoice c, ArrowApply c) => Cache.Widening cache a b -> IterationStrategy (ChaoticT cache a b c) a b
chaotic widen (ChaoticT (WriterT (StateT f))) = ChaoticT $ WriterT $ StateT $ push $ proc (stack,cache,a) -> do
......@@ -103,17 +105,26 @@ chaotic widen (ChaoticT (WriterT (StateT f))) = ChaoticT $ WriterT $ StateT $ pu
instance (Identifiable a,IsCache cache a b, ArrowRun c) => ArrowRun (ChaoticT cache a b c) where
type Rep (ChaoticT cache a b c) x y = Rep c x (cache a b,y)
run = run . runChaoticT
{-# INLINE run #-}
instance (Identifiable a,Profunctor c,ArrowApply c) => ArrowApply (ChaoticT cache a b c) where
app = ChaoticT (lmap (first coerce) app)
{-# INLINE app #-}
instance (Identifiable a,Profunctor c,ArrowApply c) => ArrowApply (ChaoticT cache a b c) where app = ChaoticT (lmap (first coerce) app)
instance (Identifiable a,Profunctor c,Arrow c) => ArrowJoin (ChaoticT cache a b c) where
join _lub (ChaoticT f) (ChaoticT g) = ChaoticT $ rmap (uncurry _lub) (f &&& g)
joinSecond g = second g
{-# INLINE joinSecond #-}
instance (Identifiable a,Profunctor c,Arrow c, Complete y) => ArrowComplete y (ChaoticT cache a b c) where
ChaoticT f <> ChaoticT g = ChaoticT $ rmap (uncurry ()) (f &&& g)
{-# INLINE (<⊔>) #-}
data Component a = Component { head :: HashSet a, body :: HashSet a }
instance Identifiable a => Semigroup (Component a) where (<>) = mappend
instance Identifiable a => Monoid (Component a) where
mempty = Component { head = H.empty, body = H.empty }
c1 `mappend` c2 = Component { head = head c1 <> head c2, body = body c1 <> body c2 }
{-# INLINE mempty #-}
{-# INLINE mappend #-}
instance (Identifiable a, ArrowEffectCommutative c) => ArrowEffectCommutative (ChaoticT cache a b c) where
......@@ -99,7 +99,7 @@ instance (IsCache cache a b, ArrowRun c) => ArrowRun (ParallelT cache a b c) whe
instance (Profunctor c,ArrowApply c) => ArrowApply (ParallelT cache a b c) where app = ParallelT (lmap (first coerce) app)
instance IsEmpty (cache a b) => IsEmpty (Iteration cache a b) where empty = Iteration empty empty W.Stable
instance (ArrowEffectCommutative c) => ArrowJoin (ParallelT cache a b c) where
join _lub (ParallelT f) (ParallelT g) = ParallelT $ rmap (uncurry _lub) (f &&& g)
joinSecond (ParallelT g) = ParallelT $ second g
instance (ArrowEffectCommutative c, Complete y) => ArrowComplete y (ParallelT cache a b c) where
ParallelT f <> ParallelT g = ParallelT $ rmap (uncurry ()) (f &&& g)
instance ArrowEffectCommutative c => ArrowEffectCommutative (ParallelT cache a b c)
......
......@@ -31,7 +31,7 @@ import Data.Coerce
-- | Computation that produces a set of results.
newtype PowT c x y = PowT (KleisliT A.Pow c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e', ArrowExcept e')
......@@ -49,6 +49,3 @@ instance (Identifiable y, ArrowChoice c, ArrowFix x (A.Pow y) c) => ArrowFix x y
instance (ArrowChoice c, Profunctor c) => ArrowLowerBounded (PowT c) where
bottom = lift $ arr (\_ -> A.empty)
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (PowT c) where
join _ f g = lift $ join A.union (unlift f) (unlift g)
......@@ -22,7 +22,6 @@ import Control.Arrow.Transformer.Kleisli
import Control.Category
import Data.Abstract.Terminating
import Data.Abstract.Widening (toJoin)
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
......@@ -30,7 +29,7 @@ import Data.Coerce
-- | Arrow that propagates non-terminating computations.
newtype TerminatingT c x y = TerminatingT (KleisliT Terminating c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowJoin,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore addr val)
......@@ -40,14 +39,13 @@ runTerminatingT = coerce
instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (TerminatingT c) where
app = lift (app .# first coerce)
{-# INLINE app #-}
type instance Fix x y (TerminatingT c) = TerminatingT (Fix (Dom TerminatingT x y) (Cod TerminatingT x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom TerminatingT x y) (Cod TerminatingT x y) c) => ArrowFix x y (TerminatingT c)
instance (ArrowChoice c, Profunctor c) => ArrowLowerBounded (TerminatingT c) where
bottom = lift $ arr (\_ -> NonTerminating)
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (TerminatingT c) where
join lub' f g = lift $ join (toJoin widening lub') (unlift f) (unlift g)
{-# INLINE bottom #-}
deriving instance (ArrowChoice c, ArrowComplete (Terminating y) c) => ArrowComplete y (TerminatingT c)
......@@ -53,8 +53,8 @@ instance ArrowMonad f c => Profunctor (KleisliT f c) where
dimap f g h = lift $ dimap f (fmap g) $ unlift h
lmap f h = lift $ lmap f (unlift h)
rmap g h = lift $ rmap (fmap g) (unlift h)
f .# _ = f `seq` unsafeCoerce f
_ #. g = g `seq` unsafeCoerce g
f .# _ = unsafeCoerce f
_ #. g = unsafeCoerce g
{-# INLINE dimap #-}
{-# INLINE lmap #-}
{-# INLINE rmap #-}
......@@ -148,3 +148,8 @@ instance (ArrowMonad f c, ArrowConst r c) => ArrowConst r (KleisliT f c) where
instance (ArrowMonad f c, ArrowComplete (f y) c) => ArrowComplete y (KleisliT f c) where
f <> g = lift $ unlift f <> unlift g
{-# INLINE (<⊔>) #-}
instance (ArrowMonad f c, ArrowJoin c) => ArrowJoin (KleisliT f c) where
joinSecond g = lift $ rmap strength2 (joinSecond (unlift g))
{-# INLINE joinSecond#-}
......@@ -155,8 +155,8 @@ instance ArrowLowerBounded c => ArrowLowerBounded (ReaderT r c) where
{-# INLINE bottom #-}
instance ArrowJoin c => ArrowJoin (ReaderT r c) where
join lub f g = lift $ join lub (unlift f) (unlift g)
{-# INLINE join #-}
joinSecond g = lift $ lmap shuffle1 (joinSecond (unlift g))
{-# INLINE joinSecond #-}
instance ArrowComplete y c => ArrowComplete y (ReaderT r c) where
f <> g = lift $ unlift f <> unlift g
......
......@@ -171,8 +171,8 @@ instance (ArrowLowerBounded c) => ArrowLowerBounded (StateT s c) where
{-# INLINE bottom #-}
instance (ArrowJoin c, O.Complete s) => ArrowJoin (StateT s c) where
join lub f g = lift $ join (\(s1,z1) (s2,z2) -> (s1 O. s2,lub z1 z2)) (unlift f) (unlift g)
{-# INLINE join #-}
joinSecond g = lift $ dimap (\(s,(z,x)) -> ((s,z),(s,x))) (\((s,z),(s',x)) -> (s O. s',(z,x))) (joinSecond (unlift g))
{-# INLINE joinSecond #-}
instance (ArrowComplete (s,y) c) => ArrowComplete y (StateT s c) where
f <> g = lift $ unlift f <> unlift g
......
......@@ -35,6 +35,7 @@ instance (Applicative f, ArrowRun c) => ArrowRun (StaticT f c) where
type Rep (StaticT f c) x y = f (Rep c x y)
run = fmap run . runStaticT
{-# INLINE run #-}
{-# SPECIALIZE instance (ArrowRun c) => ArrowRun (StaticT ((->) r) c) #-}
instance (Applicative f, Profunctor c) => Profunctor (StaticT f c) where
dimap f g (StaticT h) = StaticT $ dimap f g <$> h
......@@ -47,16 +48,19 @@ instance (Applicative f, Profunctor c) => Profunctor (StaticT f c) where
{-# INLINE rmap #-}
{-# INLINE (.#) #-}
{-# INLINE (#.) #-}
{-# SPECIALIZE instance (Profunctor c) => Profunctor (StaticT ((->) r) c) #-}
instance Applicative f => ArrowLift (StaticT f) where
lift' = StaticT . pure
{-# INLINE lift' #-}
{-# SPECIALIZE instance ArrowLift (StaticT ((->) r)) #-}
instance (Applicative f, Arrow c, Profunctor c) => Category (StaticT f c) where
id = lift' id
instance (Applicative f, Category c, Profunctor c) => Category (StaticT f c) where
id = StaticT (pure id)
StaticT f . StaticT g = StaticT $ (.) <$> f <*> g
{-# INLINE id #-}
{-# INLINE (.) #-}
{-# SPECIALIZE instance (Arrow c, Profunctor c) => Category (StaticT ((->) r) c) #-}
instance (Applicative f, Arrow c, Profunctor c) => Arrow (StaticT f c) where
arr = lift' . arr
......@@ -69,6 +73,7 @@ instance (Applicative f, Arrow c, Profunctor c) => Arrow (StaticT f c) where
{-# INLINE second #-}
{-# INLINE (&&&) #-}
{-# INLINE (***) #-}
{-# SPECIALIZE instance (Arrow c, Profunctor c) => Arrow (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowChoice c, Profunctor c) => ArrowChoice (StaticT f c) where
left (StaticT f) = StaticT $ left <$> f
......@@ -79,6 +84,7 @@ instance (Applicative f, ArrowChoice c, Profunctor c) => ArrowChoice (StaticT f
{-# INLINE right #-}
{-# INLINE (+++) #-}
{-# INLINE (|||) #-}
{-# SPECIALIZE instance (ArrowChoice c, Profunctor c) => ArrowChoice (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowState s c) => ArrowState s (StaticT f c) where
get = lift' State.get
......@@ -87,20 +93,24 @@ instance (Applicative f, ArrowState s c) => ArrowState s (StaticT f c) where
{-# INLINE get #-}
{-# INLINE put #-}
{-# INLINE modify #-}
{-# SPECIALIZE instance ArrowState s c => ArrowState s (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowReader r c) => ArrowReader r (StaticT f c) where
ask = lift' Reader.ask
local (StaticT f) = StaticT $ Reader.local <$> f
{-# INLINE ask #-}
{-# INLINE local #-}
{-# SPECIALIZE instance ArrowReader r c => ArrowReader r (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowWriter w c) => ArrowWriter w (StaticT f c) where
tell = lift' tell
{-# INLINE tell #-}
{-# SPECIALIZE instance ArrowWriter e c => ArrowWriter e (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowFail e c) => ArrowFail e (StaticT f c) where
fail = lift' fail
{-# INLINE fail #-}
{-# SPECIALIZE instance ArrowFail e c => ArrowFail e (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowExcept e c) => ArrowExcept e (StaticT f c) where
type Join y (StaticT f c) = Exc.Join y c
......@@ -108,6 +118,7 @@ instance (Applicative f, ArrowExcept e c) => ArrowExcept e (StaticT f c) where
try (StaticT f) (StaticT g) (StaticT h) = StaticT $ try <$> f <*> g <*> h
{-# INLINE throw #-}
{-# INLINE try #-}
{-# SPECIALIZE instance ArrowExcept e c => ArrowExcept e (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowEnv var val c) => ArrowEnv var val (StaticT f c) where
type Join y (StaticT f c) = Env.Join y c
......@@ -115,12 +126,14 @@ instance (Applicative f, ArrowEnv var val c) => ArrowEnv var val (StaticT f c) w
extend (StaticT f) = StaticT $ Env.extend <$> f
{-# INLINE lookup #-}
{-# INLINE extend #-}
{-# SPECIALIZE instance ArrowEnv var val c => ArrowEnv var val (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowClosure var val env c) => ArrowClosure var val env (StaticT f c) where
ask = lift' Env.ask
local (StaticT f) = StaticT $ Env.local <$> f
{-# INLINE ask #-}
{-# INLINE local #-}
{-# SPECIALIZE instance ArrowClosure var val env c => ArrowClosure var val env (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
......@@ -128,14 +141,19 @@ instance (Applicative f, ArrowStore var val c) => ArrowStore var val (StaticT f
write = lift' write
{-# INLINE read #-}
{-# INLINE write #-}
{-# SPECIALIZE instance ArrowStore var val c => ArrowStore var val (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowLowerBounded c) => ArrowLowerBounded (StaticT f c) where
bottom = StaticT (pure bottom)
{-# INLINE bottom #-}
{-# SPECIALIZE instance ArrowLowerBounded c => ArrowLowerBounded (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowJoin c) => ArrowJoin (StaticT f c) where
join lub (StaticT f) (StaticT g) = StaticT $ join lub <$> f <*> g
{-# INLINE join #-}
joinSecond (StaticT g) = StaticT $ joinSecond <$> g
{-# INLINE joinSecond #-}
{-# SPECIALIZE instance ArrowJoin c => ArrowJoin (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowComplete y c) => ArrowComplete y (StaticT f c) where
StaticT f <> StaticT g = StaticT $ (<>) <$> f <*> g
{-# INLINE (<⊔>) #-}
{-# SPECIALIZE instance ArrowComplete y c => ArrowComplete y (StaticT ((->) r) c) #-}
......@@ -159,8 +159,8 @@ instance (Monoid w, ArrowLowerBounded c) => ArrowLowerBounded (WriterT w c) wher
{-# INLINE bottom #-}
instance (Monoid w, O.Complete w, ArrowJoin c) => ArrowJoin (WriterT w c) where
join lub f g = lift $ join (\(w1,z1) (w2,z2) -> (w1 O. w2, lub z1 z2)) (unlift f) (unlift g)
{-# INLINE join #-}
joinSecond g = lift $ rmap shuffle1 (joinSecond (unlift g))