Commit 41ab4f5f authored by Sven Keidel's avatar Sven Keidel

Merge branch 'context-sensitivity'

parents 4fe6f30f 2a2f6246
......@@ -17,8 +17,10 @@ import Data.Profunctor
import Data.Abstract.Error
import Data.Abstract.Except
import Data.Abstract.Cache
import qualified Data.Abstract.Widening as W
import Control.DeepSeq
import Control.Category
import Control.Arrow
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
......@@ -164,7 +166,7 @@ main = do
{-# INLINE runExceptT' #-}
runChaoticT'' :: Profunctor c => ChaoticT Cache () () c x y -> c x y
runChaoticT'' = runChaoticT'
runChaoticT'' = runChaoticT' id W.finite
{-# INLINE runChaoticT'' #-}
expr = addN 20 (Num 1)
......
......@@ -9,6 +9,7 @@ category: Language
dependencies:
- base
- containers
- comonad
- hashable
- mtl
- random
......@@ -19,7 +20,14 @@ dependencies:
- profunctors
library:
ghc-options: -Wall
ghc-options:
-Wall
-Wcompat
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wpartial-fields
-Wredundant-constraints
source-dirs:
- src
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
module Control.Arrow.Fix(Fix,ArrowFix(..),liftFix,IterationStrategy) where
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,transform,filter) where
import Prelude hiding (filter,pred)
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Lens(Iso',from,Prism',getMaybe,get,set)
-- | Type family that computes the type of the fixpoint.
type family Fix x y (c :: * -> * -> *) :: * -> * -> *
type family Fix (c :: * -> * -> *) x y :: * -> * -> *
type Fix' c x y = Fix c x y x y
-- | Interface for describing fixpoint computations.
class (Arrow c, Profunctor c) => ArrowFix x y c where
class ArrowFix c where
-- | Computes the fixpoint of an arrow computation.
fix :: (c x y -> c x y) -> c x y
fix :: (c -> c) -> c
type instance Fix x y (->) = (->)
instance ArrowFix x y (->) where
fix f = f (fix f)
default fix :: (c ~ c' x y, ArrowTrans c', Underlying c' x y ~ c'' x' y', ArrowFix (c'' x' y')) => (c -> c) -> c
fix f = lift (fix (unlift . f . lift))
{-# INLINE fix #-}
liftFix :: (Arrow c, Profunctor c, ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y
liftFix f = lift $ fix (unlift . f . lift)
{-# INLINE liftFix #-}
type instance Fix (->) x y = (->)
instance ArrowFix (x -> y) where
fix f = f (fix f)
type IterationStrategy c a b = c a b -> c a b
transform :: Profunctor c => Iso' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
transform iso strat f = lmap (get iso) (strat (lmap (get (from iso)) f))
{-# INLINE transform #-}
filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
filter pred strat f = proc a -> case getMaybe pred a of
Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
{-# INLINE filter #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Cache where
import Control.Arrow
import Data.Profunctor
import Data.Abstract.Stable
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
-- | Looks up if there is an entry in the cache.
lookup :: c a (Maybe (Stable,b))
-- | Write a new entry to the cache.
write :: c (a,b,Stable) ()
-- | Update an existing entry in the cache.
update :: c (a,b) (Stable,b)
-- | Set a given entry to stable or unstable.
setStable :: c (Stable,a) ()
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Fix.Chaotic where
import Prelude hiding (head)
import Control.Arrow
import Data.HashSet (HashSet)
import qualified Data.HashSet as H
import Data.Identifiable
import Data.Profunctor
import Data.Order
import Text.Printf
class (Arrow c, Profunctor c) => ArrowIterate a c where
-- | Remembers to iterate on an unstable result until it stabilized.
iterate :: c (a,b) b
class (Arrow c, Profunctor c) => ArrowComponent a c | c -> a where
setComponent :: c (Component a,y) y
withComponent :: c x y -> (c (x,y,Component a) y) -> c x y
data Component a = Component { head :: HashSet a, body :: HashSet a } deriving (Eq)
instance Identifiable a => PreOrd (Component a) where
c1 c2 = head c1 head c2 && body c1 body c2
{-# INLINE (⊑) #-}
instance Identifiable a => Complete (Component a) where
c1 c2 = c1 <> c2
{-# INLINE (⊔) #-}
instance Identifiable a => Semigroup (Component a) where
Component h1 b1 <> Component h2 b2 = Component { head = h1 <> h2, body = b1 <> b2 }
{-# INLINE (<>) #-}
instance Identifiable a => Monoid (Component a) where
mempty = Component { head = H.empty, body = H.empty }
mappend = (<>)
{-# INLINE mempty #-}
{-# INLINE mappend #-}
singleton :: Identifiable a => a -> Component a
singleton a = Component { head = H.singleton a, body = H.empty }
{-# INLINE singleton #-}
instance Show a => Show (Component a) where
show (Component h b) = printf "Component { head = %s, body = %s }" (show (H.toList h)) (show (H.toList b))
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Context where
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.State
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowContext ctx c | c -> ctx where
askContext :: c () ctx
localContext :: c x y -> c (ctx,x) y
class ArrowJoinContext cache a b c where
type Widening cache a :: *
joinContexts' :: Widening cache a -> IterationStrategy c (cache a b, a) b
joinContexts :: forall a cache b c. (ArrowState (cache a b) c, ArrowJoinContext cache a b c) => Widening cache a -> IterationStrategy c a b
joinContexts widen f = proc a -> do
cache <- get -< ()
joinContexts' widen (proc (cache,a) -> do
put -< cache
f -< a) -< (cache,a)
{-# INLINE joinContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Reuse where
import Control.Arrow
import Control.Arrow.Fix
import Data.Abstract.Stable
import Data.Metric
import Data.Profunctor
import Data.Monoid
import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where
type Dom c :: *
-- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => (Dom c -> Dom c -> Stable -> b -> m) -> c (a,Stable) m
reuseFirst :: (ArrowChoice c, ArrowReuse a b c) => IterationStrategy c a b
reuseFirst f = proc a -> do
m <- reuse (\_ _ _ b -> First (Just b)) -< (a,Stable)
case getFirst m of
Just b -> returnA -< b
Nothing -> f -< a
{-# INLINE reuseFirst #-}
reuseExact :: (Eq (Dom c), ArrowChoice c, ArrowReuse a b c) => IterationStrategy c a b
reuseExact = reuseByMetric discrete
{-# INLINE reuseExact #-}
reuseByMetric :: (Ord n, ArrowChoice c, ArrowReuse a b c) => Metric (Dom c) n -> IterationStrategy c a b
reuseByMetric metric f = proc a -> do
m <- reuse (\a a' _ b -> Just (Measured { measured = metric a a', argument = b })) -< (a,Stable)
case m of
Just n -> returnA -< argument n
Nothing -> f -< a
{-# INLINE reuseByMetric #-}
data Measured a n = Measured { argument :: a, measured :: n }
instance (Show a, Show n) => Show (Measured a n) where
show m = printf "%s@%s" (show (argument m)) (show (measured m))
instance Ord n => Semigroup (Measured a n) where
m1 <> m2
| measured m1 <= measured m2 = m1
| otherwise = m2
{-# INLINE (<>) #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Stack where
import Control.Arrow
import Data.Profunctor
import Data.HashSet
class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
peek :: c () (Maybe a)
size :: c () Int
push :: c a b -> c a b
elem :: c a Bool
elems :: c () (HashSet a)
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Fix.Widening where
import Control.Arrow
import Data.Profunctor
import Data.Order
import Data.Abstract.Stable
import Data.Abstract.Widening (finite)
class (Arrow c, Profunctor c) => ArrowWidening a c where
widening :: c (a,a) (Stable,a)
instance Complete a => ArrowWidening a (->) where
widening (a,a') = finite a a'
......@@ -3,6 +3,7 @@ module Control.Arrow.Monad where
import Control.Arrow
import Control.Monad (join)
import Control.Comonad
import Data.Profunctor
class (Functor f, Arrow c, Profunctor c) => ArrowFunctor f c where
......@@ -17,3 +18,20 @@ class (Monad f, ArrowFunctor f c) => ArrowMonad f c where
mapJoinA :: c x (f y) -> c (f x) (f y)
mapJoinA f = rmap join (mapA f)
{-# INLINE unitA #-}
{-# INLINE joinA #-}
{-# INLINE mapJoinA #-}
class (Comonad f, ArrowFunctor f c) => ArrowComonad f c where
extractA :: c (f x) x
extractA = arr extract
duplicateA :: c (f x) (f (f x))
duplicateA = arr duplicate
mapDuplicateA :: c (f x) y -> c (f x) (f y)
mapDuplicateA f = lmap duplicate (mapA f)
{-# INLINE extractA #-}
{-# INLINE duplicateA #-}
{-# INLINE mapDuplicateA #-}
......@@ -19,6 +19,7 @@ class (Arrow c, Profunctor c) => ArrowComplete y c where
instance Complete y => ArrowComplete y (->) where
(<>) f g = \x -> f x g x
{-# INLINE (<⊔>) #-}
-- | An arrow computation @c@ is effect commutative iff for all @f, g :: c x y@,
--
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Reader where
import Control.Arrow
import Control.Monad.Reader (MonadReader)
import qualified Control.Monad.Reader as M
import Data.Profunctor
import Control.Arrow
import Data.Profunctor
-- | Arrow-based interface for read-only values.
class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where
......@@ -15,7 +11,3 @@ class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where
ask :: c () r
-- | Runs a computation with a new value.
local :: c x y -> c (r,x) y
instance MonadReader r m => ArrowReader r (Kleisli m) where
ask = Kleisli (const M.ask)
local (Kleisli f) = Kleisli (\(r,x) -> M.local (const r) (f x))
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
......
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Trans where
import Control.Arrow
import Data.Profunctor
import Data.Coerce
class (Arrow c, Profunctor c) => ArrowRun c where
type Rep c x y
run :: c x y -> Rep c x y
type Run c x y
run :: c x y -> Run c x y
default run :: (Underlying c x y ~ c' x' y', Run c x y ~ Run c' x' y', ArrowRun c', ArrowTrans c) => c x y -> Run c x y
run = run . unlift
{-# INLINE run #-}
instance ArrowRun (->) where
type Rep (->) x y = x -> y
type Run (->) x y = x -> y
run = id
{-# INLINE run #-}
class ArrowLift t where
lift' :: (Arrow c, Profunctor c) => c x y -> t c x y
-- | Lifts an inner computation into an arrow transformer and vice versa.
class ArrowTrans t where
type Dom t x y :: *
type Cod t x y :: *
class ArrowTrans c where
type Underlying c x y :: *
lift :: Underlying c x y -> c x y
unlift :: c x y -> Underlying c x y
default lift :: forall x y. (Coercible (c x y) (Underlying c x y)) => Underlying c x y -> c x y
lift = coerce
{-# INLINE lift #-}
default unlift :: forall x y. (Coercible (c x y) (Underlying c x y)) => c x y -> Underlying c x y
unlift = coerce
{-# INLINE unlift #-}
lift1 :: ArrowTrans c => (Underlying c x y -> Underlying c x' y') -> (c x y -> c x' y')
lift1 f = lift . f . unlift
{-# INLINE lift1 #-}
lift :: (Arrow c, Profunctor c) => c (Dom t x y) (Cod t x y) -> t c x y
unlift :: (Arrow c, Profunctor c) => t c x y -> c (Dom t x y) (Cod t x y)
unlift1 :: ArrowTrans c => (c x y -> c x' y') -> (Underlying c x y -> Underlying c x' y')
unlift1 f = unlift . f . lift
{-# INLINE unlift1 #-}
......@@ -44,12 +44,11 @@ type Env var addr val = (HM.HashMap var addr,HM.HashMap addr val)
type Alloc c var addr val = c (var,val,Env var addr val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc c var addr val) (ReaderT (Env var addr val) c) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowComplete z, ArrowLowerBounded)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowComplete z, ArrowLowerBounded, ArrowTrans)
deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c)
=> Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
runEnvT :: Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
runEnvT alloc (EnvT f) = runReaderT (runConstT alloc f)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
......@@ -73,16 +72,10 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Prof
(_,store) <- Reader.ask -< ()
Reader.local f -< ((env,store),x)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Rep (EnvT var addr val c) x y = Alloc c var addr val -> Rep c (Env var addr val,x) y
instance (ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Run (EnvT var addr val c) x y = Alloc c var addr val -> Run c (Env var addr val,x) y
run f alloc = run (runEnvT alloc f)
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = (Env var addr val,x)
type Cod (EnvT var addr val) x y = y
lift = undefined
unlift = undefined
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
......@@ -94,6 +87,5 @@ instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT (app .# first coerce)
deriving instance ArrowFix (Dom (EnvT var addr val) x y) (Cod (EnvT var addr val) x y) c => ArrowFix x y (EnvT var addr val c)
type instance Fix x y (EnvT var addr val c) = EnvT var addr val (Fix (Dom (EnvT var addr val) x y) (Cod (EnvT var addr val) x y) c)
type instance Fix (EnvT var addr val c) x y = EnvT var addr val (Fix c (Env var addr val,x) y)
deriving instance (Arrow c, Profunctor c, ArrowFix (c (Env var addr val,x) y)) => ArrowFix (EnvT var addr val c x y)
......@@ -43,8 +43,8 @@ runCompletionT = coerce
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT c) where
app = lift (app .# first coerce)
type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c) => ArrowFix x y (CompletionT c)
type instance Fix (CompletionT c) x y = CompletionT (Fix c x (FreeCompletion y))
deriving instance (ArrowFix (Underlying (CompletionT c) x y)) => ArrowFix (CompletionT c x y)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
bottom = lift $ bottom
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Contour(ContourT,runContourT,contour,CallString) where
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Control.Category
import Data.Label
import Data.CallString
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Records the k-bounded call string. Meant to be used in
-- conjunction with 'Abstract.BoundedEnvironment'.
newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b)
deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice,
ArrowConst r, ArrowState s,
ArrowEnv var val, ArrowClosure var val env,
ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete z)
-- | Runs a computation that records a call string. The argument 'k'
-- specifies the maximum length of a call string. All larger call
-- strings are truncated to at most 'k' elements.
runContourT :: (Arrow c, Profunctor c) => Int -> ContourT lab c a b -> c a b
runContourT k (ContourT (ReaderT f)) = lmap (\a -> (empty k,a)) f
{-# INLINE runContourT #-}
contour :: (Arrow c, Profunctor c) => ContourT lab c () (CallString lab)
contour = ContourT Reader.ask
instance ArrowRun c => ArrowRun (ContourT lab c) where
type Rep (ContourT lab c) x y = Int -> Rep c x y
run f i = run (runContourT i f)
{-# INLINE run #-}
type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c)
instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix x y (ContourT lab c) where
-- Pushes the label of the last argument on the call string and truncate the call string in case it reached the maximum length
fix f = ContourT $ ReaderT $ proc (c,x) -> fix (unwrap c . f . wrap) -<< x
where
wrap :: (Arrow c, Profunctor c) => c x y -> ContourT lab c x y
wrap = lift'
unwrap :: (HasLabel x lab, Arrow c, Profunctor c) => CallString lab -> ContourT lab c x y -> c x y
unwrap c (ContourT (ReaderT f')) = proc x -> do
y <- f' -< (push (label x) c,x)
returnA -< y
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' Reader.ask
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> Reader.local f)
......@@ -37,11 +37,11 @@ newtype EnvT var val c x y = EnvT (ReaderT (Map 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)
runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y
runEnvT :: EnvT var val c x y -> c (Map var val,x) y
runEnvT = coerce
{-# INLINE runEnvT #-}
runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' :: (Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' f = lmap (first M.fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
......@@ -68,5 +68,5 @@ instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' Reader.ask
local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (Reader.local (unlift f))
type instance Fix x y (EnvT var val c) = EnvT var val (Fix (Dom (EnvT var val) x y) (Cod (EnvT var val) x y) c)
deriving instance ArrowFix (Map var val,x) y c => ArrowFix x y (EnvT var val c)
type instance Fix (EnvT var val c) x y = EnvT var val (Fix c (Map var val,x) y)
deriving instance ArrowFix (Underlying (EnvT var val c) x y) => ArrowFix (EnvT var val c x y)
......@@ -46,8 +46,8 @@ instance (ArrowChoice c, Profunctor c) => ArrowFail e (ErrorT e c) where
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ErrorT e c) where
app = lift (app .# first coerce)
type instance Fix x y (ErrorT e c) = ErrorT e (Fix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowFix x y (ErrorT e c)
type instance Fix (ErrorT e c) x y = ErrorT e (Fix c x (Error e y))
deriving instance (ArrowFix (Underlying (ErrorT e c) x y)) => ArrowFix (ErrorT e c x y)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (ErrorT e c) where
bottom = lift bottom
......
......@@ -57,8 +57,8 @@ instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowApply c, Profunctor c) =>
app = lift (app .# first coerce)
{-# INLINE app #-}
type instance Fix x y