Commit db4e0fb4 authored by Sven Keidel's avatar Sven Keidel

inline all typeclass methods and implement Profunctor arrows

parent 11c79d36
...@@ -15,6 +15,7 @@ dependencies: ...@@ -15,6 +15,7 @@ dependencies:
- text - text
- unordered-containers - unordered-containers
- deepseq - deepseq
- profunctors
flags: flags:
trace: trace:
...@@ -23,7 +24,7 @@ flags: ...@@ -23,7 +24,7 @@ flags:
manual: True manual: True
library: library:
ghc-options: -Wall ghc-options: -Wall -O2
source-dirs: source-dirs:
- src - src
when: when:
......
...@@ -6,8 +6,9 @@ import Prelude hiding ((.)) ...@@ -6,8 +6,9 @@ import Prelude hiding ((.))
import Control.Arrow import Control.Arrow
import Control.Arrow.Utils import Control.Arrow.Utils
import Data.Order(Complete(..)) import Data.Order(Complete(..))
import Data.Profunctor
class Arrow c => ArrowJoin c where class (Arrow c, Profunctor c) => ArrowJoin c where
-- | Join two arrow computation with the provided upper bound operator. -- | Join two arrow computation with the provided upper bound operator.
-- --
-- Laws: -- Laws:
...@@ -18,10 +19,11 @@ class Arrow c => ArrowJoin c where ...@@ -18,10 +19,11 @@ class Arrow c => ArrowJoin c where
joinWith' :: ArrowJoin c => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y joinWith' :: ArrowJoin c => (y -> y -> y) -> c x y -> c x' y -> c (x,x') y
joinWith' lub f g = joinWith lub (f <<< pi1) (g <<< pi2) joinWith' lub f g = joinWith lub (f <<< pi1) (g <<< pi2)
{-# INLINE joinWith' #-}
(<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y (<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y
(<>) = joinWith () (<>) = joinWith ()
{-# INLINE (<⊔>) #-}
-- | Joins a list of arguments. Use it with idiom brackets: -- | Joins a list of arguments. Use it with idiom brackets:
-- @ -- @
......
module Control.Arrow.Abstract.Terminating where
import Control.Arrow
import Data.Abstract.Terminating
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowTerminating c where
throwTerminating :: c (Terminating x) x
catchTerminating :: c x y -> c x (Terminating y)
...@@ -3,8 +3,9 @@ ...@@ -3,8 +3,9 @@
module Control.Arrow.Alloc where module Control.Arrow.Alloc where
import Control.Arrow import Control.Arrow
import Data.Profunctor
-- | Arrow-based interface for allocating addresses. -- | Arrow-based interface for allocating addresses.
class Arrow c => ArrowAlloc x y c where class (Arrow c, Profunctor c) => ArrowAlloc x y c where
-- | Allocates a new address. -- | Allocates a new address.
alloc :: c x y alloc :: c x y
...@@ -6,9 +6,10 @@ module Control.Arrow.Conditional where ...@@ -6,9 +6,10 @@ module Control.Arrow.Conditional where
import Control.Arrow import Control.Arrow
import GHC.Exts(Constraint) import GHC.Exts(Constraint)
import Data.Profunctor
-- | Arrow based interface to implement conditionals. -- | Arrow based interface to implement conditionals.
class Arrow c => ArrowCond v c | c -> v where class (Arrow c, Profunctor c) => ArrowCond v c | c -> v where
-- | Type class constraint used by the abstract instances to join arrow computations. -- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint type family Join (c :: * -> * -> *) x y :: Constraint
......
...@@ -3,9 +3,10 @@ ...@@ -3,9 +3,10 @@
module Control.Arrow.Const where module Control.Arrow.Const where
import Control.Arrow import Control.Arrow
import Data.Profunctor
-- | Arrow-based interface that gives access to a constant value. -- | Arrow-based interface that gives access to a constant value.
class Arrow c => ArrowConst r c | c -> r where class (Arrow c, Profunctor c) => ArrowConst r c | c -> r where
-- | Retrieve the constant value. -- | Retrieve the constant value.
askConst :: c () r askConst :: c () r
...@@ -3,11 +3,12 @@ ...@@ -3,11 +3,12 @@
module Control.Arrow.Deduplicate where module Control.Arrow.Deduplicate where
import Control.Arrow import Control.Arrow
import Data.Profunctor
-- | Arrow-based interface to deduplicate the result /set/ of a computation. -- | Arrow-based interface to deduplicate the result /set/ of a computation.
-- This is required by the 'Control.Arrow.Transformer.Abstract.Powerset.PowT' -- This is required by the 'Control.Arrow.Transformer.Abstract.Powerset.PowT'
-- arrow transformer. -- arrow transformer.
class Arrow c => ArrowDeduplicate x y c where class (Arrow c, Profunctor c) => ArrowDeduplicate x y c where
dedup :: c x y -> c x y dedup :: c x y -> c x y
instance ArrowDeduplicate x y (->) where instance ArrowDeduplicate x y (->) where
......
...@@ -15,6 +15,7 @@ import Control.Arrow.Fail ...@@ -15,6 +15,7 @@ import Control.Arrow.Fail
import Control.Arrow.Utils import Control.Arrow.Utils
import Data.String import Data.String
import Data.Profunctor
import Text.Printf import Text.Printf
...@@ -22,7 +23,7 @@ import GHC.Exts (Constraint) ...@@ -22,7 +23,7 @@ import GHC.Exts (Constraint)
-- | Arrow-based interface for interacting with environments. -- | Arrow-based interface for interacting with environments.
class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where class (Arrow c, Profunctor c) => ArrowEnv var val env c | c -> var, c -> val, c -> env where
-- | Type class constraint used by the abstract instances to join arrow computations. -- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint type family Join (c :: * -> * -> *) x y :: Constraint
...@@ -44,6 +45,7 @@ class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where ...@@ -44,6 +45,7 @@ class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where
-- | Simpler version of environment lookup. -- | Simpler version of environment lookup.
lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c var val lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c var val
lookup' = lookup'' id lookup' = lookup'' id
{-# INLINE lookup' #-}
lookup'' :: (Join c ((val,var),var) y, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c val y -> c var y lookup'' :: (Join c ((val,var),var) y, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c val y -> c var y
lookup'' f = proc var -> lookup'' f = proc var ->
...@@ -51,7 +53,7 @@ lookup'' f = proc var -> ...@@ -51,7 +53,7 @@ lookup'' f = proc var ->
(proc (val,_) -> f -< val) (proc (val,_) -> f -< val)
(proc var -> fail -< fromString $ printf "Variable %s not bound" (show var)) (proc var -> fail -< fromString $ printf "Variable %s not bound" (show var))
-< (var,var) -< (var,var)
{-# INLINE lookup'' #-}
-- | Run a computation in an extended environment. -- | Run a computation in an extended environment.
extendEnv' :: ArrowEnv var val env c => c a b -> c (var,val,a) b extendEnv' :: ArrowEnv var val env c => c a b -> c (var,val,a) b
...@@ -59,7 +61,9 @@ extendEnv' f = proc (x,y,a) -> do ...@@ -59,7 +61,9 @@ extendEnv' f = proc (x,y,a) -> do
env <- getEnv -< () env <- getEnv -< ()
env' <- extendEnv -< (x,y,env) env' <- extendEnv -< (x,y,env)
localEnv f -< (env',a) localEnv f -< (env',a)
{-# INLINE extendEnv' #-}
-- | Add a list of bindings to the given environment. -- | Add a list of bindings to the given environment.
bindings :: (ArrowChoice c, ArrowEnv var val env c) => c ([(var,val)],env) env bindings :: (ArrowChoice c, ArrowEnv var val env c) => c ([(var,val)],env) env
bindings = fold ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv) bindings = fold ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv)
{-# INLINE bindings #-}
...@@ -14,9 +14,10 @@ import Control.Arrow ...@@ -14,9 +14,10 @@ import Control.Arrow
import Control.Arrow.Utils import Control.Arrow.Utils
import GHC.Exts(Constraint) import GHC.Exts(Constraint)
import Data.Profunctor
-- | Arrow-based interface for exception handling. -- | Arrow-based interface for exception handling.
class Arrow c => ArrowExcept e c | c -> e where class (Arrow c, Profunctor c) => ArrowExcept e c | c -> e where
-- | Type class constraint used by the abstract instances to join arrow computations. -- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint type family Join (c :: * -> * -> *) x y :: Constraint
...@@ -33,19 +34,23 @@ class Arrow c => ArrowExcept e c | c -> e where ...@@ -33,19 +34,23 @@ class Arrow c => ArrowExcept e c | c -> e where
-- | Simpler version of 'throw'. -- | Simpler version of 'throw'.
throw' :: ArrowExcept () c => c a b throw' :: ArrowExcept () c => c a b
throw' = proc _ -> throw -< () throw' = proc _ -> throw -< ()
{-# INLINE throw' #-}
-- | Simpler version of 'catch'. -- | Simpler version of 'catch'.
catch' :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c e y -> c x y catch' :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c e y -> c x y
catch' f g = catch f (pi2 >>> g) catch' f g = catch f (pi2 >>> g)
{-# INLINE catch' #-}
-- | @'try' f g h@ executes @f@, if it succeeds the result is passed to -- | @'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@. -- @g@, if it fails the original input is passed to @h@.
try :: (Join c (x,(x,e)) z, ArrowExcept e c) => c x y -> c y z -> c x z -> c x z try :: (Join c (x,(x,e)) z, ArrowExcept e c) => c x y -> c y z -> c x z -> c x z
try f g h = catch (f >>> g) (pi1 >>> h) try f g h = catch (f >>> g) (pi1 >>> h)
{-# INLINE try #-}
-- | Picks the first computation that does not throw an exception. -- | Picks the first computation that does not throw an exception.
(<+>) :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c x y -> c x y (<+>) :: (Join c (x,(x,e)) y, ArrowExcept e c) => c x y -> c x y -> c x y
f <+> g = catch f (pi1 >>> g) f <+> g = catch f (pi1 >>> g)
{-# INLINE (<+>) #-}
-- | @'tryFirst' f g -< l@ executes @f@ on elements of @l@ until one of them does not throw an exception. -- | @'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. -- In case @f@ throws an exception for all elements of @l@, @g@ is executed.
...@@ -53,7 +58,9 @@ tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) => ...@@ -53,7 +58,9 @@ tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) =>
tryFirst f g = proc l -> case l of tryFirst f g = proc l -> case l of
[] -> g -< () [] -> g -< ()
a:as -> try (f . pi1) id (tryFirst f g . pi2) -< (a,as) a:as -> try (f . pi1) id (tryFirst f g . pi2) -< (a,as)
{-# INLINE tryFirst #-}
-- | A computation that always succeeds -- | A computation that always succeeds
success :: ArrowExcept e c => c a a success :: ArrowExcept e c => c a a
success = id success = id
{-# INLINE success #-}
...@@ -10,9 +10,10 @@ import Prelude hiding (fail) ...@@ -10,9 +10,10 @@ import Prelude hiding (fail)
import Control.Arrow import Control.Arrow
import Control.Monad.Except (MonadError) import Control.Monad.Except (MonadError)
import qualified Control.Monad.Except as M import qualified Control.Monad.Except as M
import Data.Profunctor
-- | Arrow-based interface for computations that can fail. -- | Arrow-based interface for computations that can fail.
class Arrow c => ArrowFail e c | c -> e where class (Arrow c, Profunctor c) => ArrowFail e c | c -> e where
-- | Causes the computation to fail. In contrast to -- | Causes the computation to fail. In contrast to
-- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from. -- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from.
...@@ -24,3 +25,4 @@ instance MonadError e m => ArrowFail e (Kleisli m) where ...@@ -24,3 +25,4 @@ instance MonadError e m => ArrowFail e (Kleisli m) where
-- | Simpler version of 'fail'. -- | Simpler version of 'fail'.
fail' :: ArrowFail () c => c a b fail' :: ArrowFail () c => c a b
fail' = arr (const ()) >>> fail fail' = arr (const ()) >>> fail
{-# INLINE fail' #-}
...@@ -9,9 +9,10 @@ module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where ...@@ -9,9 +9,10 @@ module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where
import Control.Arrow import Control.Arrow
import Control.Arrow.Trans import Control.Arrow.Trans
import Data.Profunctor
-- | Arrow-based interface for describing fixpoint computations. -- | Arrow-based interface for describing fixpoint computations.
class Arrow c => ArrowFix x y c where class (Arrow c, Profunctor c) => ArrowFix x y c where
-- | Computes the fixpoint of an arrow computation. -- | Computes the fixpoint of an arrow computation.
fix :: (c x y -> c x y) -> c x y fix :: (c x y -> c x y) -> c x y
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
module Control.Arrow.Random where module Control.Arrow.Random where
import Control.Arrow import Control.Arrow
import Data.Profunctor
class Arrow c => ArrowRand v c where class (Arrow c, Profunctor c) => ArrowRand v c where
random :: c () v random :: c () v
...@@ -7,9 +7,10 @@ module Control.Arrow.Reader where ...@@ -7,9 +7,10 @@ module Control.Arrow.Reader where
import Control.Arrow import Control.Arrow
import Control.Monad.Reader (MonadReader) import Control.Monad.Reader (MonadReader)
import qualified Control.Monad.Reader as M import qualified Control.Monad.Reader as M
import Data.Profunctor
-- | Arrow-based interface for read-only values. -- | Arrow-based interface for read-only values.
class Arrow c => ArrowReader r c | c -> r where class (Arrow c, Profunctor c) => ArrowReader r c | c -> r where
-- | Retrieves the current read-only value. -- | Retrieves the current read-only value.
ask :: c () r ask :: c () r
-- | Runs a computation with a new value. -- | Runs a computation with a new value.
......
...@@ -12,9 +12,10 @@ import Control.Arrow ...@@ -12,9 +12,10 @@ import Control.Arrow
import Control.Arrow.Utils import Control.Arrow.Utils
import Control.Monad.State (MonadState) import Control.Monad.State (MonadState)
import qualified Control.Monad.State as M import qualified Control.Monad.State as M
import Data.Profunctor
-- | Arrow-based interface to describe stateful computations. -- | Arrow-based interface to describe stateful computations.
class Arrow c => ArrowState s c | c -> s where class (Arrow c, Profunctor c) => ArrowState s c | c -> s where
-- | Retrieves the current state. -- | Retrieves the current state.
get :: c () s get :: c () s
-- | Sets the current state. -- | Sets the current state.
...@@ -23,10 +24,12 @@ class Arrow c => ArrowState s c | c -> s where ...@@ -23,10 +24,12 @@ class Arrow c => ArrowState s c | c -> s where
-- | run computation that modifies the current state. -- | run computation that modifies the current state.
modify :: ArrowState s c => c (x,s) s -> c x () modify :: ArrowState s c => c (x,s) s -> c x ()
modify f = put <<< f <<< (id &&& const get) modify f = put <<< f <<< (id &&& const get)
{-# INLINE modify #-}
-- | run computation that modifies the current state. -- | run computation that modifies the current state.
modify' :: ArrowState s c => c (s,x) s -> c x () modify' :: ArrowState s c => c (s,x) s -> c x ()
modify' f = put <<< f <<< (const get &&& id) modify' f = put <<< f <<< (const get &&& id)
{-# INLINE modify' #-}
instance MonadState s m => ArrowState s (Kleisli m) where instance MonadState s m => ArrowState s (Kleisli m) where
get = Kleisli (P.const M.get) get = Kleisli (P.const M.get)
......
...@@ -12,12 +12,13 @@ import Control.Arrow ...@@ -12,12 +12,13 @@ import Control.Arrow
import Control.Arrow.Fail import Control.Arrow.Fail
import Text.Printf import Text.Printf
import Data.String import Data.String
import Data.Profunctor
import GHC.Exts(Constraint) import GHC.Exts(Constraint)
-- | Arrow-based interface to describe computations that read from a store. -- | Arrow-based interface to describe computations that read from a store.
-- The parameter `y` needs to be exposed, because abstract instances -- The parameter `y` needs to be exposed, because abstract instances
-- may need to join on `y`. -- may need to join on `y`.
class Arrow c => ArrowStore var val c | c -> var, c -> val where class (Arrow c, Profunctor c) => ArrowStore var val c | c -> var, c -> val where
type family Join (c :: * -> * -> *) x y :: Constraint type family Join (c :: * -> * -> *) x y :: Constraint
-- | Reads a value from the store. Fails if the binding is not in the current store. -- | Reads a value from the store. Fails if the binding is not in the current store.
...@@ -32,3 +33,4 @@ read' = proc var -> ...@@ -32,3 +33,4 @@ read' = proc var ->
read (proc (val,_) -> returnA -< val) read (proc (val,_) -> returnA -< val)
(proc var -> fail -< fromString $ printf "variable %s not bound" (show var)) (proc var -> fail -< fromString $ printf "variable %s not bound" (show var))
-< (var,var) -< (var,var)
{-# INLINE read' #-}
...@@ -2,16 +2,17 @@ ...@@ -2,16 +2,17 @@
module Control.Arrow.Trans where module Control.Arrow.Trans where
import Control.Arrow import Control.Arrow
import Data.Profunctor
class ArrowLift t where class ArrowLift t where
lift' :: Arrow c => c x y -> t c x y lift' :: (Arrow c, Profunctor c) => c x y -> t c x y
-- | Lifts an inner computation into an arrow transformer and vice versa. -- | Lifts an inner computation into an arrow transformer and vice versa.
class ArrowTrans t where class ArrowTrans t where
type Dom t x y :: * type Dom t x y :: *
type Cod t x y :: * type Cod t x y :: *
lift :: Arrow c => c (Dom t x y) (Cod t x y) -> t c x y lift :: (Arrow c, Profunctor c) => c (Dom t x y) (Cod t x y) -> t c x y
unlift :: Arrow c => t c x y -> c (Dom t x y) (Cod t x y) unlift :: (Arrow c, Profunctor c) => t c x y -> c (Dom t x y) (Cod t x y)
type family Rep c x y type family Rep c x y
...@@ -31,6 +31,12 @@ import Data.Identifiable ...@@ -31,6 +31,12 @@ 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
-- | 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.
-- | 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
...@@ -40,10 +46,10 @@ import Data.Abstract.Maybe(Maybe(..)) ...@@ -40,10 +46,10 @@ import Data.Abstract.Maybe(Maybe(..))
-- Furthermore, closures and environments are defined mutually -- Furthermore, closures and environments are defined mutually
-- 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 = 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 )
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)
runEnvT :: (Show var, Identifiable var, Identifiable addr, Complete val, ArrowChoice c) runEnvT :: (Show var, Identifiable var, Identifiable addr, Complete val, 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
...@@ -51,6 +57,7 @@ runEnvT alloc f = ...@@ -51,6 +57,7 @@ runEnvT alloc f =
env' <- bindings -< (bs,env) env' <- bindings -< (bs,env)
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')
{-# INLINE runEnvT #-}
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
...@@ -60,8 +67,9 @@ instance ArrowTrans (EnvT var addr val) where ...@@ -60,8 +67,9 @@ 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))
{-# INLINE lift' #-}
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) => instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice 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 (c (Map var addr val,x) y) type Join (EnvT var addr val c) x y = Complete (c (Map var addr val,x) y)
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
...@@ -70,27 +78,27 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) => ...@@ -70,27 +78,27 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) =>
Just val -> f -< (val,x) Just val -> f -< (val,x)
JustNothing val -> joined f g -< ((val,x),x) JustNothing val -> joined f g -< ((val,x),x)
Nothing -> g -< x Nothing -> g -< x
{-# INLINE lookup #-}
getEnv = EnvT ask getEnv = EnvT ask
{-# INLINE getEnv #-}
extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc
{-# INLINE extendEnv #-}
localEnv (EnvT f) = EnvT $ local f localEnv (EnvT f) = EnvT $ local f
{-# INLINE localEnv #-}
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' ask ask = lift' ask
{-# INLINE ask #-}
local (EnvT (ConstT (StaticT f))) = local (EnvT (ConstT (StaticT f))) =
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))
{-# INLINE local #-}
instance ArrowApply c => ArrowApply (EnvT var addr val c) where instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app app = EnvT $ lmap (\(EnvT f,x) -> (f,x)) app
{-# INLINE app #-}
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)
deriving instance Arrow c => Category (EnvT var addr val c)
deriving instance Arrow c => Arrow (EnvT var addr val c)
deriving instance ArrowChoice c => ArrowChoice (EnvT var addr val c)
deriving instance ArrowState s c => ArrowState s (EnvT var addr val c)
deriving instance ArrowFail e c => ArrowFail e (EnvT var addr val c)
deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
deriving instance ArrowJoin c => ArrowJoin (EnvT var addr val c)
deriving instance PreOrd (c ((Map var addr val),x) y) => PreOrd (EnvT var addr val c x y) deriving instance PreOrd (c ((Map var addr val),x) y) => PreOrd (EnvT var addr val c x y)
deriving instance Complete (c ((Map var addr val),x) y) => Complete (EnvT var addr val c x y) deriving instance Complete (c ((Map var addr val),x) y) => Complete (EnvT var addr val c x y)
......
...@@ -9,6 +9,7 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT(..)) where ...@@ -9,6 +9,7 @@ module Control.Arrow.Transformer.Abstract.Completion(CompletionT(..)) where