Commit 2e568b5a authored by Sven Keidel's avatar Sven Keidel

add flat environments

parent 95290f74
Pipeline #16242 failed with stages
in 31 minutes and 54 seconds
......@@ -26,7 +26,6 @@ library:
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wpartial-fields
-Wredundant-constraints
source-dirs:
- src
......
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Closure where
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import GHC.Exts
class (Arrow c, Profunctor c) => ArrowClosure expr cls c | cls -> expr where
type Join y c :: Constraint
-- | creates a non-recursive closure from expression.
closure :: c expr cls
-- | Apply a closure in its closed environment.
apply :: Join y c => c (expr,x) y -> c (cls, x) y
-- default lifting
default closure :: (c ~ (t c'), ArrowLift t, ArrowClosure expr cls c') => c expr cls
closure = lift' closure
{-# INLINE closure #-}
class IsClosure cls env | env -> cls, cls -> env where
mapEnvironment :: (env -> env) -> cls -> cls
traverseEnvironment :: Applicative f => (env -> f env) -> cls -> f cls
setEnvironment :: env -> cls -> cls
setEnvironment env = mapEnvironment (const env)
......@@ -26,7 +26,6 @@ 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 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.
......@@ -35,12 +34,9 @@ class (Arrow c, Profunctor c) => ArrowEnv var val c | c -> var, c -> val where
-- | Extend an environment with a binding.
extend :: c x y -> c (var,val,x) y
class ArrowEnv var val c => ArrowClosure var val env c | c -> env where
-- | Retrieve the current environment.
ask :: c () env
-- | Run a computation with a modified environment.
local :: c x y -> c (env,x) y
class ArrowEnv var val c => ArrowLetRec var val c where
-- | creates a list of bindings that mutual recursively refer to each other.
letRec :: c x y -> c ([(var,val)],x) y
-- | Simpler version of environment lookup.
lookup' :: (Join val c, Show var, IsString e, ArrowFail e c, ArrowEnv var val c) => c var val
......@@ -57,3 +53,4 @@ extend' :: (ArrowChoice c, ArrowEnv var val c) => c x y -> c ([(var,val)],x) y
extend' f = proc (l,x) -> case l of
((var,val):l') -> extend (extend' f) -< (var,val,(l',x))
[] -> f -< x
{-# INLINABLE extend' #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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)
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader as Reader
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader
import Control.Category
import Data.Order (Complete(..))
import Data.Identifiable
import qualified Data.HashMap.Lazy as HM
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
type Env var addr val = (HM.HashMap var addr,HM.HashMap addr val)
type Alloc c var addr val = c (var,val,Env var addr val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc c var addr val) (ReaderT (Env var addr val) c) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowComplete z, ArrowLowerBounded, ArrowTrans)
deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
runEnvT :: Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
runEnvT alloc (EnvT f) = runReaderT (runConstT alloc f)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
ArrowEnv var val (EnvT var addr val c) where
type Join y (EnvT var addr val c) = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
(env,store) <- Reader.ask -< ()
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 $ proc ((env,store),(var,val,x)) -> do
addr <- alloc -< (var,val,(env,store))
let env' = HM.insert var addr env
store' = HM.insertWith () addr val store
runReaderT (runConstT alloc f) -< ((env',store'),x)
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 (rmap fst Reader.ask)
local (EnvT f) = EnvT $ proc (env,x) -> do
(_,store) <- Reader.ask -< ()
Reader.local f -< ((env,store),x)
instance (ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Run (EnvT var addr val c) x y = Alloc c var addr val -> Run c (Env var addr val,x) y
run f alloc = run (runEnvT alloc f)
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' Reader.ask
local (EnvT (ConstT (StaticT f))) =
EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ (\(env,(r,x)) -> (r,(env,x))) ^>> Reader.local (runReaderT (f alloc))
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT (app .# first coerce)
type instance Fix (EnvT var addr val c) x y = EnvT var addr val (Fix c (Env var addr val,x) y)
deriving instance (Arrow c, Profunctor c, ArrowFix (c (Env var addr val,x) y)) => ArrowFix (EnvT var addr val c x y)
......@@ -10,6 +10,7 @@ import Prelude hiding ((.),id,lookup,fail)
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Closure
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -34,7 +35,7 @@ import Data.Coerce
newtype CompletionT c x y = CompletionT (KleisliT FreeCompletion c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowFail e, ArrowExcept e)
runCompletionT :: CompletionT c x y -> c x (FreeCompletion y)
......
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -21,52 +22,89 @@ import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Fix
import Control.Arrow.Order
import Data.Order(UpperBounded)
import Data.Identifiable
import Data.Abstract.Maybe
import Data.Abstract.StrongMap (Map)
import qualified Data.Abstract.StrongMap as M
import qualified Data.Abstract.StrongMap as SM
import qualified Data.Abstract.Environment.Flat as FM
import Data.Abstract.Closure (Closure)
import qualified Data.Abstract.Closure as Abs
import Data.Order
import Data.Identifiable
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)
import GHC.Exts
newtype EnvT env var val c x y = EnvT (ReaderT (env var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded, ArrowComplete z,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun)
runEnvT :: EnvT var val c x y -> c (Map var val,x) y
runEnvT :: EnvT env var val c x y -> c (env var val,x) y
runEnvT = coerce
{-# INLINE runEnvT #-}
runEnvT' :: (Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' f = lmap (first M.fromList) (runEnvT f)
runEnvT' :: (IsList (env var val), Item (env var val) ~ (var,val), Profunctor c) => EnvT env var val c x y -> c ([(var,val)],x) y
runEnvT' f = lmap (first fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
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
instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT SM.Map var val c) where
type Join y (EnvT SM.Map 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
case SM.lookup' var env of
Just val -> f -< (val,x)
Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
extend (EnvT f) = EnvT $ proc (var,val,x) -> do
env <- Reader.ask -< ()
Reader.local f -< (M.insert var val env,x)
Reader.local f -< (SM.insert var val env,x)
{-# INLINE lookup #-}
{-# INLINE extend #-}
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)
instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT FM.Env var val c) where
type Join y (EnvT FM.Env var val c) = ArrowComplete y c
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
case FM.lookup var env of
Just val -> f -< (val,x)
Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
extend (EnvT f) = EnvT $ proc (var,val,x) -> do
env <- Reader.ask -< ()
Reader.local f -< (FM.insert var val env,x)
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT FM.Env var val c) where
letRec (EnvT f) = EnvT $ proc (ls,x) -> do
env <- Reader.ask -< ()
Reader.local f -< (FM.insertRec ls env,x)
{-# INLINE letRec #-}
instance (Identifiable expr, ArrowLowerBounded c, ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (env var val)) (EnvT env var val c) where
type Join y (EnvT env var val c) = ArrowComplete y c
closure = EnvT $ proc expr -> do
env <- Reader.ask -< ()
returnA -< Abs.closure expr env
apply (EnvT f) = EnvT $ Abs.apply $ proc ((expr,env),x) ->
Reader.local f -< (env,(expr,x))
{-# INLINE closure #-}
{-# INLINE apply #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT env var val c) where
app = EnvT (app .# first coerce)
{-# INLINE app #-}
instance ArrowReader r c => ArrowReader r (EnvT var val c) where
instance ArrowReader r c => ArrowReader r (EnvT env var val c) where
ask = lift' Reader.ask
local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (Reader.local (unlift f))
{-# INLINE ask #-}
{-# INLINE local #-}
type instance Fix (EnvT var val c) x y = EnvT var val (Fix c (Map var val,x) y)
deriving instance ArrowFix (Underlying (EnvT var val c) x y) => ArrowFix (EnvT var val c x y)
type instance Fix (EnvT env var val c) x y = EnvT env var val (Fix c (env var val,x) y)
deriving instance ArrowFix (Underlying (EnvT env var val c) x y) => ArrowFix (EnvT env var val c x y)
......@@ -12,6 +12,7 @@ import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Fail
import Control.Arrow.Trans
import Control.Arrow.Reader
......@@ -34,7 +35,7 @@ import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowExcept e')
runErrorT :: ErrorT e c x y -> c x (Error e y)
......
......@@ -14,6 +14,7 @@ import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -35,7 +36,7 @@ import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Except e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun, ArrowLowerBounded,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowFail e')
runExceptT :: ExceptT e c x y -> c x (Except e y)
......
......@@ -12,6 +12,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Trans
......@@ -33,7 +34,7 @@ import Data.Coerce
newtype FailureT e c x y = FailureT (KleisliT (Failure e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowExcept e')
runFailureT :: FailureT e c x y -> c x (Failure e y)
......
......@@ -10,6 +10,7 @@ import Prelude hiding (id,(.),lookup,fail)
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Fail
import Control.Arrow.Trans
import Control.Arrow.Reader
......@@ -31,7 +32,7 @@ import Data.Coerce
newtype PowT c x y = PowT (KleisliT A.Pow c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowFail e', ArrowExcept e')
runPowT :: PowT c x y -> c x (A.Pow y)
......
......@@ -19,6 +19,7 @@ import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Except
import Control.Arrow.Environment
import Control.Arrow.Closure
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Control.Category
......@@ -34,25 +35,25 @@ import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype StoreT var val c x y = StoreT (StateT (Map var val) c x y)
newtype StoreT store var val c x y = StoreT (StateT (store var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowConst r, ArrowReader r,
ArrowEnv var' val', ArrowClosure var' val' env,
ArrowFail e, ArrowExcept e, ArrowState (Map var val),
ArrowEnv var' val', ArrowClosure expr cls,
ArrowFail e, ArrowExcept e, ArrowState (store var val),
ArrowLowerBounded, ArrowRun, ArrowJoin)
runStoreT :: StoreT var val c x y -> c (Map var val, x) (Map var val, y)
runStoreT :: StoreT store var val c x y -> c (store var val, x) (store var val, y)
runStoreT = coerce
{-# INLINE runStoreT #-}
evalStoreT :: Profunctor c => StoreT var val c x y -> c (Map var val, x) y
evalStoreT :: Profunctor c => StoreT store var val c x y -> c (store var val, x) y
evalStoreT f = rmap pi2 (runStoreT f)
execStoreT :: Profunctor c => StoreT var val c x y -> c (Map var val, x) (Map var val)
execStoreT :: Profunctor c => StoreT store var val c x y -> c (store var val, x) (store var val)
execStoreT f = rmap pi1 (runStoreT f)
instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowStore var val (StoreT var val c) where
type Join y (StoreT var val c) = ArrowComplete (Map var val,y) c
instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowStore var val (StoreT Map var val c) where
type Join y (StoreT Map var val c) = ArrowComplete (Map var val,y) c
read (StoreT f) (StoreT g) = StoreT $ proc (var,x) -> do
s <- get -< ()
case M.lookup var s of
......@@ -63,10 +64,10 @@ instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowStore var val (
{-# INLINE read #-}
{-# INLINE write #-}
deriving instance (ArrowComplete (Map var val,y) c) => ArrowComplete y (StoreT var val c)
instance (ArrowApply c, Profunctor c) => ArrowApply (StoreT var val c) where
deriving instance (ArrowComplete (store var val,y) c) => ArrowComplete y (StoreT store var val c)
instance (ArrowApply c, Profunctor c) => ArrowApply (StoreT store var val c) where
app = StoreT (app .# first coerce)
{-# INLINE app #-}
type instance Fix (StoreT var val c) x y = StoreT var val (Fix c (Map var val,x) (Map var val,y))
deriving instance ArrowFix (Underlying (StoreT var val c) x y) => ArrowFix (StoreT var val c x y)
type instance Fix (StoreT store var val c) x y = StoreT store var val (Fix c (store var val,x) (store var val,y))
deriving instance ArrowFix (Underlying (StoreT store var val c) x y) => ArrowFix (StoreT store var val c x y)
......@@ -12,6 +12,7 @@ import Prelude hiding (id,(.),lookup,fail)
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Closure
import Control.Arrow.Store
import Control.Arrow.Fix
import Control.Arrow.Reader
......@@ -32,7 +33,7 @@ import Data.Coerce
newtype TerminatingT c x y = TerminatingT (KleisliT Terminating c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore addr val)
ArrowEnv var val, ArrowClosure expr cls, ArrowStore addr val)
runTerminatingT :: TerminatingT c x y -> c x (Terminating y)
runTerminatingT = coerce
......
......@@ -11,6 +11,7 @@ import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -97,11 +98,10 @@ instance (ArrowComonad f c, ArrowEnv x y c) => ArrowEnv x y (CokleisliT f c) whe
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (ArrowComonad f c, ArrowClosure var val env c) => ArrowClosure var val env (CokleisliT f c) where
ask = lift' Env.ask
local f = lift (lmap costrength2 (Env.local (unlift f)))
{-# INLINE ask #-}
{-# INLINE local #-}
instance (ArrowComonad f c, ArrowClosure expr cls c) => ArrowClosure expr cls (CokleisliT f c) where
type Join y (CokleisliT f c) = Cls.Join y c
apply f = lift (lmap costrength2 (Cls.apply (lmap strength2 (unlift f))))
{-# INLINE apply #-}
instance (ArrowComonad f c, ArrowStore var val c) => ArrowStore var val (CokleisliT f c) where
type Join y (CokleisliT f c) = Store.Join y c
......
......@@ -15,6 +15,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Closure
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -25,6 +26,7 @@ import Control.Arrow.Trans
import Control.Arrow.Transformer.Reader
import Data.Concrete.Closure
import Data.Identifiable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
......@@ -56,9 +58,20 @@ instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowEnv var val (En
env <- Reader.ask -< ()
Reader.local f -< (M.insert var val env, x)
instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowClosure var val (HashMap var val) (EnvT var val c) where
ask = EnvT Reader.ask
local (EnvT f) = EnvT (Reader.local f)
instance (ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashMap var val)) (EnvT var val c) where
type Join y (EnvT var val c) = ()
closure = EnvT $ proc expr -> do
env <- Reader.ask -< ()
returnA -< Closure expr env
apply (EnvT f) = EnvT $ proc (Closure expr env, x) ->
Reader.local f -< (env,(expr,x))
instance (Identifiable var, IsClosure val (HashMap var val), ArrowChoice c, Profunctor c)
=> ArrowLetRec var val (EnvT var val c) where
letRec (EnvT f) = EnvT $ proc (ls,x) -> do
env <- Reader.ask -< ()
let env' = foldr (\(var,val) -> M.insert var (setEnvironment env' val)) env ls
Reader.local f -< (env',x)
instance (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where
app = EnvT $ app .# first coerce
......
......@@ -2,7 +2,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Concrete.Except(ExceptT,runExceptT) where
......@@ -13,6 +12,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -29,17 +29,17 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Arrow transformer that adds exceptions to the result of a computation
newtype ExceptT e c x y = ExceptT (KleisliT (Error e) c x y)
newtype ExceptT e c x y = ExceptT (KleisliT (Error e) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r,ArrowState s,ArrowReader r,ArrowFail err,
ArrowEnv var val, ArrowClosure var val env,ArrowStore var val)
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val)
runExceptT :: ExceptT e c x y -> c x (Error e y)
runExceptT = coerce
{-# INLINE runExceptT #-}
instance (ArrowChoice c, Profunctor c) => ArrowExcept e (ExceptT e c) where
type instance Join y (ExceptT e c) = ()
type Join y (ExceptT e c) = ()
throw = lift $ arr Fail
try f g h = lift $ proc x -> do
......
......@@ -3,8 +3,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Concrete.Failure(FailureT,runFailureT) where
......@@ -14,6 +12,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -33,7 +32,7 @@ import Data.Coerce
newtype FailureT e c x y = FailureT (KleisliT (Error e) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r,ArrowState s,ArrowReader r,ArrowExcept exc,
ArrowEnv var val, ArrowClosure var val env,ArrowStore var val)
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val)
runFailureT :: FailureT e c x y -> c x (Error e y)
runFailureT = coerce
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -13,6 +11,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Closure
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Fail
......@@ -33,7 +32,7 @@ import qualified System.Random as R
newtype RandomT c x y = RandomT (StateT StdGen c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e,
ArrowEnv var val, ArrowClosure var val env, ArrowStore var val)
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val)
runRandomT :: RandomT c x y -> c (StdGen,x) (StdGen,y)
runRandomT = coerce
......
......@@ -15,6 +15,7 @@ import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Fix.Context
import Control.Arrow.Environment
import Control.Arrow.Closure
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -34,7 +35,7 @@ import Data.Coerce
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,
ArrowState s,ArrowReader r',ArrowWriter w,
ArrowEnv var val, ArrowClosure var val env, ArrowStore var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,ArrowContext ctx a)
constT :: (r -> c x y) -> ConstT r c x y
......
......@@ -3,9 +3,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.Transformer.Kleisli where
import Prelude hiding (id,(.),lookup,read,fail)
......@@ -14,6 +11,7 @@ import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -102,11 +100,10 @@ instance (ArrowMonad f c, ArrowEnv x y c) => ArrowEnv x y (KleisliT f c) where
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (ArrowMonad f c, ArrowClosure var val env c) => ArrowClosure var val env (KleisliT f c) where
ask = lift' Env.ask
local f = lift (Env.local (unlift f))
{-# INLINE ask #-}
{-# INLINE local #-}
instance (ArrowMonad f c, ArrowClosure expr cls c) => ArrowClosure expr cls (KleisliT f c) where
type Join y (KleisliT f c) = Cls.Join (f y) c
apply f = lift (Cls.apply (unlift f))
{-# INLINE apply #-}
instance (ArrowMonad f c, ArrowStore var val c) => ArrowStore var val (KleisliT f c) where