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:
- text
- unordered-containers
- deepseq
- profunctors
flags:
trace:
......@@ -23,7 +24,7 @@ flags:
manual: True
library:
ghc-options: -Wall
ghc-options: -Wall -O2
source-dirs:
- src
when:
......
......@@ -6,8 +6,9 @@ import Prelude hiding ((.))
import Control.Arrow
import Control.Arrow.Utils
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.
--
-- Laws:
......@@ -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' lub f g = joinWith lub (f <<< pi1) (g <<< pi2)
{-# INLINE joinWith' #-}
(<>) :: (ArrowJoin c, Complete y) => c x y -> c x y -> c x y
(<>) = joinWith ()
{-# INLINE (<⊔>) #-}
-- | 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 @@
module Control.Arrow.Alloc where
import Control.Arrow
import Data.Profunctor
-- | 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.
alloc :: c x y
......@@ -6,9 +6,10 @@ module Control.Arrow.Conditional where
import Control.Arrow
import GHC.Exts(Constraint)
import Data.Profunctor
-- | 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 family Join (c :: * -> * -> *) x y :: Constraint
......
......@@ -3,9 +3,10 @@
module Control.Arrow.Const where
import Control.Arrow
import Data.Profunctor
-- | 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.
askConst :: c () r
......@@ -3,11 +3,12 @@
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 => ArrowDeduplicate x y c where
class (Arrow c, Profunctor c) => ArrowDeduplicate x y c where
dedup :: c x y -> c x y
instance ArrowDeduplicate x y (->) where
......
......@@ -15,6 +15,7 @@ import Control.Arrow.Fail
import Control.Arrow.Utils
import Data.String
import Data.Profunctor
import Text.Printf
......@@ -22,7 +23,7 @@ import GHC.Exts (Constraint)
-- | 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 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
-- | 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' = 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'' f = proc var ->
......@@ -51,7 +53,7 @@ lookup'' f = proc var ->
(proc (val,_) -> f -< val)
(proc var -> fail -< fromString $ printf "Variable %s not bound" (show var))
-< (var,var)
{-# INLINE lookup'' #-}
-- | Run a computation in an extended environment.
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
env <- getEnv -< ()
env' <- extendEnv -< (x,y,env)
localEnv f -< (env',a)
{-# INLINE extendEnv' #-}
-- | Add a list of bindings to the given environment.
bindings :: (ArrowChoice c, ArrowEnv var val env c) => c ([(var,val)],env) env
bindings = fold ((\(env,(x,y)) -> (x,y,env)) ^>> extendEnv)
{-# INLINE bindings #-}
......@@ -14,9 +14,10 @@ import Control.Arrow
import Control.Arrow.Utils
import GHC.Exts(Constraint)
import Data.Profunctor
-- | 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 family Join (c :: * -> * -> *) x y :: Constraint
......@@ -33,19 +34,23 @@ class Arrow c => ArrowExcept e c | c -> e where
-- | Simpler version of 'throw'.
throw' :: ArrowExcept () c => c a b
throw' = proc _ -> throw -< ()
{-# INLINE throw' #-}
-- | Simpler version of 'catch'.
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)
{-# INLINE catch' #-}
-- | @'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 (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)
{-# INLINE try #-}
-- | 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
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.
-- 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) =>
tryFirst f g = proc l -> case l of
[] -> g -< ()
a:as -> try (f . pi1) id (tryFirst f g . pi2) -< (a,as)
{-# INLINE tryFirst #-}
-- | A computation that always succeeds
success :: ArrowExcept e c => c a a
success = id
{-# INLINE success #-}
......@@ -10,9 +10,10 @@ import Prelude hiding (fail)
import Control.Arrow
import Control.Monad.Except (MonadError)
import qualified Control.Monad.Except as M
import Data.Profunctor
-- | 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
-- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from.
......@@ -24,3 +25,4 @@ instance MonadError e m => ArrowFail e (Kleisli m) where
-- | Simpler version of 'fail'.
fail' :: ArrowFail () c => c a b
fail' = arr (const ()) >>> fail
{-# INLINE fail' #-}
......@@ -9,9 +9,10 @@ module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
-- | 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.
fix :: (c x y -> c x y) -> c x y
......
......@@ -2,6 +2,7 @@
module Control.Arrow.Random where
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
......@@ -7,9 +7,10 @@ module Control.Arrow.Reader where
import Control.Arrow
import Control.Monad.Reader (MonadReader)
import qualified Control.Monad.Reader as M
import Data.Profunctor
-- | 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.
ask :: c () r
-- | Runs a computation with a new value.
......
......@@ -12,9 +12,10 @@ import Control.Arrow
import Control.Arrow.Utils
import Control.Monad.State (MonadState)
import qualified Control.Monad.State as M
import Data.Profunctor
-- | 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.
get :: c () s
-- | Sets the current state.
......@@ -23,10 +24,12 @@ class Arrow c => ArrowState s c | c -> s where
-- | run computation that modifies the current state.
modify :: ArrowState s c => c (x,s) s -> c x ()
modify f = put <<< f <<< (id &&& const get)
{-# INLINE modify #-}
-- | run computation that modifies the current state.
modify' :: ArrowState s c => c (s,x) s -> c x ()
modify' f = put <<< f <<< (const get &&& id)
{-# INLINE modify' #-}
instance MonadState s m => ArrowState s (Kleisli m) where
get = Kleisli (P.const M.get)
......
......@@ -12,12 +12,13 @@ import Control.Arrow
import Control.Arrow.Fail
import Text.Printf
import Data.String
import Data.Profunctor
import GHC.Exts(Constraint)
-- | Arrow-based interface to describe computations that read from a store.
-- The parameter `y` needs to be exposed, because abstract instances
-- 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
-- | Reads a value from the store. Fails if the binding is not in the current store.
......@@ -32,3 +33,4 @@ read' = proc var ->
read (proc (val,_) -> returnA -< val)
(proc var -> fail -< fromString $ printf "variable %s not bound" (show var))
-< (var,var)
{-# INLINE read' #-}
......@@ -2,16 +2,17 @@
module Control.Arrow.Trans where
import Control.Arrow
import Data.Profunctor
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.
class ArrowTrans t where
type Dom t x y :: *
type Cod t x y :: *
lift :: Arrow 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)
lift :: (Arrow c, Profunctor c) => c (Dom t x y) (Cod t x y) -> t c 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
......@@ -31,6 +31,12 @@ import Data.Identifiable
import Data.Abstract.FiniteMap (Map)
import qualified Data.Abstract.FiniteMap as M
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
-- are approximated by a mapping from variables to addresses and a
......@@ -40,10 +46,10 @@ import Data.Abstract.Maybe(Maybe(..))
-- 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 )
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)
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
runEnvT alloc f =
let EnvT f' = proc (bs,x) -> do
......@@ -51,6 +57,7 @@ runEnvT alloc f =
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
in (const (M.empty) &&& id) ^>> runReaderT (runConstT alloc f')
{-# INLINE runEnvT #-}
instance ArrowTrans (EnvT var addr val) where
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
instance ArrowLift (EnvT var addr val) where
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
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
......@@ -70,27 +78,27 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) =>
Just val -> f -< (val,x)
JustNothing val -> joined f g -< ((val,x),x)
Nothing -> g -< x
{-# INLINE lookup #-}
getEnv = EnvT ask
{-# INLINE getEnv #-}
extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc
{-# INLINE extendEnv #-}
localEnv (EnvT f) = EnvT $ local f
{-# INLINE localEnv #-}
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' ask
{-# INLINE ask #-}
local (EnvT (ConstT (StaticT f))) =
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
app = EnvT $ (\(EnvT f,x) -> (f,x)) ^>> app
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
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)
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 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
import Prelude hiding ((.),id,lookup,fail)
import Control.Applicative
import Control.Arrow
import Control.Arrow.Deduplicate
import Control.Arrow.Environment as Env
......@@ -21,6 +22,7 @@ import Control.Arrow.Fix
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Profunctor
import Data.Abstract.FreeCompletion
import Data.Monoidal
import Data.Order hiding (lub)
......@@ -29,71 +31,109 @@ import Data.Order hiding (lub)
-- E.g. allows to join a computation of type 'c x [y]'.
newtype CompletionT c x y = CompletionT { runCompletionT :: c x (FreeCompletion y) }
instance (Profunctor c, Arrow c) => Profunctor (CompletionT c) where
dimap f g h = lift $ dimap f (fmap g) (unlift h)
{-# INLINE dimap #-}
lmap f h = lift $ lmap f (unlift h)
{-# INLINE lmap #-}
rmap g h = lift $ rmap (fmap g) (unlift h)
{-# INLINE rmap #-}
instance ArrowTrans CompletionT where
type Dom CompletionT x y = x
type Cod CompletionT x y = FreeCompletion y
lift = CompletionT
{-# INLINE lift #-}
unlift = runCompletionT
{-# INLINE unlift #-}
instance ArrowLift CompletionT where
lift' f = CompletionT (f >>> arr Lower)
lift' f = CompletionT (rmap Lower f)
{-# INLINE lift' #-}
instance ArrowChoice c => Category (CompletionT c) where
instance (ArrowChoice c, Profunctor c) => Category (CompletionT c) where
id = lift' id
{-# INLINE id #-}
CompletionT f . CompletionT g = CompletionT $ proc x -> do
g' <- g -< x
case g' of
Lower a -> f -< a
Top -> returnA -< Top
{-# INLINE (.) #-}
instance ArrowChoice c => Arrow (CompletionT c) where
instance (ArrowChoice c, Profunctor c) => Arrow (CompletionT c) where
arr = lift' . arr
first f = lift $ first (unlift f) >>^ strength1
second f = lift $ second (unlift f) >>^ strength2
instance ArrowChoice c => ArrowChoice (CompletionT c) where
left (CompletionT f) = CompletionT $ left f >>^ strength1
right (CompletionT f) = CompletionT $ right f >>^ strength2
instance (ArrowApply c, ArrowChoice c) => ArrowApply (CompletionT c) where
app = CompletionT $ first runCompletionT ^>> app
instance (ArrowChoice c, ArrowState s c) => ArrowState s (CompletionT c) where
{-# INLINE arr #-}
first f = lift $ rmap strength1 (first (unlift f))
{-# INLINE first #-}
second f = lift $ rmap strength2 (second (unlift f))
{-# INLINE second #-}
f *** g = lift $ rmap (uncurry (liftA2 (,))) (unlift f *** unlift g)
{-# INLINE (***) #-}
f &&& g = lift $ rmap (uncurry (liftA2 (,))) (unlift f &&& unlift g)
{-# INLINE (&&&) #-}
instance (ArrowChoice c, Profunctor c) => ArrowChoice (CompletionT c) where
left (CompletionT f) = CompletionT $ rmap strength1 (left f)
{-# INLINE left #-}
right (CompletionT f) = CompletionT $ rmap strength2 (right f)
{-# INLINE right #-}
instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowApply (CompletionT c) where
app = CompletionT $ lmap (first runCompletionT) app
{-# INLINE app #-}
instance (ArrowChoice c, ArrowState s c, Profunctor c) => ArrowState s (CompletionT c) where
get = lift' get
{-# INLINE get #-}
put = lift' put
{-# INLINE put #-}
instance (ArrowChoice c, ArrowFail e c) => ArrowFail e (CompletionT c) where
fail = lift' fail
{-# INLINE fail #-}
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (CompletionT c) where
ask = lift' ask
{-# INLINE ask #-}
local f = lift (local (unlift f))
{-# INLINE local #-}
instance (ArrowChoice c, ArrowEnv var val env c) => ArrowEnv var val env (CompletionT c) where
type Join (CompletionT c) x y = Env.Join c (Dom CompletionT x y) (Cod CompletionT x y)
lookup f g = lift (lookup (unlift f) (unlift g))
{-# INLINE lookup #-}
getEnv = lift' getEnv
{-# INLINE getEnv #-}
extendEnv = lift' extendEnv
{-# INLINE extendEnv #-}
localEnv f = lift (localEnv (unlift f))
{-# INLINE localEnv #-}
instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (CompletionT c) where
type Join (CompletionT c) x y = Exc.Join c (Dom CompletionT x y) (Cod CompletionT x y)
throw = lift' throw
{-# INLINE throw #-}
catch f g = lift $ catch (unlift f) (unlift g)
{-# INLINE catch #-}
finally f g = lift $ finally (unlift f) (unlift g)
{-# INLINE finally #-}
instance ArrowChoice c => ArrowDeduplicate x y (CompletionT c) where
instance (ArrowChoice c, Profunctor c) => ArrowDeduplicate x y (CompletionT c) where
dedup = returnA
{-# INLINE dedup #-}
type instance Fix x y (CompletionT c) = CompletionT (Fix (Dom CompletionT x y) (Cod CompletionT x y) c)
instance (ArrowChoice c, ArrowFix (Dom CompletionT x y) (Cod CompletionT x y) c) => ArrowFix x y (CompletionT c) where
fix = liftFix
{-# INLINE fix #-}
instance (ArrowChoice c, ArrowJoin c) => ArrowJoin (CompletionT c) where
joinWith lub f g = lift $ joinWith join (unlift f) (unlift g)
where join (Lower x) (Lower y) = Lower (lub x y)
join Top _ = Top
join _ Top = Top
{-# INLINE joinWith #-}
deriving instance PreOrd (c x (FreeCompletion y)) => PreOrd (CompletionT c x y)
deriving instance LowerBounded (c x (FreeCompletion y)) => LowerBounded (CompletionT c x y)
......
......@@ -27,50 +27,49 @@ import Control.Category
import Data.Label
import Data.Order
import Data.CallString
import Data.Profunctor
-- | Records the k-bounded call string. Meant to be used in
-- conjunction with 'Abstract.BoundedEnvironment'.
newtype ContourT lab c a b = ContourT (ReaderT (CallString lab) c a b)
deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice, ArrowState s,
ArrowEnv x y env, ArrowFail e, ArrowExcept e, ArrowJoin)
-- | Runs a computation that records a call string. The argument 'k'
-- specifies the maximum length of a call string. All larger call
-- strings are truncated to at most 'k' elements.
runContourT :: Arrow c => Int -> ContourT lab c a b -> c a b
runContourT k (ContourT (ReaderT f)) = (\a -> (empty k,a)) ^>> f
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
{-# INLINE runContourT #-}
type instance Fix x y (ContourT lab c) = ContourT lab (Fix x y c)
instance (ArrowFix x y c, ArrowApply c, HasLabel x lab) => 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
-- Pushes the label of the last argument on the call string and truncate the call string in case it reached the maximum length
fix f = ContourT $ ReaderT $ proc (c,x) -> fix (unwrap c . f . wrap) -<< x
where
wrap :: Arrow c => c x y -> ContourT lab c x y
wrap :: (Arrow c, Profunctor c) => c x y -> ContourT lab c x y
wrap = lift'
unwrap :: (HasLabel x lab, Arrow c) => CallString lab -> ContourT lab c x y -> c x y
unwrap :: (HasLabel x lab, Arrow c, Profunctor c) => CallString lab -> ContourT lab c x y -> c x y
unwrap c (ContourT (ReaderT f')) = proc x -> do
y <- f' -< (push (label x) c,x)
returnA -< y
{-# INLINE fix #-}
instance Arrow c => ArrowAlloc (var,val,env) (var,CallString lab) (ContourT lab c) where
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 $ proc (l,(x,_,_)) -> returnA -< (x,l)
alloc = ContourT $ ReaderT $ arr $ \(l,(x,_,_)) -> (x,l)
{-# INLINE alloc #-}
instance ArrowApply c => ArrowApply (ContourT lab c) where
app = ContourT $ (\(ContourT f,x) -> (f,x)) ^>> app
instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT $ lmap (\(ContourT f,x) -> (f,x)) app
{-# INLINE app #-}
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' ask
{-# INLINE ask #-}
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> local f)
deriving instance Arrow c => Category (ContourT lab c)
deriving instance Arrow c => Arrow (ContourT lab c)
deriving instance ArrowLift (ContourT lab)
deriving instance ArrowChoice c => ArrowChoice (ContourT lab c)
deriving instance ArrowState s c => ArrowState s (ContourT lab c)
deriving instance ArrowEnv x y env c => ArrowEnv x y env (ContourT lab c)
deriving instance ArrowFail e c => ArrowFail e (ContourT lab c)
deriving instance ArrowExcept e c => ArrowExcept e (ContourT lab c)
deriving instance ArrowJoin c => ArrowJoin (ContourT lab c)
{-# INLINE local #-}
deriving instance PreOrd (c (CallString lab,x) y) => PreOrd (ContourT lab c x y)
deriving instance LowerBounded (c (CallString lab,x) y) => LowerBounded (ContourT lab c x y)
......
......@@ -30,16 +30,21 @@ import Control.Arrow.Environment
import Control.Arrow.Fix
import Control.Arrow.Abstract.Join
import Data.Profunctor
newtype EnvT var val c x y = EnvT (ReaderT (Map var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowJoin,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k)
runEnvT :: Arrow 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
{-# INLINE runEnvT #-}
runEnvT' :: (Arrow 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