Commit cd8570b2 authored by Sven Keidel's avatar Sven Keidel

remove INLINE statments

parent db4e0fb4
......@@ -24,7 +24,7 @@ flags:
manual: True
library:
ghc-options: -Wall -O2
ghc-options: -Wall
source-dirs:
- src
when:
......
......@@ -19,11 +19,9 @@ class (Arrow c, Profunctor c) => ArrowJoin c where
joinWith' :: ArrowJoin c => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
joinWith' lub f g = joinWith lub (f <<< pi1) (g <<< pi2)
{-# INLINE joinWith' #-}
(<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y
(<>) = joinWith ()
{-# INLINE (<⊔>) #-}
-- | Joins a list of arguments. Use it with idiom brackets:
-- @
......
......@@ -45,7 +45,6 @@ class (Arrow c, Profunctor c) => ArrowEnv var val env c | c -> var, c -> val, c
-- | Simpler version of environment lookup.
lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c var val
lookup' = lookup'' id
{-# INLINE lookup' #-}
lookup'' :: (Join c ((val,var),var) y, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c val y -> c var y
lookup'' f = proc var ->
......@@ -53,7 +52,6 @@ lookup'' f = proc var ->
(proc (val,_) -> f -< val)
(proc var -> fail -< fromString $ printf "Variable %s not bound" (show var))
-< (var,var)
{-# INLINE lookup'' #-}
-- | Run a computation in an extended environment.
extendEnv' :: ArrowEnv var val env c => c a b -> c (var,val,a) b
......@@ -61,9 +59,7 @@ extendEnv' f = proc (x,y,a) -> do
env <- getEnv -< ()
env' <- extendEnv -< (x,y,env)
localEnv f -< (env',a)
{-# INLINE extendEnv' #-}
-- | Add a list of bindings to the given environment.
bindings :: (ArrowChoice c, ArrowEnv var val env c) => c ([(var,val)],env) env
bindings = fold ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv)
{-# INLINE bindings #-}
......@@ -34,23 +34,19 @@ class (Arrow c, Profunctor c) => ArrowExcept e c | c -> e where
-- | Simpler version of 'throw'.
throw' :: ArrowExcept () c => c a b
throw' = proc _ -> throw -< ()
{-# INLINE throw' #-}
-- | Simpler version of 'catch'.
catch' :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c e y -> c x y
catch' f g = catch f (pi2 >>> g)
{-# INLINE catch' #-}
-- | @'try' f g h@ executes @f@, if it succeeds the result is passed to
-- @g@, if it fails the original input is passed to @h@.
try :: (Join c (x,(x,e)) z, ArrowExcept e c) => c x y -> c y z -> c x z -> c x z
try f g h = catch (f >>> g) (pi1 >>> h)
{-# INLINE try #-}
-- | Picks the first computation that does not throw an exception.
(<+>) :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c x y -> c x y
f <+> g = catch f (pi1 >>> g)
{-# INLINE (<+>) #-}
-- | @'tryFirst' f g -< l@ executes @f@ on elements of @l@ until one of them does not throw an exception.
-- In case @f@ throws an exception for all elements of @l@, @g@ is executed.
......@@ -58,9 +54,7 @@ tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) =>
tryFirst f g = proc l -> case l of
[] -> g -< ()
a:as -> try (f . pi1) id (tryFirst f g . pi2) -< (a,as)
{-# INLINE tryFirst #-}
-- | A computation that always succeeds
success :: ArrowExcept e c => c a a
success = id
{-# INLINE success #-}
......@@ -25,4 +25,3 @@ instance MonadError e m => ArrowFail e (Kleisli m) where
-- | Simpler version of 'fail'.
fail' :: ArrowFail () c => c a b
fail' = arr (const ()) >>> fail
{-# INLINE fail' #-}
......@@ -25,4 +25,3 @@ instance ArrowFix x y (->) where
liftFix :: (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 #-}
......@@ -24,12 +24,10 @@ class (Arrow c, Profunctor c) => ArrowState s c | c -> s where
-- | run computation that modifies the current state.
modify :: ArrowState s c => c (x,s) s -> c x ()
modify f = put <<< f <<< (id &&& const get)
{-# INLINE modify #-}
-- | run computation that modifies the current state.
modify' :: ArrowState s c => c (s,x) s -> c x ()
modify' f = put <<< f <<< (const get &&& id)
{-# INLINE modify' #-}
instance MonadState s m => ArrowState s (Kleisli m) where
get = Kleisli (P.const M.get)
......
......@@ -33,4 +33,3 @@ read' = proc var ->
read (proc (val,_) -> returnA -< val)
(proc var -> fail -< fromString $ printf "variable %s not bound" (show var))
-< (var,var)
{-# INLINE read' #-}
......@@ -57,7 +57,6 @@ runEnvT alloc f =
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f')
{-# INLINE runEnvT #-}
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = Dom (ReaderT (Map var addr val)) x y
......@@ -67,7 +66,6 @@ instance ArrowTrans (EnvT var addr val) where
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
{-# INLINE lift' #-}
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
ArrowEnv var val (Map var addr val) (EnvT var addr val c) where
......@@ -78,24 +76,17 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Prof
Just val -> f -< (val,x)
JustNothing val -> joined f g -< ((val,x),x)
Nothing -> g -< x
{-# INLINE lookup #-}
getEnv = EnvT ask
{-# INLINE getEnv #-}
extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc
{-# INLINE extendEnv #-}
localEnv (EnvT f) = EnvT $ local f
{-# INLINE localEnv #-}
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' ask
{-# INLINE ask #-}
local (EnvT (ConstT (StaticT f))) =
EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (runReaderT (f alloc))
{-# INLINE local #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app
{-# INLINE app #-}
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)
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)
......
......@@ -33,107 +33,76 @@ newtype CompletionT c x y = CompletionT { runCompletionT :: c x (FreeCompletion
instance (Profunctor c, Arrow c) => Profunctor (CompletionT c) where
dimap f g h = lift $ dimap f (fmap g) (unlift h)
{-# INLINE dimap #-}
lmap f h = lift $ lmap f (unlift h)
{-# INLINE lmap #-}
rmap g h = lift $ rmap (fmap g) (unlift h)
{-# INLINE rmap #-}
instance ArrowTrans CompletionT where
type Dom CompletionT x y = x
type Cod CompletionT x y = FreeCompletion y
lift = CompletionT
{-# INLINE lift #-}
unlift = runCompletionT
{-# INLINE unlift #-}
instance ArrowLift CompletionT where
lift' f = CompletionT (rmap Lower f)
{-# INLINE lift' #-}
instance (ArrowChoice c, Profunctor c) => Category (CompletionT c) where
id = lift' id
{-# INLINE id #-}
CompletionT f . CompletionT g = CompletionT $ proc x -> do
g' <- g -< x
case g' of
Lower a -> f -< a
Top -> returnA -< Top
{-# INLINE (.) #-}
instance (ArrowChoice c, Profunctor c) => Arrow (CompletionT c) where
arr = lift' . arr
{-# INLINE arr #-}
first f = lift $ rmap strength1 (first (unlift f))
{-# INLINE first #-}
second f = lift $ rmap strength2 (second (unlift f))
{-# INLINE second #-}
f *** g = lift $ rmap (uncurry (liftA2 (,))) (unlift f *** unlift g)
{-# INLINE (***) #-}
f &&& g = lift $ rmap (uncurry (liftA2 (,))) (unlift f &&& unlift g)
{-# INLINE (&&&) #-}
instance (ArrowChoice c, Profunctor c) => ArrowChoice (CompletionT c) where
left (CompletionT f) = CompletionT $ rmap strength1 (left f)
{-# INLINE left #-}
right (CompletionT f) = CompletionT $ rmap strength2 (right f)
{-# INLINE right #-}
instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowApply (CompletionT c) where
app = CompletionT $ lmap (first runCompletionT) app
{-# INLINE app #-}
instance (ArrowChoice c, ArrowState s c, Profunctor c) => ArrowState s (CompletionT c) where
get = lift' get
{-# INLINE get #-}
put = lift' put
{-# INLINE put #-}
instance (ArrowChoice c, ArrowFail e c) => ArrowFail e (CompletionT c) where
fail = lift' fail
{-# INLINE fail #-}
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (CompletionT c) where
ask = lift' ask
{-# INLINE ask #-}
local f = lift (local (unlift f))
{-# INLINE local #-}
instance (ArrowChoice c, ArrowEnv var val env c) => ArrowEnv var val env (CompletionT c) where
type Join (CompletionT c) x y = Env.Join c (Dom CompletionT x y) (Cod CompletionT x y)
lookup f g = lift (lookup (unlift f) (unlift g))
{-# INLINE lookup #-}
getEnv = lift' getEnv
{-# INLINE getEnv #-}
extendEnv = lift' extendEnv
{-# INLINE extendEnv #-}
localEnv f = lift (localEnv (unlift f))
{-# INLINE localEnv #-}
instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (CompletionT c) where
type Join (CompletionT c) x y = Exc.Join c (Dom CompletionT x y) (Cod CompletionT x y)
throw = lift' throw
{-# INLINE throw #-}
catch f g = lift $ catch (unlift f) (unlift g)
{-# INLINE catch #-}
finally f g = lift $ finally (unlift f) (unlift g)
{-# INLINE finally #-}
instance (ArrowChoice c, Profunctor c) => ArrowDeduplicate x y (CompletionT c) where
dedup = returnA
{-# INLINE dedup #-}
type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom CompletionT x y) (Cod CompletionT x y) c)
instance (ArrowChoice c, ArrowFix (Dom CompletionT x y) (Cod CompletionT x y) c) => ArrowFix x y (CompletionT c) where
fix = liftFix
{-# INLINE fix #-}
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where
joinWith lub f g = lift $ joinWith join (unlift f) (unlift g)
where join (Lower x) (Lower y) = Lower (lub x y)
join Top _ = Top
join _ Top = Top
{-# INLINE joinWith #-}
deriving instance PreOrd (c x (FreeCompletion y)) => PreOrd (CompletionT c x y)
deriving instance LowerBounded (c x (FreeCompletion y)) => LowerBounded (CompletionT c x y)
......
......@@ -40,7 +40,6 @@ newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b)
-- 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 #-}
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
......@@ -54,22 +53,17 @@ instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix
unwrap c (ContourT (ReaderT f')) = proc x -> do
y <- f' -< (push (label x) c,x)
returnA -< y
{-# INLINE fix #-}
instance (Arrow c, Profunctor c) => ArrowAlloc (var,val,env) (var,CallString lab) (ContourT lab c) where
-- | Return the variable together with the current call string as address.
alloc = ContourT $ ReaderT $ arr $ \(l,(x,_,_)) -> (x,l)
{-# INLINE alloc #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT $ lmap (\(ContourT f,x) -> (f,x)) app
{-# INLINE app #-}
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' ask
{-# INLINE ask #-}
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> local f)
{-# INLINE local #-}
deriving instance PreOrd (c (CallString lab,x) y) => PreOrd (ContourT lab c x y)
deriving instance LowerBounded (c (CallString lab,x) y) => LowerBounded (ContourT lab c x y)
......
......@@ -38,11 +38,9 @@ newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y)
runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y
runEnvT = unlift
{-# INLINE runEnvT #-}
runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' f = first M.fromList ^>> runEnvT f
{-# INLINE runEnvT' #-}
instance (Show var, Identifiable var, ArrowChoice c,Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where
type Join (EnvT var val c) x y = (Complete (c (Map var val,x) y))
......@@ -52,23 +50,16 @@ instance (Show var, Identifiable var, ArrowChoice c,Profunctor c) => ArrowEnv va
Just val -> f -< (val,x)
JustNothing val -> joined f g -< ((val,x),x)
Nothing -> g -< x
{-# INLINE lookup #-}
getEnv = EnvT ask
{-# INLINE getEnv #-}
extendEnv = arr $ \(x,y,env) -> M.insert x y env
{-# INLINE extendEnv #-}
localEnv (EnvT f) = EnvT (local f)
{-# INLINE localEnv #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where
app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app
{-# INLINE app #-}
instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' ask
{-# INLINE ask #-}
local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (local (unlift f))
{-# INLINE local #-}
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)
......
......@@ -35,23 +35,19 @@ newtype ExceptT e c x y = ExceptT { runExceptT :: c x (Error e y)}
instance (ArrowChoice c, Complete e, ArrowJoin c) => ArrowExcept e (ExceptT e c) where
type Join (ExceptT e c) (x,(x,e)) y = Complete (c (y,(x,e)) (Error e y))
throw = lift $ arr Fail
{-# INLINE throw #-}
catch f g = lift $ proc x -> do
e <- unlift f -< x
case e of
Success y -> returnA -< Success y
SuccessOrFail er y -> joined (arr Success) (unlift g) -< (y,(x,er))
Fail er -> unlift g -< (x,er)
{-# INLINE catch #-}
finally f g = lift $ proc x -> do
e <- unlift f -< x
unlift g -< x
returnA -< e
{-# INLINE finally #-}
instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) where
id = lift' id
{-# INLINE id #-}
f . g = lift $ proc x -> do
y <- unlift g -< x
case y of
......@@ -68,104 +64,72 @@ instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) wher
Fail e' -> Fail (e e')
SuccessOrFail e' z -> SuccessOrFail (e e') z)
id (unlift f) -< (Fail e,y')
{-# INLINE (.) #-}
instance (Profunctor c, Arrow c) => Profunctor (ExceptT e c) where
dimap f g h = lift $ dimap f (fmap g) (unlift h)
{-# INLINE dimap #-}
lmap f h = lift $ lmap f (unlift h)
{-# INLINE lmap #-}
rmap g h = lift $ rmap (fmap g) (unlift h)
{-# INLINE rmap #-}
instance ArrowLift (ExceptT e) where
lift' f = ExceptT (rmap Success f)
{-# INLINE lift' #-}
instance ArrowTrans (ExceptT e) where
type Dom (ExceptT e) x y = x
type Cod (ExceptT e) x y = Error e y
lift = ExceptT
{-# INLINE lift #-}
unlift = runExceptT
{-# INLINE unlift #-}
instance (ArrowChoice c, ArrowJoin c, Complete e) => Arrow (ExceptT e c) where
arr f = lift' (arr f)
{-# INLINE arr #-}
first f = lift $ rmap strength1 (first (unlift f))
{-# INLINE first #-}
second f = lift $ rmap strength2 (second (unlift f))
{-# INLINE second #-}
f &&& g = lift $ rmap mstrength (unlift f &&& unlift g)
{-# INLINE (&&&) #-}
f *** g = lift $ rmap mstrength (unlift f *** unlift g)
{-# INLINE (***) #-}
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowChoice (ExceptT e c) where
left f = lift $ rmap strength1 (left (unlift f))
{-# INLINE left #-}
right f = lift $ rmap strength2 (right (unlift f))
{-# INLINE right #-}
f ||| g = lift $ unlift f ||| unlift g
{-# INLINE (|||) #-}
f +++ g = lift $ rmap mstrength $ unlift f +++ unlift g
{-# INLINE (+++) #-}
instance (Complete e, ArrowJoin c, ArrowApply c, ArrowChoice c) => ArrowApply (ExceptT e c) where
app = lift $ lmap (first unlift) app
{-# INLINE app #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowState s c) => ArrowState s (ExceptT e c) where
get = lift' get
{-# INLINE get #-}
put = lift' put
{-# INLINE put #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowStore var val c) => ArrowStore var val (ExceptT e c) where
type Join (ExceptT e c) x y = Store.Join c (Dom (ExceptT e) x y) (Cod (ExceptT e) x y)
read f g = lift $ read (unlift f) (unlift g)
{-# INLINE read #-}
write = lift' write
{-# INLINE write #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFail f c) => ArrowFail f (ExceptT e c) where
fail = lift' fail
{-# INLINE fail #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowReader r c) => ArrowReader r (ExceptT e c) where
ask = lift' ask
{-# INLINE ask #-}
local f = lift (local (unlift f))
{-# INLINE local #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (ExceptT e c) where
type Join (ExceptT e c) x y = Env.Join c (Dom (ExceptT e) x y) (Cod (ExceptT e) x y)
lookup f g = lift $ lookup (unlift f) (unlift g)
{-# INLINE lookup #-}
getEnv = lift' getEnv
{-# INLINE getEnv #-}
extendEnv = lift' extendEnv
{-# INLINE extendEnv #-}
localEnv f = lift (localEnv (unlift f))
{-# INLINE localEnv #-}
type instance Fix x y (ExceptT e c) = ExceptT e (Fix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c)
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) where
fix = liftFix
{-# INLINE fix #-}
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowDeduplicate x y (ExceptT e c) where
dedup = returnA
{-# INLINE dedup #-}
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowConst r c) => ArrowConst r (ExceptT e c) where
askConst = lift' askConst
{-# INLINE askConst #-}
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) where
joinWith lub' f g = ExceptT $ joinWith (widening () lub') (unlift f) (unlift g)
{-# INLINE joinWith #-}
deriving instance PreOrd (c x (Error e y)) => PreOrd (ExceptT e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (ExceptT e c x y)
......
......@@ -36,116 +36,80 @@ newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) }
instance (ArrowChoice c, Profunctor c) => ArrowFail e (FailureT e c) where
fail = lift $ arr Fail
{-# INLINE fail #-}
instance (Profunctor c, Arrow c) => Profunctor (FailureT e c) where
dimap f g h = lift $ dimap f (fmap g) (unlift h)
{-# INLINE dimap #-}
lmap f h = lift $ lmap f (unlift h)
{-# INLINE lmap #-}
rmap g h = lift $ rmap (fmap g) (unlift h)
{-# INLINE rmap #-}
instance ArrowTrans (FailureT e) where
type Dom (FailureT e) x y = x
type Cod (FailureT e) x y = Failure e y
lift = FailureT
{-# INLINE lift #-}
unlift = runFailureT
{-# INLINE unlift #-}
instance ArrowLift (FailureT e) where
lift' f = lift (f >>> arr Success)
{-# INLINE lift' #-}
instance (ArrowChoice c,Profunctor c) => Category (FailureT r c) where
id = lift' id
{-# INLINE id #-}
f . g = lift $ unlift g >>> lmap toEither (arr Fail ||| unlift f)
{-# INLINE (.) #-}
instance (ArrowChoice c,Profunctor c) => Arrow (FailureT r c) where
arr f = lift' (arr f)
{-# INLINE arr #-}
first f = lift $ rmap strength1 (first (unlift f))
{-# INLINE first #-}
second f = lift $ rmap strength2 (second (unlift f))
{-# INLINE second #-}
f &&& g = lift $ rmap mstrength (unlift f &&& unlift g)
{-# INLINE (&&&) #-}
f *** g = lift $ rmap mstrength (unlift f *** unlift g)
{-# INLINE (***) #-}
instance (ArrowChoice c, Profunctor c) => ArrowChoice (FailureT r c) where
left f = lift $ rmap strength1 $ left (unlift f)
{-# INLINE left #-}
right f = lift $ rmap strength2 $ right (unlift f)
{-# INLINE right #-}
f ||| g = lift $ unlift f ||| unlift g
{-# INLINE (|||) #-}
f +++ g = lift $ rmap mstrength (unlift f +++ unlift g)
{-# INLINE (+++) #-}
instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (FailureT e c) where
app = lift $ lmap (first unlift) app
{-# INLINE app #-}
instance (ArrowChoice c, ArrowState s c) => ArrowState s (FailureT e c) where
get = lift' get
{-# INLINE get #-}
put = lift' put
{-# INLINE put #-}
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (FailureT e c) where
ask = lift' ask
{-# INLINE ask #-}
local f = lift (local (unlift f))
{-# INLINE local #-}
instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (FailureT e c) where
type Join (FailureT e c) x y = Env.Join c (Dom (FailureT e) x y) (Cod (FailureT e) x y)
lookup f g = lift $ lookup (unlift f) (unlift g)
{-# INLINE lookup #-}
getEnv = lift' getEnv
{-# INLINE getEnv #-}
extendEnv = lift' extendEnv
{-# INLINE extendEnv #-}
localEnv f = lift (localEnv (unlift f))
{-# INLINE localEnv #-}
instance (ArrowChoice c, ArrowStore var val c) => ArrowStore var val (FailureT e c) where
type Join (FailureT e c) x y = Store.Join c (Dom (FailureT e) x y) (Cod (FailureT e) x y)
read f g = lift $ read (unlift f) (unlift g)
{-# INLINE read #-}
write = lift' $ write
{-# INLINE write #-}
type instance Fix x y (FailureT e c) = FailureT e (Fix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c)
instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) => ArrowFix x y (FailureT e c) where
fix = liftFix
{-# INLINE fix #-}
instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (FailureT e' c) where
type Join (FailureT e' c) x y = Exc.Join c (Dom (FailureT e') x y) (Cod (FailureT e') x y)
throw = lift' throw
{-# INLINE throw #-}
catch f g = lift $ catch (unlift f) (unlift g)
{-# INLINE catch #-}
finally f g = lift $ finally (unlift f) (unlift g)
{-# INLINE finally #-}
instance (Identifiable e, ArrowChoice c, ArrowDeduplicate (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) => ArrowDeduplicate x y (FailureT e c) where
dedup f = lift (dedup (unlift f))
{-# INLINE dedup #-}
instance (ArrowChoice c, ArrowConst r c) => ArrowConst r (FailureT e c) where
askConst = lift' askConst
{-# INLINE askConst #-}
instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FailureT e c) where
joinWith lub' (FailureT f) (FailureT g) = FailureT $ joinWith (widening lub') f g
{-# INLINE joinWith #-}
deriving instance PreOrd (c x (Failure e y)) => PreOrd (FailureT e c x y)
deriving instance LowerBounded (c x (Failure e y)) => LowerBounded (FailureT e c x y)
......
......@@ -179,30 +179,24 @@ memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,inCache), o
getCache :: (ArrowChoice c, Profunctor c) => FixT s x y c () (Cache x y)
getCache = FixT get
{-# INLINE getCache #-}
setCache :: (ArrowChoice c, Profunctor c) => FixT s x y c (Map x (Terminating y)) ()
setCache = FixT put
{-# INLINE setCache #-}
localOldCache :: (ArrowChoice c, Profunctor c) => FixT s x y c x y -> FixT s x y c (Map x (Terminating y),x) y
localOldCache (FixT f) = FixT (local f)
{-# INLINE localOldCache #-}
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FixT s i o c) where
app = FixT $ lmap (\(FixT f,x) -> (f,x)) app
{-# INLINE app #-}
instance (Identifiable a, ArrowJoin c, ArrowChoice c) => ArrowJoin (FixT s a b c) where
joinWith lub f g = proc x -> do
y <- catchTerminating f -< x
y' <- catchTerminating g -< x
throwTerminating -< T.widening lub y y'
{-# INLINE joinWith #-}
instance (Identifiable a,Complete y,ArrowJoin c, ArrowChoice c, PreOrd (Underlying a b c x y)) => Complete (FixT s a b c x y) where
f g = joinWith () f g
{-# INLINE (⊔) #-}
type Underlying a b c x y = (c (Map a (Terminating b), (Map a (Terminating b), x)) (Map a (Terminating b), Terminating y))
deriving instance PreOrd (Underlying a b c x y) => PreOrd (FixT s a b c x y)
......
......@@ -33,23 +33,17 @@ newtype PowT c x y = PowT { runPowT :: c x (A.Pow y)}
instance (Profunctor c, Arrow c) => Profunctor (PowT c) where
dimap f g h = lift $ dimap f (fmap g) (unlift h)
{-# INLINE dimap #-}
lmap f h = lift $ lmap f (unlift h)
{-# INLINE lmap #-}
rmap g h = lift $ rmap (fmap g) (unlift h)
{-# INLINE rmap #-}
instance ArrowTrans PowT where
type Dom PowT x y = x
type Cod PowT x y = A.Pow y
lift = PowT