Commit 377eeb33 authored by Sven Keidel's avatar Sven Keidel

refactor exceptions

There are now two abstract domains for exceptions, `PropagateError`,
which is used in case the language only _propagates_ the error and
`HandleError` in case the language allows to _handle_ excepctions.
Furthermore, I unified the interfaces for `ArrowTry` and `ArrowTryCatch`.
parent c92b6e26
module Control.Arrow.Abstract.Join where
import Prelude hiding ((.))
import Control.Arrow
class Arrow c => ArrowJoin c where
-- | Join two arrow computation with the provided upper bound operator.
--
-- Laws:
-- @
-- joinWith (⊔) f g = joined f g
-- @
joinWith :: (z -> z -> z) -> c x z -> c u z -> c (x,u) z
instance ArrowJoin (->) where
joinWith lub f g = \(x,y) -> lub (f x) (g y)
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Except where
import Prelude hiding (id,(.))
import Control.Category
import Control.Arrow
import Control.Arrow.Fail
import Control.Arrow.Utils
-- | Arrow-based interface for exception handling.
class ArrowFail e c => ArrowExcept x y e c | c -> e where
-- | Executes the first computation. If it fails, the exception is
-- handled with the second computation.
tryCatchA :: c x y -> c (x,e) y -> c x y
tryCatchA' :: ArrowExcept x y e c => c x y -> c e y -> c x y
tryCatchA' f g = tryCatchA f (pi2 >>> g)
-- | Executes the second computation, no matter if the first
-- computation fails or not.
finally :: (ArrowChoice c, ArrowExcept x (Either x z) e c) => c x y -> c x z -> c x z
finally f g = tryCatchA (proc x -> do _ <- f -< x; returnA -< Left x)
(proc (x,_) -> do y <- g -< x; returnA -< Right y)
>>> (g ||| id)
-- | 'tryA f g h' Executes 'f', if it succeeds the result is passed to
-- 'g', if it fails the original input is passed to 'h'.
tryA :: ArrowExcept x z e c => c x y -> c y z -> c x z -> c x z
tryA f g h = tryCatchA (f >>> g) (pi1 >>> h)
-- | Picks the first successful computation.
(<+>) :: ArrowExcept x y e c => c x y -> c x y -> c x y
f <+> g = tryCatchA f (pi1 >>> g)
tryFirst :: (ArrowChoice c, ArrowExcept (x, [x]) y e c) => c x y -> c () y -> c [x] y
tryFirst f g = proc l -> case l of
[] -> g -< ()
a:as -> tryA (f . pi1) id (tryFirst f g . pi2) -< (a,as)
-- | A computation that always succeeds
success :: ArrowExcept a a e c => c a a
success = id
......@@ -13,6 +13,7 @@ import Control.Arrow
import Control.Arrow.Abstract.Alloc
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
......@@ -23,7 +24,6 @@ import Prelude hiding ((.),id)
import Data.Order
import Data.Identifiable
import Data.Abstract.Error
import Data.Abstract.Environment (Env)
import qualified Data.Abstract.Environment as E
import Data.Abstract.Store (Store)
......@@ -58,8 +58,8 @@ instance (Show var, Identifiable var, Identifiable addr, Complete val, ArrowChoi
ArrowEnv var val (Env var addr,Store addr val) (Environment var addr val c) where
lookup = Environment $ Reader $ proc ((env,store),x) -> do
case do {addr <- E.lookup x env; S.lookup addr store} of
Success v -> returnA -< v
Fail _ -> failA -< printf "Variable %s not bound" (show x)
Just v -> returnA -< v
Nothing -> failA -< printf "Variable %s not bound" (show x)
getEnv = Environment askA
-- | If an existing address is allocated for a new variable binding,
-- the new value is joined with the existing value at this address.
......@@ -84,6 +84,8 @@ deriving instance Arrow c => Arrow (Environment var addr val c)
deriving instance ArrowChoice c => ArrowChoice (Environment var addr val c)
deriving instance ArrowState s c => ArrowState s (Environment var addr val c)
deriving instance ArrowFail e c => ArrowFail e (Environment var addr val c)
deriving instance ArrowExcept ((Env var addr,Store addr val),x) y e c => ArrowExcept x y e (Environment var addr val c)
deriving instance PreOrd (c ((Env var addr,Store addr val),x) y) => PreOrd (Environment var addr val c x y)
deriving instance Complete (c ((Env var addr,Store addr val),x) y) => Complete (Environment var addr val c x y)
deriving instance CoComplete (c ((Env var addr,Store addr val),x) y) => CoComplete (Environment var addr val c x y)
......
......@@ -15,12 +15,13 @@ import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Try
import Control.Arrow.Except
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Abstract.FreeCompletion
import Data.Monoidal
import Data.Order
import Data.Order hiding (lub)
-- | Allows to describe computations over non-completely ordered types.
-- E.g. allows to join a computation of type 'c x [y]'.
......@@ -53,7 +54,7 @@ instance (ArrowChoice c, ArrowState s c) => ArrowState s (Completion c) where
getA = lift getA
putA = lift putA
instance (ArrowChoice c, ArrowFail () c) => ArrowFail () (Completion c) where
instance (ArrowChoice c, ArrowFail e c) => ArrowFail e (Completion c) where
failA = lift failA
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (Completion c) where
......@@ -66,16 +67,18 @@ instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (Completion c)
extendEnv = lift extendEnv
localEnv (Completion f) = Completion (localEnv f)
instance ArrowChoice c => ArrowTry x y z (Completion c) where
tryA (Completion f) (Completion g) (Completion h) = Completion $ proc x -> do
e <- f -< x
case e of
Lower y -> g -< y
Top -> h -< x
instance (ArrowChoice c, ArrowExcept x (FreeCompletion y) e c) => ArrowExcept x y e (Completion c) where
tryCatchA (Completion f) (Completion g) = Completion $ tryCatchA f g
instance ArrowChoice c => ArrowDeduplicate (Completion c) where
dedupA = returnA
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (Completion c) where
joinWith lub (Completion f) (Completion g) = Completion $ joinWith join f g
where join (Lower x) (Lower y) = Lower (lub x y)
join Top _ = Top
join _ Top = Top
deriving instance PreOrd (c x (FreeCompletion y)) => PreOrd (Completion c x y)
deriving instance LowerBounded (c x (FreeCompletion y)) => LowerBounded (Completion c x y)
deriving instance Complete (c x (FreeCompletion y)) => Complete (Completion c x y)
......
......@@ -14,6 +14,7 @@ import Control.Arrow
import Control.Arrow.Abstract.Alloc
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
......@@ -62,8 +63,9 @@ deriving instance Arrow c => Arrow (Contour c)
deriving instance ArrowLift Contour
deriving instance ArrowChoice c => ArrowChoice (Contour c)
deriving instance ArrowState s c => ArrowState s (Contour c)
deriving instance ArrowFail e c => ArrowFail e (Contour c)
deriving instance ArrowEnv x y env c => ArrowEnv x y env (Contour c)
deriving instance ArrowFail e c => ArrowFail e (Contour c)
deriving instance ArrowExcept (CallString,x) y e c => ArrowExcept x y e (Contour c)
deriving instance PreOrd (c (CallString,x) y) => PreOrd (Contour c x y)
deriving instance LowerBounded (c (CallString,x) y) => LowerBounded (Contour c x y)
......
......@@ -13,7 +13,6 @@ import Prelude hiding ((.))
import Data.Hashable
import Data.Order
import Data.Identifiable
import Data.Abstract.Error
import Data.Abstract.Environment (Env)
import qualified Data.Abstract.Environment as E
......@@ -23,6 +22,7 @@ import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Lift
import Control.Arrow.Environment
import Control.Arrow.Fix
......@@ -37,8 +37,8 @@ runEnvironment (Environment (Reader f)) = first E.fromList ^>> f
instance (Show var, Identifiable var, ArrowChoice c, ArrowFail String c) => ArrowEnv var val (Env var val) (Environment var val c) where
lookup = Environment $ Reader $ proc (env,x) -> do
case E.lookup x env of
Success y -> returnA -< y
Fail _ -> failA -< printf "Variable %s not bound" (show x)
Just y -> returnA -< y
Nothing -> failA -< printf "Variable %s not bound" (show x)
getEnv = Environment askA
extendEnv = arr $ \(x,y,env) -> E.insert x y env
localEnv (Environment f) = Environment (localA f)
......@@ -51,6 +51,7 @@ instance ArrowReader r c => ArrowReader r (Environment var val c) where
localA (Environment (Reader f)) = Environment (Reader ((\(env,(r,x)) -> (r,(env,x))) ^>> localA f))
type instance Fix x y (Environment var val c) = Environment var val (Fix (Env var val,x) y c)
deriving instance ArrowFix (Env var val,x) y c => ArrowFix x y (Environment var val c)
deriving instance Arrow c => Category (Environment var val c)
deriving instance Arrow c => Arrow (Environment var val c)
......@@ -58,6 +59,8 @@ deriving instance ArrowLift (Environment var val)
deriving instance ArrowChoice c => ArrowChoice (Environment var val c)
deriving instance ArrowState s c => ArrowState s (Environment var val c)
deriving instance ArrowFail e c => ArrowFail e (Environment var val c)
deriving instance ArrowExcept (Env var val,x) y e c => ArrowExcept x y e (Environment var val c)
deriving instance PreOrd (c (Env var val,x) y) => PreOrd (Environment var val c x y)
deriving instance Complete (c (Env var val,x) y) => Complete (Environment var val c x y)
deriving instance CoComplete (c (Env var val,x) y) => CoComplete (Environment var val c x y)
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GADTs #-}
module Control.Arrow.Transformer.Abstract.HandleExcept(Except(..)) where
import Prelude hiding (id,lookup,(.))
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Except
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Abstract.HandleError
import Data.Monoidal
import Data.Order
newtype Except e c x y = Except { runExcept :: c x (Error e y)}
instance ArrowLift (Except e) where
lift f = Except (f >>> arr Success)
instance (ArrowChoice c, ArrowJoin c, Complete e) => Category (Except e c) where
id = lift id
Except f . Except g = Except $ proc x -> do
y <- g -< x
case y of
Success y' -> f -< y'
Fail e -> returnA -< Fail e
SuccessOrFail e y' -> do
-- Ideally we would like to write '(returnA -< Fail e) ⊔ (f -< y)',
-- however this is not possible, because the result type of
-- 'f', 'UncertainError e z', is not 'Complete' because 'z' is not
-- 'Complete'. However, in '(returnA -< Fail e) ⊔ (f -< y)' we
-- actually never join to values of type 'z'.
joinWith (\(Fail e) er -> case er of
Success z -> SuccessOrFail e z
Fail e' -> Fail (e e')
SuccessOrFail e' z -> SuccessOrFail (e e') z)
id f -< (Fail e,y')
instance (ArrowChoice c, ArrowJoin c, Complete e) => Arrow (Except e c) where
arr f = lift (arr f)
first (Except f) = Except $ first f >>^ strength1
second (Except f) = Except $ second f >>^ strength2
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowChoice (Except e c) where
left (Except f) = Except $ left f >>^ strength1
right (Except f) = Except $ right f >>^ strength2
instance (Complete e, ArrowJoin c, ArrowApply c, ArrowChoice c) => ArrowApply (Except e c) where
app = Except $ first runExcept ^>> app
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowState s c) => ArrowState s (Except e c) where
getA = lift getA
putA = lift putA
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowFail e (Except e c) where
failA = Except $ arr Fail
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowReader r c) => ArrowReader r (Except e c) where
askA = lift askA
localA (Except f) = Except (localA f)
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (Except e c) where
lookup = lift lookup
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (Except f) = Except (localEnv f)
instance (ArrowChoice c, Complete e, ArrowJoin c, Complete (c (y,(x,e)) (Error e y))) => ArrowExcept x y e (Except e c) where
tryCatchA (Except f) (Except g) = Except $ proc x -> do
e <- 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)
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowDeduplicate (Except e c) where
dedupA = returnA
deriving instance PreOrd (c x (Error e y)) => PreOrd (Except e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (Except e c x y)
deriving instance Complete (c x (Error e y)) => Complete (Except e c x y)
deriving instance CoComplete (c x (Error e y)) => CoComplete (Except e c x y)
deriving instance UpperBounded (c x (Error e y)) => UpperBounded (Except e c x y)
......@@ -20,14 +20,15 @@ import Data.Function (fix)
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Abstract.Terminating
import Data.Order
import Data.Order hiding (lub)
import Data.Identifiable
import Data.Monoidal
import Data.Maybe
import Data.Abstract.Error
import Data.Abstract.Store (Store)
import qualified Data.Abstract.Store as S
import Data.Abstract.Widening
......@@ -126,9 +127,9 @@ instance (Show x, Show y, Identifiable x, Widening y)
memoize :: (Show x, Show y, Identifiable x, Widening y) => LeastFixPointArrow x y x y -> LeastFixPointArrow x y x y
memoize (LeastFixPointArrow f) = LeastFixPointArrow $ \((inCache, outCache),x) -> do
case trace (printf "\tmemoize -< %s" (show x)) (S.lookup x outCache) of
Success y -> trace (printf "\t%s <- memoize -< %s" (show y) (show x)) (outCache,y)
Fail _ ->
let yOld = fromError bottom (S.lookup x inCache)
Just y -> trace (printf "\t%s <- memoize -< %s" (show y) (show x)) (outCache,y)
Nothing ->
let yOld = fromMaybe bottom (S.lookup x inCache)
outCache' = S.insert x yOld outCache
(outCache'',y) = trace (printf "\tf -< %s" (show x)) (f ((inCache, outCache'),x))
outCache''' = S.insertWith (flip ()) x y outCache''
......@@ -179,7 +180,19 @@ instance ArrowLoop (LeastFixPointArrow i o) where
instance ArrowApply (LeastFixPointArrow i o) where
app = LeastFixPointArrow $ (\(io,(LeastFixPointArrow f,x)) -> (f,(io,x))) ^>> app
instance (Identifiable i, Complete o) => ArrowJoin (LeastFixPointArrow i o) where
joinWith lub (LeastFixPointArrow f) (LeastFixPointArrow g) = LeastFixPointArrow $ \((i,o),(x,u)) ->
let (o',y) = f ((i,o),x)
(o'',v) = g ((i,o),u)
in (o' o'',case (y,v) of
(Terminating y',Terminating v') -> Terminating (lub y' v')
(Terminating y',NonTerminating) -> Terminating y'
(NonTerminating,Terminating v') -> Terminating v'
(NonTerminating,NonTerminating) -> NonTerminating)
deriving instance (Identifiable a, PreOrd b, PreOrd y) => PreOrd (LeastFixPointArrow a b x y)
-- TODO: Figure out if it is sound to thread the fixpoint cache while computing the least upper bound of two arrow computations.
deriving instance (Identifiable a, Complete b, Complete y) => Complete (LeastFixPointArrow a b x y)
deriving instance (Identifiable a, CoComplete b, CoComplete y) => CoComplete (LeastFixPointArrow a b x y)
deriving instance (Identifiable a, PreOrd b, PreOrd y) => LowerBounded (LeastFixPointArrow a b x y)
......
......@@ -5,7 +5,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Except(Except(..)) where
module Control.Arrow.Transformer.Abstract.PropagateExcept(Except(..)) where
import Prelude hiding (id,(.),lookup)
......@@ -17,17 +17,16 @@ import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Try
import Control.Category
import Data.Abstract.Error
import Data.Abstract.PropagateError
import Data.Order
import Data.Monoidal
import Data.Identifiable
-- | Describes computations that can fail. Usefull for implementing analyses for
-- languages that only propagate error and /do not/ handle it. For
-- languages that handle error, use 'PreciseExcept'.
-- languages that handle error, use 'Except'.
newtype Except e c x y = Except { runExcept :: c x (Error e y) }
instance ArrowLift (Except e) where
......@@ -79,16 +78,19 @@ type instance Fix x y (Except e c) = Except e (Fix x (Error e y) c)
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (Except e c) where
fixA f = Except (fixA (runExcept . f . Except))
instance (ArrowChoice c, Complete (c (y,x) (Error e z))) => ArrowTry x y z (Except e c) where
-- | In case the first computation succeeds, the results of the
-- second and third computation are joined. The reason is that the
-- ordering for 'Error' is 'Fail ⊑ Success', i.e., 'Success'
-- represents all concrete computations that succeed or fail.
tryA (Except f) (Except g) (Except h) = Except $ proc x -> do
{-
There is no `ArrowExcept` instance for `Except` on purpose. This is how it would look like.
instance (ArrowChoice c, UpperBounded e, Complete (c (y,(x,e)) (Error e y))) => ArrowExcept x y e (Except e c) where
tryCatchA (Except f) (Except g) = Except $ proc x -> do
e <- f -< x
case e of
Success y -> joined g h -< (y,x)
Fail _ -> h -< x
-- Since Fail ⊑ Success, 'Success' also represents the case 'f'
-- could have failed. This means we also have to run the
-- exception handler 'g' with all exceptions (represented by ⊤).
Success y -> joined (arr Success) g -< (y,(x,top))
Fail er -> g -< (x,er)
-}
instance (Identifiable e, ArrowChoice c, ArrowDeduplicate c) => ArrowDeduplicate (Except e c) where
dedupA (Except f) = Except (dedupA f)
......
......@@ -19,7 +19,6 @@ import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Control.Category
import Data.Abstract.Error
import Data.Abstract.Store (Store)
import qualified Data.Abstract.Store as S
import Data.Order
......@@ -42,8 +41,8 @@ instance (Show var, Identifiable var, ArrowFail String c, ArrowChoice c, Complet
ArrowStore var val lab (StoreArrow var val c) where
read =
StoreArrow $ State $ proc (s,(var,_)) -> case S.lookup var s of
Success v -> joined returnA (proc var -> failA -< printf "Variable %s not bound" (show var)) -< ((s,v),var)
Fail _ -> failA -< printf "Variable %s not bound" (show var)
Just v -> joined returnA (proc var -> failA -< printf "Variable %s not bound" (show var)) -< ((s,v),var)
Nothing -> failA -< printf "Variable %s not bound" (show var)
write = StoreArrow (State (arr (\(s,(x,v,_)) -> (S.insert x v s,()))))
instance ArrowState s c => ArrowState s (StoreArrow var val c) where
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Abstract.Uncertain(Uncertain(..)) where
import Prelude hiding (id,lookup)
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Try
import Control.Category
import Data.Abstract.UncertainResult
import Data.Monoidal
import Data.Order
newtype Uncertain c x y = Uncertain { runUncertain :: c x (UncertainResult y)}
instance ArrowLift Uncertain where
lift f = Uncertain (f >>> arr Success)
instance ArrowChoice c => Category (Uncertain c) where
id = lift id
Uncertain f . Uncertain g = Uncertain $ proc x -> do
g' <- g -< x
case g' of
Success a -> f -< a
SuccessOrFail a -> do
f' <- f -< a
case f' of
-- At first glance, this looks unsound because the effects or fail
-- might be passed on to the failure case. However, the only effect
-- currently passed on is FreeCompletion. But if f produces Top,
-- then f \/ failA produces Top, and so does the current solution.
Success a' -> returnA -< SuccessOrFail a'
_ -> returnA -< f'
Fail -> returnA -< Fail
instance ArrowChoice c => Arrow (Uncertain c) where
arr f = lift (arr f)
first (Uncertain f) = Uncertain $ first f >>^ strength1
second (Uncertain f) = Uncertain $ second f >>^ strength2
instance ArrowChoice c => ArrowChoice (Uncertain c) where
left (Uncertain f) = Uncertain $ left f >>^ strength1
right (Uncertain f) = Uncertain $ right f >>^ strength2
instance (ArrowApply c, ArrowChoice c) => ArrowApply (Uncertain c) where
app = Uncertain $ first runUncertain ^>> app
instance (ArrowChoice c, ArrowState s c) => ArrowState s (Uncertain c) where
getA = lift getA
putA = lift putA
instance ArrowChoice c => ArrowFail () (Uncertain c) where
failA = Uncertain $ arr (const Fail)
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (Uncertain c) where
askA = lift askA
localA (Uncertain f) = Uncertain (localA f)
instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (Uncertain c) where
lookup = lift lookup
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (Uncertain f) = Uncertain (localEnv f)
instance (ArrowChoice c, Complete (c (y,x) (UncertainResult z))) => ArrowTry x y z (Uncertain c) where
tryA (Uncertain f) (Uncertain g) (Uncertain h) = Uncertain $ proc x -> do
e <- f -< x
case e of
Success y -> g -< y
SuccessOrFail y -> joined g h -< (y,x)
Fail -> h -< x
instance ArrowChoice c => ArrowDeduplicate (Uncertain c) where
dedupA = returnA
deriving instance PreOrd (c x (UncertainResult y)) => PreOrd (Uncertain c x y)
deriving instance LowerBounded (c x (UncertainResult y)) => LowerBounded (Uncertain c x y)
deriving instance Complete (c x (UncertainResult y)) => Complete (Uncertain c x y)
deriving instance CoComplete (c x (UncertainResult y)) => CoComplete (Uncertain c x y)
deriving instance UpperBounded (c x (UncertainResult y)) => UpperBounded (Uncertain c x y)
......@@ -12,19 +12,20 @@ import Prelude hiding (id,(.),lookup,read)
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment
import Control.Arrow.TryCatch
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Try
import Control.Arrow.Except
import Control.Arrow.Utils
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Hashable
import Data.Order
import Data.Order hiding (lub)
import Data.Monoidal
newtype State s c x y = State { runState :: c (s,x) (s,y) }
......@@ -92,15 +93,17 @@ type instance Fix x y (State s c) = State s (Fix (s,x) (s,y) c)
instance (ArrowLoop c, ArrowFix (s,x) (s,y) c) => ArrowFix x y (State s c) where
fixA f = State (fixA (runState . f . State))
instance (ArrowLoop c, ArrowTry (s,x) (s,y) (s,z) c) => ArrowTry x y z (State s c) where
tryA (State f) (State g) (State h) = State $ tryA f g h
instance (ArrowChoice c, ArrowLoop c, ArrowTryCatch (s,e) (s,x) (s,y) (s,z) c) => ArrowTryCatch e x y z (State s c) where
tryCatchA (State f) (State g) (State h) = State $ tryCatchA f g h
instance (ArrowLoop c, ArrowExcept (s,x) (s,y) e c) => ArrowExcept x y e (State s c) where
tryCatchA (State f) (State g) = State $ tryCatchA f (from assoc ^>> g)
instance (Eq s, Hashable s, ArrowLoop c, ArrowDeduplicate c) => ArrowDeduplicate (State s c) where
dedupA (State f) = State (dedupA f)
instance (ArrowJoin c, Complete s, ArrowLoop c) => ArrowJoin (State s c) where
joinWith lub (State f) (State g) =
State $ (\(s,(x,y)) -> ((s,x),(s,y))) ^>> joinWith (\(s1,z1) (s2,z2) -> (s1s2,lub z1 z2)) f g
deriving instance PreOrd (c (s,x) (s,y)) => PreOrd (State s c x y)
deriving instance LowerBounded (c (s,x) (s,y)) => LowerBounded (State s c x y)
deriving instance Complete (c (s,x) (s,y)) => Complete (State s c x y)
......
......@@ -12,20 +12,18 @@ import Prelude hiding ((.))
import Data.Hashable
import Data.Identifiable
import Data.Concrete.Error
import Data.Concrete.Environment (Env)
import qualified Data.Concrete.Environment as E
import Control.Category
import Control.Arrow
import Control.Arrow.TryCatch
import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Lift
import Control.Arrow.Try
import Control.Arrow.Except
import Control.Arrow.Environment
import Control.Arrow.Fix
......@@ -42,8 +40,8 @@ instance (Show var, Identifiable var, ArrowChoice c, ArrowFail String c) =>
lookup = proc x -> do
env <- getEnv -< ()
case E.lookup x env of
Success y -> returnA -< y
Fail _ -> failA -< printf "Variable %s not bound" (show x)
Just y -> returnA -< y
Nothing -> failA -< printf "Variable %s not bound" (show x)
getEnv = Environment askA
extendEnv = arr $ \(x,y,env) -> E.insert x y env
localEnv (Environment f) = Environment (localA f)
......@@ -55,14 +53,13 @@ instance ArrowReader r c => ArrowReader r (Environment var val c) where
askA = lift askA
localA (Environment (Reader f)) = Environment (Reader ((\(env,(r,x)) -> (r,(env,x))) ^>> localA f))
deriving instance ArrowTry (Env var val,x) (Env var val,y) z c => ArrowTry x y z (Environment var val c)
deriving instance ArrowTryCatch (Env var val,e) (Env var val,x) (Env var val,y) (Env var val,z) c => ArrowTryCatch e x y z (Environment var val c)
deriving instance Arrow c => Category (Environment var val c)
deriving instance Arrow c => Arrow (Environment var val c)
deriving instance ArrowLift (Environment var val)