Commit 52461cf5 authored by Sven Keidel's avatar Sven Keidel

refactor ArrowComplete

parent 1f100d2f
Pipeline #13987 passed with stages
in 20 minutes and 23 seconds
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Alloc where
import Control.Arrow
import Data.Profunctor
-- | Arrow-based interface for allocating addresses.
class (Arrow c, Profunctor c) => ArrowAlloc x y c where
-- | Allocates a new address.
alloc :: c x y
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Conditional where
import Control.Arrow
import GHC.Exts(Constraint)
import Data.Profunctor
-- | Arrow based interface to implement conditionals.
class (Arrow c, Profunctor 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
-- TODO: Change type to if_ :: Join c (e,s) y => c (e,s) y -> c (e,s) y -> c (e, (v, s)) y
-- | @'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
......@@ -24,13 +24,13 @@ import GHC.Exts (Constraint)
-- | Arrow-based interface for interacting with environments.
class (Arrow c, Profunctor c) => ArrowEnv var val c | c -> var, c -> val where
-- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint
type family Join y (c :: * -> * -> *) :: Constraint
-- TODO: Change type to lookup (Join c x y) => c (e,(val,s)) y -> c (e,s) y -> c (e,(var,s)) y
-- | 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
lookup :: Join y c => c (val,x) y -> c x y -> c (var,x) y
-- | Extend an environment with a binding.
extend :: c x y -> c (var,val,x) y
......@@ -43,10 +43,10 @@ class ArrowEnv var val c => ArrowClosure var val env c | c -> env where
local :: c x y -> c (env,x) y
-- | Simpler version of environment lookup.
lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val c) => c var val
lookup' :: (Join val c, Show var, IsString e, ArrowFail e c, ArrowEnv var val c) => c var val
lookup' = lookup'' id
lookup'' :: (Join c ((val,var),var) y, Show var, IsString e, ArrowFail e c, ArrowEnv var val c) => c val y -> c var y
lookup'' :: (Join y c, Show var, IsString e, ArrowFail e c, ArrowEnv var val c) => c val y -> c var y
lookup'' f = proc var ->
lookup
(proc (val,_) -> f -< val)
......
......@@ -11,57 +11,56 @@ import Prelude hiding (id,(.))
import Control.Category
import Control.Arrow
import GHC.Exts(Constraint)
import Data.Profunctor
import GHC.Exts (Constraint)
-- | Arrow-based interface for exception handling.
class (Arrow c, Profunctor 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
type family Join y (c :: * -> * -> *) :: Constraint
-- | Opertion that throws an exception that can be handled with 'catch'.
throw :: c e a
-- | @'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 (y,(x,e)) z => c x y -> c y z -> c (x,e) z -> c x z
try :: Join z c => c x y -> c y z -> c (x,e) z -> c x z
-- | Simpler version of 'throw'.
throw' :: ArrowExcept () c => c a b
throw' = proc _ -> throw -< ()
{-# INLINE throw' #-}
try' :: (Join c (y,(x,e)) z, ArrowExcept e c) => c x y -> c y z -> c x z -> c x z
try' :: (Join z c, ArrowExcept e c) => c x y -> c y z -> c x z -> c x z
try' f g h = try f g (lmap fst h)
{-# INLINE try' #-}
-- | @'catch' f g@ handles exceptions thrown in @f@ with @g@.
catch :: (Join c (y,(x,e)) y, ArrowExcept e c) => c x y -> c (x,e) y -> c x y
catch :: (Join y c, ArrowExcept e c) => c x y -> c (x,e) y -> c x y
catch f g = try f id g
{-# INLINE catch #-}
{-# ANN catch "HLint: ignore Eta reduce" #-}
-- | Simpler version of 'catch'.
catch' :: (Join c (y,(x,e)) y, ArrowExcept e c) => c x y -> c e y -> c x y
catch' :: (Join y c, ArrowExcept e c) => c x y -> c e y -> c x y
catch' f g = catch f (lmap snd g)
{-# INLINE catch' #-}
-- | @'finally' f g@ executes @g@, no matter if @f@ throws an exception.
finally :: (Join c ((x,y),(x,e)) y, ArrowExcept e c) => c x y -> c x u -> c x y
finally :: (Join y c, ArrowExcept e c) => c x y -> c x u -> c x y
finally f g = try (id &&& f)
(proc (x,y) -> do g -< x; returnA -< y)
(proc (x,e) -> do g -< x; throw -< e)
{-# INLINE finally #-}
-- | Picks the first computation that does not throw an exception.
(<+>) :: (Join c (y,(x,e)) y, ArrowExcept e c) => c x y -> c x y -> c x y
(<+>) :: (Join y c, ArrowExcept e c) => c x y -> c x y -> c x y
f <+> g = catch f (lmap fst 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.
tryFirst :: (Join c (y,((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) => c x y -> c () y -> c [x] y
tryFirst :: (Join y c, ArrowChoice c, ArrowExcept e c) => c x y -> c () y -> c [x] y
tryFirst f g = proc l -> case l of
[] -> g -< ()
a:as -> catch (lmap fst f) (lmap (snd . fst) (tryFirst f g)) -< (a,as)
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Order where
import Prelude hiding ((.))
......@@ -10,32 +14,34 @@ import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowLowerBounded c where
bottom :: c x y
class (Arrow c, Profunctor c) => ArrowComplete c where
-- | Join two arrow computation with the provided upper bound operator.
class (Arrow c, Profunctor c) => ArrowComplete y c where
(<>) :: c x y -> c x y -> c x y
instance Complete y => ArrowComplete y (->) where
(<>) f g = \x -> f x g x
class (Arrow c, Profunctor c) => ArrowJoin c where
join :: (y -> y -> y) -> c x y -> c x y -> c x y
join' :: (ArrowComplete c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
join' lub f g = join lub (lmap fst f) (lmap snd g)
instance ArrowJoin (->) where
join lub f g = \x -> f x `lub` g x
(<>) :: (ArrowComplete c, Complete y) => c x y -> c x y -> c x y
(<>) = join ()
join' :: (ArrowJoin c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
join' lub f g = join lub (lmap fst f) (lmap snd g)
-- | Joins a list of arguments. Use it with idiom brackets:
-- @
-- let a = ...; b = ...; xs = ...
-- (| joinList (returnA -< a) (\x -> f -< x+b) |) xs
-- @
joinList :: (ArrowChoice c, ArrowComplete c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y
joinList :: (ArrowChoice c, ArrowComplete y c) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y
joinList empty f = proc (e,(l,s)) -> case l of
[] -> empty -< (e,s)
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s)))
joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete c, Complete y) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 f = proc (e,(l,s)) -> case l of
[] -> bottom -< ()
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s)))
instance ArrowComplete (->) where
join lub f g = \x -> lub (f x) (g x)
......@@ -19,16 +19,16 @@ import GHC.Exts(Constraint)
-- The parameter `y` needs to be exposed, because abstract instances
-- may need to join on `y`.
class (Arrow c, Profunctor c) => ArrowStore var val c | c -> var, c -> val where
type family Join (c :: * -> * -> *) x y :: Constraint
type family Join y (c :: * -> * -> *) :: Constraint
-- | Reads a value from the store. Fails if the binding is not in the current store.
read :: Join c ((val,x),x) y => c (val,x) y -> c x y -> c (var,x) y
read :: Join y c => c (val,x) y -> c x y -> c (var,x) y
-- | Writes a value to the store.
write :: c (var,val) ()
-- | Simpler version of 'read'
read' :: (Show var, Join c ((val,var),var) val, IsString e, ArrowFail e c, ArrowStore var val c) => c var val
read' :: (Show var, Join val c, IsString e, ArrowFail e c, ArrowStore var val c) => c var val
read' = proc var ->
read (proc (val,_) -> returnA -< val)
(proc var -> fail -< fromString $ printf "variable %s not bound" (show var))
......
......@@ -8,9 +8,17 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-}
-- | Abstract domain for environments in which concrete environments
-- are approximated by a mapping from variables to addresses and a
-- mapping from addresses to values. The number of allocated addresses
-- allows to tune the precision and performance of the analysis.
--
-- Furthermore, closures and environments are defined mutually
-- recursively. By only allowing a finite number of addresses, the
-- abstract domain of closures and environments becomes finite.
module Control.Arrow.Transformer.Abstract.BoundedEnvironment(EnvT,runEnvT) where
import Prelude hiding ((.),id,Maybe(..))
import Prelude hiding ((.),id)
import Control.Arrow
import Control.Arrow.Environment
......@@ -19,71 +27,67 @@ 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.State as State
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Category
import Data.Order (Complete)
import Data.Order (Complete(..))
import Data.Identifiable
import Data.Abstract.FiniteMap (Map)
import qualified Data.Abstract.FiniteMap as M
import Data.Abstract.Maybe(Maybe(..))
import Data.HashMap.Lazy as HM
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Abstract domain for environments in which concrete environments
-- are approximated by a mapping from variables to addresses and a
-- mapping from addresses to values. The number of allocated addresses
-- allows to tune the precision and performance of the analysis.
--
-- Furthermore, closures and environments are defined mutually
-- recursively. By only allowing a finite number of addresses, the
-- abstract domain of closures and environments becomes finite.
newtype EnvT var addr val c x y = EnvT ( ConstT (c (var,val,Map var addr val) addr) (ReaderT (Map var addr val) c) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowState s, ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete)
type Env var addr val = (HM.HashMap var addr,HM.HashMap addr val)
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowComplete c, ArrowChoice c, Profunctor c)
=> c (var,val,Map var addr val) addr -> EnvT var addr val c x y -> c ([(var,val)],x) y
runEnvT alloc f =
let EnvT f' = proc (bs,x) -> do
extend' f -< (bs,x)
in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f')
newtype EnvT var addr val c x y = EnvT (ConstT (c (var,val,Env var addr val) addr) (ReaderT (HM.HashMap var addr) (StateT (HM.HashMap addr val) c)) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowLowerBounded)
instance (Identifiable var, Identifiable addr, Complete val, ArrowComplete c, ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Rep (EnvT var addr val c) x y = c (var,val,Map var addr val) addr -> Rep c ([(var,val)],x) y
run f alloc = run (runEnvT alloc f)
deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = Dom (ReaderT (Map var addr val)) x y
type Cod (EnvT var addr val) x y = Cod (ReaderT (Map var addr val)) x y
lift = undefined
unlift = undefined
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c)
=> c (var,val,Env var addr val) addr -> EnvT var addr val c x y -> c x (HM.HashMap addr val,y)
runEnvT alloc (EnvT f) =
lmap (\x -> (HM.empty,(HM.empty,x)))
(runStateT (runReaderT (runConstT alloc f)))
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowComplete c, Profunctor c) =>
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
ArrowEnv var val (EnvT var addr val c) where
type Join (EnvT var addr val c) x y = (Complete y)
type Join y (EnvT var addr val c) = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
case do M.lookup var env of
Just val -> f -< (val,x)
Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
extend (EnvT f) = EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ proc (env,(var,val,x)) -> do
env' <- M.insertBy alloc -< (var,val,env)
runReaderT (runConstT alloc f) -< (env',x)
store <- State.get -< ()
case do { addr <- HM.lookup var env; HM.lookup addr store } of
Just val -> f -< (val,x)
Nothing -> g -< x
extend (EnvT f) = EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ StateT $ proc (store,(env,(var,val,x))) -> do
addr <- alloc -< (var,val,(env,store))
let env' = HM.insert var addr env
store' = HM.insertWith () addr val store
runStateT (runReaderT (runConstT alloc f)) -< (store',(env',x))
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowComplete c, Profunctor c) =>
ArrowClosure var val (Map var addr val) (EnvT var addr val c) where
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
ArrowClosure var val (HM.HashMap var addr) (EnvT var addr val c) where
ask = EnvT Reader.ask
local (EnvT f) = EnvT $ Reader.local f
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 = c (var,val,Env var addr val) addr -> Rep c x (HM.HashMap addr val,y)
run f alloc = run (runEnvT alloc f)
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = (HM.HashMap addr val,(HM.HashMap var addr,x))
type Cod (EnvT var addr val) x y = (HM.HashMap addr val,y)
lift = undefined
unlift = undefined
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' (lift' f)))
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' Reader.ask
local (EnvT (ConstT (StaticT f))) =
......@@ -92,5 +96,6 @@ 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)
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)
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)
......@@ -49,7 +49,7 @@ deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (Complet
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
bottom = lift $ bottom
instance (ArrowChoice c, ArrowComplete c) => ArrowComplete (CompletionT c) where
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where
join lub f g = lift $ join joinVal (unlift f) (unlift g)
where joinVal (Lower x) (Lower y) = Lower (lub x y)
joinVal Top _ = Top
......
......@@ -11,7 +11,6 @@ module Control.Arrow.Transformer.Abstract.Contour(CallString,ContourT,runContour
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Alloc
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Fail
......@@ -37,7 +36,7 @@ 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)
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
......@@ -64,10 +63,6 @@ instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix
y <- f' -< (push (label x) c,x)
returnA -< y
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)
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT (app .# first coerce)
......
......@@ -24,7 +24,7 @@ import Control.Arrow.Environment as Env
import Control.Arrow.Fix
import Control.Arrow.Order
import Data.Order(UpperBounded, Complete)
import Data.Order(UpperBounded)
import Data.Identifiable
import Data.Abstract.Maybe
import Data.Abstract.StrongMap (Map)
......@@ -34,7 +34,7 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete,
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
......@@ -45,8 +45,8 @@ runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c
runEnvT' f = lmap (first M.fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowEnv var val (EnvT var val c) where
type Join (EnvT var val c) x y = Complete y
instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT var val c) where
type Join y (EnvT var val c) = ArrowComplete y c
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
case M.lookup' var env of
......@@ -57,7 +57,7 @@ instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Pr
env <- Reader.ask -< ()
Reader.local f -< (M.insert var val env,x)
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowClosure var val (Map var val) (EnvT var val c) where
instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => ArrowClosure var val (Map var val) (EnvT var val c) where
ask = EnvT Reader.ask
local (EnvT f) = EnvT (Reader.local f)
......
......@@ -33,7 +33,7 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowExcept e')
......@@ -54,6 +54,8 @@ deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e)
instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (ErrorT e c) where
bottom = lift bottom
instance (O.Complete e, ArrowComplete c, ArrowChoice c) => ArrowComplete (ErrorT e c) where
instance (O.Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ErrorT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
deriving instance (ArrowChoice c, ArrowComplete (Error e y) c) => ArrowComplete y (ErrorT e c)
......@@ -43,8 +43,8 @@ runExceptT :: ExceptT e c x y -> c x (Except e y)
runExceptT = coerce
{-# INLINE runExceptT #-}
instance (Complete e, ArrowChoice c, ArrowComplete c) => ArrowExcept e (ExceptT e c) where
type Join (ExceptT e c) (y,(x,e)) z = Complete (Except e z)
instance (Complete e, ArrowChoice c, ArrowJoin c) => ArrowExcept e (ExceptT e c) where
type Join y (ExceptT e c) = ArrowComplete (Except e y) c
throw = lift $ arr Fail
try f g h = lift $ proc x -> do
e <- unlift f -< x
......@@ -53,12 +53,15 @@ instance (Complete e, ArrowChoice c, ArrowComplete c) => ArrowExcept e (ExceptT
Fail er -> unlift h -< (x,er)
SuccessOrFail er y -> (unlift g -< y) <> (unlift h -< (x,er))
instance (Complete e, ArrowComplete c, ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where
app = lift (app .# first coerce)
type instance Fix x y (ExceptT e c) = ExceptT e (Fix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c)
deriving instance (Complete e, ArrowComplete c, ArrowChoice c, ArrowFix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c)
deriving instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFix (Dom (ExceptT e) x y) (Cod (ExceptT e) x y) c) => ArrowFix x y (ExceptT e c)
instance (Complete e, ArrowComplete c, ArrowChoice c) => ArrowComplete (ExceptT e c) where
instance (Complete e, ArrowChoice c, ArrowJoin c) => ArrowJoin (ExceptT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
deriving instance (Complete e, ArrowChoice c, ArrowJoin c, ArrowComplete (Except e y) c) => ArrowComplete y (ExceptT e c)
......@@ -52,5 +52,5 @@ type instance Fix x y (FailureT e c) = FailureT e (Fix (Dom (FailureT e) x y) (C
deriving instance (ArrowChoice c, ArrowFix (Dom (FailureT e) x y) (Cod (FailureT e) x y) c) =>
ArrowFix x y (FailureT e c)
instance (ArrowComplete c, ArrowChoice c) => ArrowComplete (FailureT e c) where
instance (ArrowChoice c,ArrowJoin c) => ArrowJoin (FailureT e c) where
join lub f g = lift $ join (toJoin widening lub) (unlift f) (unlift g)
......@@ -28,7 +28,7 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype FixT a b c x y = FixT { unFixT :: ConstT (IterationStrategy c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin)
-- runFixT :: (Identifiable a, PreOrd b, Profunctor c, ArrowRun t)
-- => IterationStrategy (t c) a b -> FixT a b (t c) x y -> c x y
......
......@@ -15,7 +15,7 @@ import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowComplete(..))
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..))
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Writer
......@@ -96,8 +96,10 @@ instance (Identifiable a, ArrowRun c) => ArrowRun (ChaoticT a b c) where
run = run . runChaoticT
instance (Identifiable a,Profunctor c,ArrowApply c) => ArrowApply (ChaoticT a b c) where app = ChaoticT (lmap (first coerce) app)
instance (Identifiable a,Profunctor c,Arrow c) => ArrowComplete (ChaoticT a b c) where
instance (Identifiable a,Profunctor c,Arrow c) => ArrowJoin (ChaoticT a b c) where
join _lub (ChaoticT f) (ChaoticT g) = ChaoticT $ rmap (uncurry _lub) (f &&& g)
instance (Identifiable a,Profunctor c,Arrow c, Complete y) => ArrowComplete y (ChaoticT a b c) where
ChaoticT f <> ChaoticT g = ChaoticT $ rmap (uncurry ()) (f &&& g)
data Component a = Component { head :: HashSet a, body :: HashSet a }
instance Identifiable a => Semigroup (Component a) where (<>) = mappend
......
......@@ -16,7 +16,7 @@ import Control.Arrow.Fix
import Control.Arrow.State
import Control.Arrow.Reader
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowComplete(..))
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..))
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
......@@ -94,6 +94,10 @@ instance (ArrowRun c) => ArrowRun (ParallelT a b c) where
type instance Fix x y (ParallelT _ _ c) = ParallelT x y c
instance (Profunctor c,ArrowApply c) => ArrowApply (ParallelT a b c) where app = ParallelT (lmap (first coerce) app)
instance IsEmpty (cache a b) => IsEmpty (Iteration cache a b) where empty = Iteration empty empty W.Stable
instance (Profunctor c,Arrow c) => ArrowComplete (ParallelT a b c) where
instance (Profunctor c,Arrow c) => ArrowJoin (ParallelT a b c) where
join _lub (ParallelT f) (ParallelT g) = ParallelT $ rmap (uncurry _lub) (f &&& g)
instance (Profunctor c,Arrow c, Complete y) => ArrowComplete y (ParallelT a b c) where
ParallelT f <> ParallelT g = ParallelT $ rmap (uncurry ()) (f &&& g)
......@@ -14,7 +14,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowComplete(..))
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..))
import Control.Arrow.Transformer.Reader
import Data.Profunctor
......@@ -25,7 +25,7 @@ import Data.Empty
import Data.Abstract.StackWidening(StackWidening)
newtype StackWideningT stack a c x y = StackWideningT (ReaderT (stack a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete,ArrowTrans)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z,ArrowJoin,ArrowTrans)
runStackWideningT :: (IsEmpty (stack a), Profunctor c) => StackWideningT stack a c x y -> c x y
runStackWideningT (StackWideningT f) = lmap (\x -> (empty,x)) (runReaderT f)
......
......@@ -50,5 +50,5 @@ instance (Identifiable y, ArrowChoice c, ArrowFix x (A.Pow y) c) => ArrowFix x y
instance (ArrowChoice c, Profunctor c) => ArrowLowerBounded (PowT c) where
bottom = lift $ arr (\_ -> A.empty)
instance (ArrowChoice c, ArrowComplete c) => ArrowComplete (PowT c) where
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (PowT c) where
join _ f g = lift $ join A.union (unlift f) (unlift g)
......@@ -9,6 +9,7 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
module Control.Arrow.Transformer.Abstract.ReachingDefinitions(
ReachingDefsT(..),
reachingDefsT,
......@@ -20,7 +21,6 @@ import Prelude hiding ((.),read,id)
import Control.Category
import Control.Arrow
import Control.Arrow.Alloc
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
......@@ -46,7 +46,7 @@ newtype ReachingDefsT lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y)
ArrowState s,
ArrowEnv var val, ArrowClosure var val env,
ArrowFail e,ArrowExcept e,
ArrowLowerBounded, ArrowComplete)
ArrowLowerBounded, ArrowComplete z)
reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT lab c x y
reachingDefsT = lift
......@@ -65,7 +65,7 @@ instance ArrowRun c => ArrowRun (ReachingDefsT lab c) where
run = run . runReachingDefsT'
instance (Identifiable var, Identifiable lab, ArrowStore var (val,Pow lab) c) => ArrowStore var val (ReachingDefsT lab c) where
type Join (ReachingDefsT lab c) ((val,x),x) y = Store.Join c (((val,Pow lab),Dom (ReachingDefsT lab) x y), Dom (ReachingDefsT lab) x y) (Cod (ReachingDefsT lab) x y)