Commit 797ab08d authored by Sven Keidel's avatar Sven Keidel

use more generic program for implementing arrow transformers

parent 07cd4603
{ pkgs ? import <nixpkgs> {} }:
let
hsEnv = pkgs.haskellPackages.ghcWithPackages(p: with p; [
hsEnv = pkgs.haskell.packages.ghc863.ghcWithPackages(p: with p; [
stack
]);
......
......@@ -4,5 +4,7 @@ module Control.Arrow.Alloc where
import Control.Arrow
-- | Arrow-based interface for allocating addresses.
class Arrow c => ArrowAlloc x y c where
-- | Allocates a new address.
alloc :: c x y
......@@ -9,9 +9,9 @@ import GHC.Exts(Constraint)
-- | Arrow based interface to implement conditionals.
class Arrow c => ArrowCond v c | c -> v where
-- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint
-- | Performs a case distinction on the given value 'v'. In one case
-- the first continuation is called and in the other case the second
-- continuation. An abstract instance might join on the result type 'z'.
-- | @'if_' f g -< (v,(x,y))@ performs a case distinction on the given value @v@ and executes either @(f -< x)@ or @(g -< y)@. Abstract instances might join the results of @f@ and @g@.
if_ :: Join c (x,y) z => c x z -> c y z -> c (v, (x, y)) z
......@@ -6,5 +6,6 @@ import Control.Arrow
-- | Arrow-based interface that gives access to a constant value.
class Arrow c => ArrowConst r c | c -> r where
-- | Retrieve the constant value.
askConst :: c () r
......@@ -4,10 +4,11 @@ module Control.Arrow.Deduplicate where
import Control.Arrow
import Data.Hashable
-- | Arrow-based interface to deduplicate the result /set/ of a computation.
-- This is required by the 'Control.Arrow.Transformer.Abstract.Powerset.PowT'
-- arrow transformer.
class Arrow c => ArrowDeduplicate x y c where
dedup :: (Hashable y,Eq y) => c x y -> c x y
dedup :: c x y -> c x y
instance ArrowDeduplicate x y (->) where
dedup = returnA
......@@ -23,16 +23,20 @@ import GHC.Exts (Constraint)
-- | Arrow-based interface for interacting with environments.
class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where
-- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint
-- | Lookup a variable in the current environment. The first
-- continuation is called if the variable is in the enviroment, the
-- second if it is not.
-- | Lookup a variable in the current environment. If the
-- environment contains a binding of the variable, the first
-- continuation is called and the second computation otherwise.
lookup :: (Join c ((val,x),x) y) => c (val,x) y -> c x y -> c (var,x) y
-- | Retrieve the current environment.
getEnv :: c () env
-- | Extend an environment with a binding.
extendEnv :: c (var,val,env) env
-- | Run a computation with a modified environment.
localEnv :: c x y -> c (env,x) y
......
......@@ -17,30 +17,38 @@ import GHC.Exts(Constraint)
-- | Arrow-based interface for exception handling.
class Arrow c => ArrowExcept e c | c -> e where
-- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint
-- | Opertion that throws an exception that can be handled with 'catch'.
throw :: c e a
-- | Executes the first computation. If it fails, the exception is
-- handled with the second computation.
-- | @'catch' f g@ handles exceptions thrown in @f@ with @g@.
catch :: Join c (x,(x,e)) y => c x y -> c (x,e) y -> c x y
-- | Executes the second computation, no matter if the first
-- computation fails or not.
-- | @'finally' f g@ executes @g@, no matter if @f@ throws an exception.
finally :: c x y -> c x u -> c x y
-- | Simpler version of 'throw'.
throw' :: ArrowExcept () c => c a b
throw' = proc _ -> 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)
-- | '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' 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)
-- | Picks the first successful computation.
-- | 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)
-- | @'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.
tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) => c x y -> c () y -> c [x] y
tryFirst f g = proc l -> case l of
[] -> g -< ()
......
......@@ -13,11 +13,14 @@ import qualified Control.Monad.Except as M
-- | Arrow-based interface for computations that can fail.
class Arrow c => ArrowFail e c | c -> e where
-- | Throws an exception of type `e`.
-- | Causes the computation to fail. In contrast to
-- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from.
fail :: c e x
instance MonadError e m => ArrowFail e (Kleisli m) where
fail = Kleisli M.throwError
-- | Simpler version of 'fail'.
fail' :: ArrowFail () c => c a b
fail' = arr (const ()) >>> fail
......@@ -4,44 +4,17 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix,liftFix') where
{-# LANGUAGE DefaultSignatures #-}
module Control.Arrow.Fix(ArrowFix(..),liftFix) where
import Control.Arrow
import Control.Arrow.Trans
-- | Arrow-based interface for describing fixpoint computations.
class Arrow c => ArrowFix x y c where
-- | Computes the fixpoint of an arrow computation.
fix :: (c x y -> c x y) -> c x y
instance ArrowFix x y (->) where
fix f = f (fix f)
-- | Computes the type of the fixpoint cache used by 'LeastFixPoint'.
--
-- For the concrete interpreter use 'Fix' with '->' as last component of the arrow transformer stack:
-- @
-- Fix Expr Val (State Store (->)) x y = State Store (->) x y
-- @
--
-- For the abstract interpreter use 'Fix' with '~>' as last component of the arrow transformer stack:
-- @
-- Fix Expr Val (State Store (LeastFix () ())) x y = State Store (LeastFixPoint (Store,Expr) (Store,Val))
-- @
type family Fix x y (c :: * -> * -> *) :: * -> * -> *
type instance Fix a b (->) = (->)
-- | Generic lifting operation for the fixpoint operator 'fix'.
-- Example usage: fix = liftFix State runState
liftFix :: ArrowFix (f x) (g y) c
=> (t c x y -> c (f x) (g y))
-> (c (f x) (g y) -> t c x y)
-> ((t c x y -> t c x y) -> t c x y)
liftFix unwrap wrap f = wrap $ fix (unwrap . f . wrap)
-- | Generic lifting operation for the fixpoint operator 'fix'.
-- Example usage: fix = liftFix Except runExcept
liftFix' :: ArrowFix x (g y) c
=> (t c x y -> c x (g y))
-> (c x (g y) -> t c x y)
-> ((t c x y -> t c x y) -> t c x y)
liftFix' unwrap wrap f = wrap $ fix (unwrap . f . wrap)
liftFix :: (ArrowFix (Dom1 t x y) (Cod1 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)
module Control.Arrow.Lift where
import Control.Arrow
-- | Lifts an inner computation into an arrow transformer.
class ArrowLift c where
lift :: Arrow d => d x y -> c d x y
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Trans where
import Control.Arrow
type family Dom (c :: * -> * -> *) x y :: *
type family Cod (c :: * -> * -> *) x y :: *
type instance Dom (->) x y = x
type instance Cod (->) x y = y
class ArrowLift t where
lift' :: Arrow c => c x y -> t c x y
-- | Lifts an inner computation into an arrow transformer and vice versa.
class ArrowTrans t where
type Dom1 t x y :: *
type Cod1 t x y :: *
lift :: Arrow c => c (Dom1 t x y) (Cod1 t x y) -> t c x y
unlift :: Arrow c => t c x y -> c (Dom1 t x y) (Cod1 t x y)
......@@ -17,7 +17,7 @@ import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Transformer.Const
......@@ -52,7 +52,7 @@ runEnvT alloc f =
in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f')
instance ArrowLift (EnvT var addr val) where
lift f = EnvT (lift (lift f))
lift' f = EnvT (lift' (lift' f))
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) =>
ArrowEnv var val (Map var addr val) (EnvT var addr val c) where
......@@ -64,18 +64,17 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) =>
JustNothing val -> joined f g -< ((val,x),x)
Nothing -> g -< x
getEnv = EnvT ask
extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift $ M.insertBy alloc
extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc
localEnv (EnvT f) = EnvT $ local f
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift ask
ask = lift' ask
local (EnvT (ConstT (StaticT f))) =
EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (runReaderT (f alloc))
instance ArrowApply c => ArrowApply (EnvT var addr val c) where
app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app
type instance Fix x y (EnvT var addr val c) = EnvT var addr val (Fix ((Map var addr val),x) y c)
deriving instance ArrowFix ((Map var addr val),x) y c => ArrowFix x y (EnvT var addr val c)
deriving instance Arrow c => Category (EnvT var addr val c)
deriving instance Arrow c => Arrow (EnvT var addr val c)
......
......@@ -13,7 +13,7 @@ import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Except as Exc
......@@ -29,11 +29,17 @@ import Data.Order hiding (lub)
-- E.g. allows to join a computation of type 'c x [y]'.
newtype CompletionT c x y = CompletionT { runCompletionT :: c x (FreeCompletion y) }
instance ArrowTrans CompletionT where
type Dom1 CompletionT x y = x
type Cod1 CompletionT x y = FreeCompletion y
lift = CompletionT
unlift = runCompletionT
instance ArrowLift CompletionT where
lift f = CompletionT (f >>> arr Lower)
lift' f = CompletionT (f >>> arr Lower)
instance ArrowChoice c => Category (CompletionT c) where
id = lift id
id = lift' id
CompletionT f . CompletionT g = CompletionT $ proc x -> do
g' <- g -< x
case g' of
......@@ -41,9 +47,9 @@ instance ArrowChoice c => Category (CompletionT c) where
Top -> returnA -< Top
instance ArrowChoice c => Arrow (CompletionT c) where
arr = lift . arr
first (CompletionT f) = CompletionT $ first f >>^ strength1
second (CompletionT f) = CompletionT $ second f >>^ strength2
arr = lift' . arr
first f = lift $ first (unlift f) >>^ strength1
second f = lift $ second (unlift f) >>^ strength2
instance ArrowChoice c => ArrowChoice (CompletionT c) where
left (CompletionT f) = CompletionT $ left f >>^ strength1
......@@ -53,38 +59,37 @@ instance (ArrowApply c, ArrowChoice c) => ArrowApply (CompletionT c) where
app = CompletionT $ first runCompletionT ^>> app
instance (ArrowChoice c, ArrowState s c) => ArrowState s (CompletionT c) where
get = lift get
put = lift put
get = lift' get
put = lift' put
instance (ArrowChoice c, ArrowFail e c) => ArrowFail e (CompletionT c) where
fail = lift fail
fail = lift' fail
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (CompletionT c) where
ask = lift ask
local (CompletionT f) = CompletionT (local f)
ask = lift' ask
local f = lift (local (unlift f))
instance (ArrowChoice c, ArrowEnv var val env c) => ArrowEnv var val env (CompletionT c) where
type Join (CompletionT c) x y = Env.Join c x (FreeCompletion y)
lookup (CompletionT f) (CompletionT g) = CompletionT (lookup f g)
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (CompletionT f) = CompletionT (localEnv f)
type Join (CompletionT c) x y = Env.Join c (Dom1 CompletionT x y) (Cod1 CompletionT x y)
lookup f g = lift (lookup (unlift f) (unlift g))
getEnv = lift' getEnv
extendEnv = lift' extendEnv
localEnv f = lift (localEnv (unlift f))
instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (CompletionT c) where
type Join (CompletionT c) x y = Exc.Join c x (FreeCompletion y)
throw = lift throw
catch (CompletionT f) (CompletionT g) = CompletionT $ catch f g
finally (CompletionT f) (CompletionT g) = CompletionT $ finally f g
type Join (CompletionT c) x y = Exc.Join c (Dom1 CompletionT x y) (Cod1 CompletionT x y)
throw = lift' throw
catch f g = lift $ catch (unlift f) (unlift g)
finally f g = lift $ finally (unlift f) (unlift g)
instance ArrowChoice c => ArrowDeduplicate x y (CompletionT c) where
dedup = returnA
type instance Fix x y (CompletionT c) = CompletionT (Fix x (FreeCompletion y) c)
instance (ArrowChoice c, ArrowFix x (FreeCompletion y) c) => ArrowFix x y (CompletionT c) where
fix = liftFix' runCompletionT CompletionT
fix = liftFix
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where
joinWith lub (CompletionT f) (CompletionT g) = CompletionT $ joinWith join f g
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
......
......@@ -16,7 +16,7 @@ import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Transformer.Reader
......@@ -37,13 +37,12 @@ newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b)
runContourT :: Arrow c => Int -> ContourT lab c a b -> c a b
runContourT k (ContourT (ReaderT f)) = (\a -> (empty k,a)) ^>> f
type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c)
instance (ArrowFix x y c, ArrowApply c, HasLabel x lab) => 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 => c x y -> ContourT lab c x y
wrap = lift
wrap = lift'
unwrap :: (HasLabel x lab, Arrow c) => CallString lab -> ContourT lab c x y -> c x y
unwrap c (ContourT (ReaderT f')) = proc x -> do
......@@ -58,9 +57,10 @@ instance ArrowApply c => ArrowApply (ContourT lab c) where
app = ContourT $ (\(ContourT f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift ask
local (ContourT (ReaderT f)) = ContourT (ReaderT ((\(c,(r,x)) -> (r,(c,x))) ^>> local f))
ask = lift' ask
local f = lift ((\(c,(r,x)) -> (r,(c,x))) ^>> local (unlift f))
deriving instance ArrowTrans (ContourT lab)
deriving instance Arrow c => Category (ContourT lab c)
deriving instance Arrow c => Arrow (ContourT lab c)
deriving instance ArrowLift (ContourT lab)
......
......@@ -25,7 +25,7 @@ import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Lift
import Control.Arrow.Trans
import Control.Arrow.Environment
import Control.Arrow.Fix
......@@ -33,8 +33,8 @@ import Control.Arrow.Abstract.Join
newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y)
runEnvT :: (Arrow c) => EnvT var val c x y -> c (Map var val,x) y
runEnvT (EnvT (ReaderT f)) = f
runEnvT :: Arrow c => EnvT var val c x y -> c (Map var val,x) y
runEnvT = unlift
runEnvT' :: (Arrow c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' f = first M.fromList ^>> runEnvT f
......@@ -55,15 +55,14 @@ instance ArrowApply c => ArrowApply (EnvT var val c) where
app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift ask
local (EnvT (ReaderT f)) = EnvT (ReaderT ((\(env,(r,x)) -> (r,(env,x))) ^>> local f))
type instance Fix x y (EnvT var val c) = EnvT var val (Fix (Map var val,x) y c)
ask = lift' ask
local f = lift $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (unlift f)
deriving instance ArrowJoin c => ArrowJoin (EnvT var val c)
deriving instance ArrowFix (Map var val,x) y c => ArrowFix x y (EnvT var val c)
deriving instance Arrow c => Category (EnvT var val c)
deriving instance Arrow c => Arrow (EnvT var val c)
deriving instance ArrowTrans (EnvT var val)
deriving instance ArrowLift (EnvT var val)
deriving instance ArrowChoice c => ArrowChoice (EnvT var val c)
deriving instance ArrowState s c => ArrowState s (EnvT var val c)
......
......@@ -15,7 +15,7 @@ import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
......@@ -30,15 +30,21 @@ import Data.Order
newtype ExceptT e c x y = ExceptT { runExceptT :: c x (Error e y)}
instance ArrowTrans (ExceptT e) where
type Dom1 (ExceptT e) x y = x
type Cod1 (ExceptT e) x y = Error e y
lift = ExceptT
unlift = runExceptT
instance ArrowLift (ExceptT e) where
lift f = ExceptT (f >>> arr Success)
lift' f = ExceptT (f >>> arr Success)
instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) where
id = lift id
ExceptT f . ExceptT g = ExceptT $ proc x -> do
y <- g -< x
id = lift' id
f . g = lift $ proc x -> do
y <- unlift g -< x
case y of
Success y' -> f -< y'
Success y' -> unlift f -< y'
Fail e -> returnA -< Fail e
SuccessOrFail e y' -> do
-- Ideally we would like to write '(returnA -< Fail e) ⊔ (f -< y)',
......@@ -50,69 +56,69 @@ instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (ExceptT e c) wher
Success z -> SuccessOrFail e z
Fail e' -> Fail (e e')
SuccessOrFail e' z -> SuccessOrFail (e e') z)
id f -< (Fail e,y')
id (unlift f) -< (Fail e,y')
instance (ArrowChoice c, ArrowJoin c, Complete e) => Arrow (ExceptT e c) where
arr f = lift (arr f)
first (ExceptT f) = ExceptT $ first f >>^ strength1
second (ExceptT f) = ExceptT $ second f >>^ strength2
arr f = lift' (arr f)
first f = lift $ first (unlift f) >>^ strength1
second f = lift $ second (unlift f) >>^ strength2
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowChoice (ExceptT e c) where
left (ExceptT f) = ExceptT $ left f >>^ strength1
right (ExceptT f) = ExceptT $ right f >>^ strength2
left f = lift $ left (unlift f) >>^ strength1
right f = lift $ right (unlift f) >>^ strength2
instance (Complete e, ArrowJoin c, ArrowApply c, ArrowChoice c) => ArrowApply (ExceptT e c) where
app = ExceptT $ first runExceptT ^>> app
app = lift $ first unlift ^>> app
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowState s c) => ArrowState s (ExceptT e c) where
get = lift get
put = lift put
get = lift' get
put = lift' 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 x (Error e y)
type Join (ExceptT e c) x y = Store.Join c (Dom1 (ExceptT e) x y) (Cod1 (ExceptT e) x y)
read (ExceptT f) (ExceptT g) = ExceptT $ read f g
write = lift write
write = lift' write
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFail f c) => ArrowFail f (ExceptT e c) where
fail = lift fail
fail = lift' fail
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowReader r c) => ArrowReader r (ExceptT e c) where
ask = lift ask
local (ExceptT f) = ExceptT (local f)
ask = lift' ask
local f = lift (local (unlift f))
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 x (Error e y)
lookup (ExceptT f) (ExceptT g) = ExceptT $ lookup f g
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (ExceptT f) = ExceptT (localEnv f)
type Join (ExceptT e c) x y = Env.Join c (Dom1 (ExceptT e) x y) (Cod1 (ExceptT e) x y)
lookup f g = lift $ lookup (unlift f) (unlift g)
getEnv = lift' getEnv
extendEnv = lift' extendEnv
localEnv f = lift (localEnv (unlift f))
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 = ExceptT $ arr Fail
catch (ExceptT f) (ExceptT g) = ExceptT $ proc x -> do
e <- f -< x
throw = lift $ arr Fail
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) g -< (y,(x,er))
Fail er -> g -< (x,er)
finally (ExceptT f) (ExceptT g) = ExceptT $ proc x -> do
e <- f -< x
g -< x
SuccessOrFail er y -> joined (arr Success) (unlift g) -< (y,(x,er))
Fail er -> unlift g -< (x,er)
finally f g = lift $ proc x -> do
e <- unlift f -< x
unlift g -< x
returnA -< e
type instance Fix x y (ExceptT e c) = ExceptT e (Fix x (Error e y) c)
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (ExceptT e c) where
fix = liftFix' runExceptT ExceptT
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFix (Dom1 (ExceptT e) x y) (Cod1 (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c) where
fix = liftFix
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowDeduplicate x y (ExceptT e c) where
dedup = returnA
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowConst r c) => ArrowConst r (ExceptT e c) where
askConst = lift askConst
askConst = lift' askConst
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) where
joinWith lub' (ExceptT f) (ExceptT g) = ExceptT $ joinWith (\r1 r2 -> case (r1, r2) of
joinWith lub' f g = ExceptT $ joinWith (\r1 r2 -> case (r1, r2) of
(Success y1, Success y2) -> Success (y1 `lub'` y2)
(Success y1, SuccessOrFail e y2) -> SuccessOrFail e (y1 `lub'` y2)
(Success y, Fail e) -> SuccessOrFail e y
......@@ -122,7 +128,7 @@ instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ExceptT e c) whe
(Fail e, Success y) -> SuccessOrFail e y
(Fail e1, SuccessOrFail e2 y) -> SuccessOrFail (e1 e2) y
(Fail e1, Fail e2) -> Fail (e1 e2)
) f g
) (unlift f) (unlift g)
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)
......
......@@ -8,7 +8,7 @@
{-# LANGUAGE DataKinds #-}
module Control.Arrow.Transformer.Abstract.Failure(FailureT(..)) where
import Prelude hiding (id,(.),lookup)
import Prelude hiding (id,(.),lookup,read)
import Control.Arrow
import Control.Arrow.Const
......@@ -16,9 +16,10 @@ import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc
import Control.Arrow.Abstract.Join
import Control.Category
......@@ -31,67 +32,70 @@ import Data.Identifiable
-- | Describes computations that can fail.
newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) }
instance ArrowChoice c => ArrowFail e (FailureT e c) where
fail = lift $ arr Fail