Commit b7226241 authored by Sven Keidel's avatar Sven Keidel

refactor fixpoint algos

parent 8543baf9
Pipeline #13925 passed with stages
in 25 minutes and 47 seconds
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Abstract.Cache where
import Control.Arrow
import Data.Abstract.Widening (Stable)
import Data.Profunctor
class (Profunctor c, Arrow c) => ArrowCache a b c where
lookup :: c a b
update :: c (a,b) (Stable,b)
cached :: c a b -> c a b
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Deduplicate where
import Control.Arrow
import Data.Profunctor
-- | 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, Profunctor c) => ArrowDeduplicate x y c where
dedup :: c x y -> c x y
instance ArrowDeduplicate x y (->) where
dedup = returnA
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DefaultSignatures #-}
module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix,IterationStrategy) where
import Control.Arrow import Control.Arrow
import Control.Arrow.Trans import Control.Arrow.Trans
...@@ -25,3 +25,6 @@ instance ArrowFix x y (->) where ...@@ -25,3 +25,6 @@ instance ArrowFix x y (->) where
liftFix :: (Arrow c, Profunctor c, ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y liftFix :: (Arrow c, Profunctor c, ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y
liftFix f = lift $ fix (unlift . f . lift) liftFix f = lift $ fix (unlift . f . lift)
{-# INLINE liftFix #-}
type IterationStrategy c a b = c a b -> c a b
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
module Control.Arrow.Abstract.Join where module Control.Arrow.Order where
import Prelude hiding ((.)) import Prelude hiding ((.))
import Control.Arrow import Control.Arrow
import Data.Order(Complete(..)) import Data.Order(Complete(..))
import Data.Profunctor import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowJoin c where 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. -- | Join two arrow computation with the provided upper bound operator.
-- join :: (y -> y -> y) -> c x y -> c x y -> c x y
-- Laws:
-- @
-- joinWith (⊔) f g = joined f g
-- @
joinWith :: (y -> y -> y) -> c x y -> c x y -> c x y
joinWith' :: (ArrowJoin c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y join' :: (ArrowComplete c) => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
joinWith' lub f g = joinWith lub (lmap fst f) (lmap snd g) join' lub f g = join lub (lmap fst f) (lmap snd g)
(<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y (<>) :: (ArrowComplete c, Complete y) => c x y -> c x y -> c x y
(<>) = joinWith () (<>) = join ()
-- | Joins a list of arguments. Use it with idiom brackets: -- | Joins a list of arguments. Use it with idiom brackets:
-- @ -- @
-- let a = ...; b = ...; xs = ... -- let a = ...; b = ...; xs = ...
-- (| joinList (returnA -< a) (\x -> f -< x+b) |) xs -- (| joinList (returnA -< a) (\x -> f -< x+b) |) xs
-- @ -- @
joinList :: (ArrowChoice c, ArrowJoin c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y joinList :: (ArrowChoice c, ArrowComplete c, Complete y) => c (e,s) y -> c (e,(x,s)) y -> c (e,([x],s)) y
joinList empty f = proc (e,(l,s)) -> case l of joinList empty f = proc (e,(l,s)) -> case l of
[] -> empty -< (e,s) [] -> empty -< (e,s)
[x] -> f -< (e,(x,s)) [x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s))) (x:xs) -> (f -< (e,(x,s))) <> (joinList empty f -< (e,(xs,s)))
joinList1 :: (ArrowChoice c, ArrowJoin c, Complete y) => c (e,(x,s)) y -> c (e,([x],s)) y joinList1 :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete c, Complete y) => c (e,(x,s)) y -> c (e,([x],s)) y
joinList1 f = proc (e,(l,s)) -> case l of joinList1 f = proc (e,(l,s)) -> case l of
[] -> returnA -< error "empty list" [] -> bottom -< ()
[x] -> f -< (e,(x,s)) [x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s))) (x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s)))
instance ArrowJoin (->) where instance ArrowComplete (->) where
joinWith lub f g = \x -> lub (f x) (g x) join lub f g = \x -> lub (f x) (g x)
...@@ -4,6 +4,14 @@ module Control.Arrow.Trans where ...@@ -4,6 +4,14 @@ module Control.Arrow.Trans where
import Control.Arrow import Control.Arrow
import Data.Profunctor import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowRun c where
type Rep c x y
run :: c x y -> Rep c x y
instance ArrowRun (->) where
type Rep (->) x y = x -> y
run = id
class ArrowLift t where class ArrowLift t where
lift' :: (Arrow c, Profunctor c) => c x y -> t c x y lift' :: (Arrow c, Profunctor c) => c x y -> t c x y
......
...@@ -20,23 +20,20 @@ import Control.Arrow.Fix ...@@ -20,23 +20,20 @@ import Control.Arrow.Fix
import Control.Arrow.Trans import Control.Arrow.Trans
import Control.Arrow.Reader import Control.Arrow.Reader
import Control.Arrow.State import Control.Arrow.State
import Control.Arrow.Abstract.Join import Control.Arrow.Order
import Control.Arrow.Transformer.Const import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.Reader
import Control.Category import Control.Category
import Data.Order import Data.Order (Complete)
import Data.Identifiable import Data.Identifiable
import Data.Abstract.FiniteMap (Map) import Data.Abstract.FiniteMap (Map)
import qualified Data.Abstract.FiniteMap as M import qualified Data.Abstract.FiniteMap as M
import Data.Abstract.Maybe(Maybe(..)) import Data.Abstract.Maybe(Maybe(..))
import Data.Profunctor import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
-- | Abstract domain for environments in which concrete environments import Data.Coerce
-- 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.
-- | Abstract domain for environments in which concrete environments -- | Abstract domain for environments in which concrete environments
-- are approximated by a mapping from variables to addresses and a -- are approximated by a mapping from variables to addresses and a
...@@ -47,9 +44,9 @@ import Data.Profunctor ...@@ -47,9 +44,9 @@ import Data.Profunctor
-- recursively. By only allowing a finite number of addresses, the -- recursively. By only allowing a finite number of addresses, the
-- abstract domain of closures and environments becomes finite. -- 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 ) 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, ArrowJoin) deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowState s, ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete)
runEnvT :: (Show var, Identifiable var, Identifiable addr, Complete val, ArrowJoin c, ArrowChoice c, Profunctor c) 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 => c (var,val,Map var addr val) addr -> EnvT var addr val c x y -> c ([(var,val)],x) y
runEnvT alloc f = runEnvT alloc f =
let EnvT f' = proc (bs,x) -> do let EnvT f' = proc (bs,x) -> do
...@@ -58,6 +55,10 @@ runEnvT alloc f = ...@@ -58,6 +55,10 @@ runEnvT alloc f =
localEnv f -< (env',x) localEnv f -< (env',x)
in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f') in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f')
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)
instance ArrowTrans (EnvT var addr val) where instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = Dom (ReaderT (Map var addr val)) x y 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 type Cod (EnvT var addr val) x y = Cod (ReaderT (Map var addr val)) x y
...@@ -67,7 +68,7 @@ instance ArrowTrans (EnvT var addr val) where ...@@ -67,7 +68,7 @@ instance ArrowTrans (EnvT var addr val) where
instance ArrowLift (EnvT var addr val) where 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, ArrowJoin c, Profunctor c) => instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowComplete c, Profunctor c) =>
ArrowEnv var val (Map var addr val) (EnvT var addr val c) where ArrowEnv var val (Map var addr val) (EnvT var addr val c) where
type Join (EnvT var addr val c) x y = (Complete y) type Join (EnvT var addr val c) x y = (Complete y)
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
...@@ -86,7 +87,7 @@ instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where ...@@ -86,7 +87,7 @@ instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (runReaderT (f alloc)) EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> local (runReaderT (f alloc))
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app 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) 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) 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)
...@@ -10,7 +10,6 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT,runCompletionT) ...@@ -10,7 +10,6 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT,runCompletionT)
import Prelude hiding ((.),id,lookup,fail) import Prelude hiding ((.),id,lookup,fail)
import Control.Arrow import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment import Control.Arrow.Environment
import Control.Arrow.Except import Control.Arrow.Except
import Control.Arrow.Fail import Control.Arrow.Fail
...@@ -20,30 +19,36 @@ import Control.Arrow.State ...@@ -20,30 +19,36 @@ import Control.Arrow.State
import Control.Arrow.Store import Control.Arrow.Store
import Control.Arrow.Trans import Control.Arrow.Trans
import Control.Arrow.Const import Control.Arrow.Const
import Control.Arrow.Abstract.Join import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli import Control.Arrow.Transformer.Kleisli
import Control.Category import Control.Category
import Data.Profunctor
import Data.Abstract.FreeCompletion import Data.Abstract.FreeCompletion
import Data.Identifiable
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Allows to describe computations over non-completely ordered types. -- | Allows to describe computations over non-completely ordered types.
-- E.g. allows to join a computation of type 'c x [y]'. -- E.g. allows to join a computation of type 'c x [y]'.
newtype CompletionT c x y = CompletionT { unCompletionT :: KleisliT FreeCompletion c x y } newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e, ArrowStore a b, ArrowFail e, ArrowExcept e) ArrowConst r, ArrowEnv a b e, ArrowStore a b, ArrowFail e, ArrowExcept e, ArrowRun)
runCompletionT :: CompletionT c x y -> c x (FreeCompletion y) runCompletionT :: CompletionT c x y -> c x (FreeCompletion y)
runCompletionT = runKleisliT . unCompletionT runCompletionT = coerce
{-# INLINE runCompletionT #-}
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT c) where app = lift $ lmap (first unlift) app instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (CompletionT c) where
app = lift (app .# first coerce)
type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c) type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c) => ArrowFix x y (CompletionT c) deriving instance (ArrowChoice c, ArrowFix (Dom (CompletionT) x y) (Cod (CompletionT) x y) c) => ArrowFix x y (CompletionT c)
deriving instance (Identifiable (Cod CompletionT x y), ArrowChoice c, ArrowDeduplicate (Dom CompletionT x y) (Cod CompletionT x y) c) => ArrowDeduplicate x y (CompletionT c)
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (CompletionT c) where
joinWith lub f g = lift $ joinWith join (unlift f) (unlift g) bottom = lift $ bottom
where join (Lower x) (Lower y) = Lower (lub x y)
join Top _ = Top instance (ArrowChoice c, ArrowComplete c) => ArrowComplete (CompletionT c) where
join _ Top = Top join lub f g = lift $ join joinVal (unlift f) (unlift g)
where joinVal (Lower x) (Lower y) = Lower (lub x y)
joinVal Top _ = Top
joinVal _ Top = Top
...@@ -8,37 +8,45 @@ ...@@ -8,37 +8,45 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Contour(CallString,ContourT,runContourT) where module Control.Arrow.Transformer.Abstract.Contour(CallString,ContourT,runContourT) where
import Prelude hiding (id,(.),lookup) import Prelude hiding (id,(.),lookup)
import Control.Arrow import Control.Arrow
import Control.Arrow.Alloc import Control.Arrow.Alloc
import Control.Arrow.Environment import Control.Arrow.Environment
import Control.Arrow.Fail import Control.Arrow.Fail
import Control.Arrow.Except import Control.Arrow.Except
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Trans import Control.Arrow.Trans
import Control.Arrow.Reader import Control.Arrow.Reader
import Control.Arrow.State import Control.Arrow.State
import Control.Arrow.Abstract.Join import Control.Arrow.Order
import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.Reader
import Control.Category import Control.Category
import Data.Label import Data.Label
import Data.CallString import Data.CallString
import Data.Profunctor import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Records the k-bounded call string. Meant to be used in -- | Records the k-bounded call string. Meant to be used in
-- conjunction with 'Abstract.BoundedEnvironment'. -- conjunction with 'Abstract.BoundedEnvironment'.
newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b) newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b)
deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice, ArrowState s, deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice, ArrowState s,
ArrowEnv x y env, ArrowFail e, ArrowExcept e, ArrowJoin) ArrowEnv x y env, ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete)
-- | Runs a computation that records a call string. The argument 'k' -- | Runs a computation that records a call string. The argument 'k'
-- specifies the maximum length of a call string. All larger call -- specifies the maximum length of a call string. All larger call
-- strings are truncated to at most 'k' elements. -- strings are truncated to at most 'k' elements.
runContourT :: (Arrow c, Profunctor c) => Int -> ContourT lab c a b -> c a b 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 runContourT k (ContourT (ReaderT f)) = lmap (\a -> (empty k,a)) f
{-# INLINE runContourT #-}
instance ArrowRun c => ArrowRun (ContourT lab c) where
type Rep (ContourT lab c) x y = Int -> Rep c x y
run f i = run (runContourT i f)
{-# INLINE run #-}
type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c) 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 instance (ArrowFix x y c, ArrowApply c, HasLabel x lab,Profunctor c) => ArrowFix x y (ContourT lab c) where
...@@ -58,7 +66,7 @@ instance (Arrow c, Profunctor c) => ArrowAlloc (var,val,env) (var,CallString lab ...@@ -58,7 +66,7 @@ instance (Arrow c, Profunctor c) => ArrowAlloc (var,val,env) (var,CallString lab
alloc = ContourT $ ReaderT $ arr $ \(l,(x,_,_)) -> (x,l) alloc = ContourT $ ReaderT $ arr $ \(l,(x,_,_)) -> (x,l)
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT $ lmap (\(ContourT f,x) -> (f,x)) app app = ContourT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ContourT lab c) where instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' ask ask = lift' ask
......
...@@ -10,12 +10,6 @@ module Control.Arrow.Transformer.Abstract.Environment where ...@@ -10,12 +10,6 @@ module Control.Arrow.Transformer.Abstract.Environment where
import Prelude hiding ((.),read,Maybe(..)) import Prelude hiding ((.),read,Maybe(..))
import Data.Order
import Data.Identifiable
import Data.Abstract.Maybe
import Data.Abstract.StrongMap (Map)
import qualified Data.Abstract.StrongMap as M
import Control.Category import Control.Category
import Control.Arrow import Control.Arrow
import Control.Arrow.Const import Control.Arrow.Const
...@@ -28,34 +22,43 @@ import Control.Arrow.Except ...@@ -28,34 +22,43 @@ import Control.Arrow.Except
import Control.Arrow.Trans import Control.Arrow.Trans
import Control.Arrow.Environment import Control.Arrow.Environment
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Abstract.Join import Data.Order(UpperBounded, Complete)
import Data.Identifiable
import Data.Abstract.Maybe
import Data.Abstract.StrongMap (Map)
import qualified Data.Abstract.StrongMap as M
import Data.Profunctor import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y) newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowJoin, deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k) ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun)
runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y runEnvT :: (Arrow c, Profunctor c) => EnvT var val c x y -> c (Map var val,x) y
runEnvT = unlift runEnvT = coerce
{-# INLINE runEnvT #-}
runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y 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 runEnvT' f = lmap (first M.fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowJoin c, Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where
type Join (EnvT var val c) x y = (Complete y) type Join (EnvT var val c) x y = Complete y
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- ask -< () env <- ask -< ()
case M.lookup' var env of case M.lookup' var env of
Just val -> f -< (val,x) Just val -> f -< (val,x)
JustNothing val -> (f -< (val,x)) <> (g -< x)
Nothing -> g -< x Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
getEnv = EnvT ask getEnv = EnvT ask
extendEnv = arr $ \(x,y,env) -> M.insert x y env extendEnv = arr $ \(x,y,env) -> M.insert x y env
localEnv (EnvT f) = EnvT (local f) localEnv (EnvT f) = EnvT (local f)
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where
app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app app = EnvT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (EnvT var val c) where instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' ask ask = lift' ask
......
...@@ -12,7 +12,6 @@ import Prelude hiding (id,lookup,(.),read,fail) ...@@ -12,7 +12,6 @@ import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow import Control.Arrow
import Control.Arrow.Const import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env import Control.Arrow.Environment as Env
import Control.Arrow.Fail import Control.Arrow.Fail
import Control.Arrow.Trans import Control.Arrow.Trans
...@@ -21,31 +20,38 @@ import Control.Arrow.State ...@@ -21,31 +20,38 @@ import Control.Arrow.State
import Control.Arrow.Store as Store import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc import Control.Arrow.Except as Exc
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Abstract.Join import Control.Arrow.Order
import Control.Arrow.Transformer.Kleisli import Control.Arrow.Transformer.Kleisli
import Control.Category import Control.Category
import Data.Order
import Data.Profunctor
import Data.Identifiable
import Data.Abstract.Error import Data.Abstract.Error
import Data.Abstract.Widening (toJoin2) import Data.Abstract.Widening (toJoin2)
newtype ErrorT e c x y = ErrorT { unErrorT :: KleisliT (Error e) c x y } import qualified Data.Order as O
import Data.Profunctor
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, ArrowState s, ArrowReader r, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e') ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e', ArrowRun)
runErrorT :: ErrorT e c x y -> c x (Error e y) runErrorT :: ErrorT e c x y -> c x (Error e y)
runErrorT = runKleisliT . unErrorT runErrorT = coerce
{-# INLINE runErrorT #-}
instance (ArrowChoice c, Profunctor c) => ArrowFail e (ErrorT e c) where instance (ArrowChoice c, Profunctor c) => ArrowFail e (ErrorT e c) where
fail = lift $ arr Fail fail = lift $ arr Fail
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ErrorT e c) where app = lift $ lmap (first unlift) app instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ErrorT e c) where
app = lift (app .# first coerce)
type instance Fix x y (ErrorT e c) = ErrorT e (Fix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) type instance Fix x y (ErrorT e c) = ErrorT e (Fix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c)
deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowFix x y (ErrorT e c) deriving instance (ArrowChoice c, ArrowFix (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowFix x y (ErrorT e c)
deriving instance (Identifiable (Cod (ErrorT e) x y), ArrowChoice c, ArrowDeduplicate (Dom (ErrorT e) x y) (Cod (ErrorT e) x y) c) => ArrowDeduplicate x y (ErrorT e c)
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowJoin (ErrorT e c) where instance (ArrowChoice c, ArrowLowerBounded c) => ArrowLowerBounded (ErrorT e c) where
joinWith lub' f g = lift $ joinWith (toJoin2 widening () lub') (unlift f) (unlift g) bottom = lift bottom
instance (O.Complete e, ArrowComplete c, ArrowChoice c) => ArrowComplete (ErrorT e c) where
join lub f g = lift $ join (toJoin2 widening (O.) lub) (unlift f) (unlift g)
...@@ -12,7 +12,6 @@ import Prelude hiding (id,lookup,(.),read,fail) ...@@ -12,7 +12,6 @@ import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow import Control.Arrow
import Control.Arrow.Const import Control.Arrow.Const
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env import Control.Arrow.Environment as Env
import Control.Arrow.Fail import Control.Arrow.Fail
import Control.Arrow.Trans import Control.Arrow.Trans
...@@ -21,25 +20,28 @@ import Control.Arrow.State ...@@ -21,25 +20,28 @@ import Control.Arrow.State
import Control.Arrow.Store as Store import Control.Arrow.Store as Store
import Control.Arrow.Except import Control.Arrow.Except<