Commit 1f100d2f authored by Sven Keidel's avatar Sven Keidel

remove getEnv and localEnv from ArrowEnv interface

parent b7226241
Pipeline #13975 passed with stages
in 27 minutes and 8 seconds
......@@ -12,7 +12,6 @@ import Prelude hiding (lookup,fail,id)
import Control.Category
import Control.Arrow
import Control.Arrow.Fail
import Control.Arrow.Utils
import Data.String
import Data.Profunctor
......@@ -23,7 +22,7 @@ import GHC.Exts (Constraint)
-- | Arrow-based interface for interacting with environments.
class (Arrow c, Profunctor c) => ArrowEnv var val env c | c -> var, c -> val, c -> env where
class (Arrow c, Profunctor c) => ArrowEnv var val c | c -> var, c -> val where
-- | Type class constraint used by the abstract instances to join arrow computations.
type family Join (c :: * -> * -> *) x y :: Constraint
......@@ -31,35 +30,30 @@ class (Arrow c, Profunctor c) => ArrowEnv var val env c | c -> var, c -> val, c
-- | Lookup a variable in the current environment. If the
-- environment contains a binding of the variable, the first
-- continuation is called and the second computation otherwise.
lookup :: (Join c ((val,x),x) y) => c (val,x) y -> c x y -> c (var,x) y
-- | Retrieve the current environment.
getEnv :: c () env
lookup :: Join c ((val,x),x) y => c (val,x) y -> c x y -> c (var,x) y
-- | Extend an environment with a binding.
extendEnv :: c (var,val,env) env
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.
localEnv :: c x y -> c (env,x) y
local :: c x y -> c (env,x) y
-- | Simpler version of environment lookup.
lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val env c) => c var val
lookup' :: (Join c ((val,var),var) val, Show var, IsString e, ArrowFail e c, ArrowEnv var val c) => c var val
lookup' = lookup'' id
lookup'' :: (Join c ((val,var),var) y, Show var, IsString e, ArrowFail e c, ArrowEnv var val 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 c) => c val y -> c var y
lookup'' f = proc var ->
lookup
(proc (val,_) -> f -< val)
(proc var -> fail -< fromString $ printf "Variable %s not bound" (show var))
-< (var,var)
-- | Run a computation in an extended environment.
extendEnv' :: ArrowEnv var val env c => c a b -> c (var,val,a) b
extendEnv' f = proc (x,y,a) -> do
env <- getEnv -< ()
env' <- extendEnv -< (x,y,env)
localEnv f -< (env',a)
-- | 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)
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
......@@ -18,7 +18,7 @@ import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
......@@ -50,9 +50,7 @@ runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowComplete 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
env <- getEnv -< ()
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
extend' f -< (bs,x)
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
......@@ -69,22 +67,27 @@ instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' f))
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 (EnvT var addr val c) where
type Join (EnvT var addr val c) x y = (Complete y)
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- ask -< ()
env <- Reader.ask -< ()
case do M.lookup var env of
Just val -> f -< (val,x)
Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
getEnv = EnvT ask
extendEnv = EnvT $ ConstT $ StaticT $ \alloc -> lift' $ M.insertBy alloc
localEnv (EnvT f) = EnvT $ local f
extend (EnvT f) = EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ proc (env,(var,val,x)) -> do
env' <- M.insertBy alloc -< (var,val,env)
runReaderT (runConstT alloc f) -< (env',x)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowComplete c, Profunctor c) =>
ArrowClosure var val (Map var addr val) (EnvT var addr val c) where
ask = EnvT Reader.ask
local (EnvT f) = EnvT $ Reader.local f
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' ask
ask = lift' Reader.ask
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))) ^>> Reader.local (runReaderT (f alloc))
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var addr val c) where
app = EnvT (app .# first coerce)
......
......@@ -32,8 +32,10 @@ import Data.Coerce
-- | Allows to describe computations over non-completely ordered types.
-- E.g. allows to join a computation of type '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,
ArrowConst r, ArrowEnv a b e, ArrowStore a b, ArrowFail e, ArrowExcept e, ArrowRun)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e, ArrowExcept e)
runCompletionT :: CompletionT c x y -> c x (FreeCompletion y)
runCompletionT = coerce
......
......@@ -12,12 +12,13 @@ import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Alloc
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
......@@ -33,8 +34,10 @@ import Data.Coerce
-- | 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, ArrowLowerBounded, ArrowComplete)
deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice,
ArrowConst r, ArrowState s,
ArrowEnv var val, ArrowClosure var val env,
ArrowFail e, ArrowExcept e, ArrowLowerBounded, ArrowComplete)
-- | Runs a computation that records a call string. The argument 'k'
-- specifies the maximum length of a call string. All larger call
......@@ -69,5 +72,5 @@ instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' ask
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> local f)
ask = lift' Reader.ask
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> Reader.local f)
......@@ -14,13 +14,13 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Environment
import Control.Arrow.Environment as Env
import Control.Arrow.Fix
import Control.Arrow.Order
......@@ -45,24 +45,28 @@ runEnvT' :: (Arrow c, Profunctor c, Identifiable var) => EnvT var val c x y -> c
runEnvT' f = lmap (first M.fromList) (runEnvT f)
{-# INLINE runEnvT' #-}
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowEnv var val (Map var val) (EnvT var val c) where
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowEnv var val (EnvT var val c) where
type Join (EnvT var val c) x y = Complete y
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- ask -< ()
env <- Reader.ask -< ()
case M.lookup' var env of
Just val -> f -< (val,x)
Nothing -> g -< x
JustNothing val -> (f -< (val,x)) <> (g -< x)
getEnv = EnvT ask
extendEnv = arr $ \(x,y,env) -> M.insert x y env
localEnv (EnvT f) = EnvT (local f)
extend (EnvT f) = EnvT $ proc (var,val,x) -> do
env <- Reader.ask -< ()
Reader.local f -< (M.insert var val env,x)
instance (Identifiable var, UpperBounded val, ArrowChoice c, ArrowComplete c, Profunctor c) => ArrowClosure var val (Map var val) (EnvT var val c) where
ask = EnvT Reader.ask
local (EnvT f) = EnvT (Reader.local f)
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvT var val c) where
app = EnvT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' ask
local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (local (unlift f))
ask = lift' Reader.ask
local f = lift $ lmap (\(env,(r,x)) -> (r,(env,x))) (Reader.local (unlift f))
type instance Fix x y (EnvT var val c) = EnvT var val (Fix (Dom (EnvT var val) x y) (Cod (EnvT var val) x y) c)
deriving instance ArrowFix (Map var val,x) y c => ArrowFix x y (EnvT var val c)
......@@ -33,8 +33,10 @@ 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,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e', ArrowRun)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowExcept e')
runErrorT :: ErrorT e c x y -> c x (Error e y)
runErrorT = coerce
......
......@@ -34,8 +34,10 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Except e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowFail e', ArrowRun)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e')
runExceptT :: ExceptT e c x y -> c x (Except e y)
runExceptT = coerce
......
......@@ -33,8 +33,10 @@ import Data.Coerce
-- | Describes computations that can fail.
newtype FailureT e c x y = FailureT (KleisliT (Failure e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowExcept e', ArrowRun)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowExcept e')
runFailureT :: FailureT e c x y -> c x (Failure e y)
runFailureT = coerce
......
......@@ -31,8 +31,10 @@ import Data.Coerce
-- | Computation that produces a set of results.
newtype PowT c x y = PowT (KleisliT A.Pow c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowEnv a b e', ArrowStore a b, ArrowFail e', ArrowExcept e', ArrowRun)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env, ArrowStore a b,
ArrowFail e', ArrowExcept e')
runPowT :: PowT c x y -> c x (A.Pow y)
runPowT = coerce
......
......@@ -24,7 +24,7 @@ import Control.Arrow.Alloc
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Store as Store
......@@ -43,7 +43,9 @@ import Data.Coerce
newtype ReachingDefsT lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowFail e,ArrowExcept e,ArrowState s,ArrowEnv var val env,
ArrowState s,
ArrowEnv var val, ArrowClosure var val env,
ArrowFail e,ArrowExcept e,
ArrowLowerBounded, ArrowComplete)
reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT lab c x y
......@@ -78,8 +80,8 @@ instance (ArrowApply c,Profunctor c) => ArrowApply (ReachingDefsT lab c) where
app = ReachingDefsT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ReachingDefsT lab c) where
ask = lift' ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (local (unlift f))
ask = lift' Reader.ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (Reader.local (unlift f))
instance ArrowAlloc x y c => ArrowAlloc x y (ReachingDefsT lab c) where
alloc = lift' alloc
......@@ -38,8 +38,10 @@ import Data.Coerce
newtype StoreT var val c x y = StoreT (StateT (Map var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowReader r, ArrowFail e, ArrowExcept e, ArrowEnv var val env,
ArrowConst r, ArrowLowerBounded, ArrowRun)
ArrowConst r, ArrowReader r,
ArrowEnv var' val', ArrowClosure var' val' env,
ArrowFail e, ArrowExcept e,
ArrowLowerBounded, ArrowRun)
runStoreT :: StoreT var val c x y -> c (Map var val, x) (Map var val, y)
runStoreT = coerce
......
......@@ -29,8 +29,9 @@ import Data.Coerce
-- | Arrow that propagates non-terminating computations.
newtype TerminatingT c x y = TerminatingT (KleisliT Terminating c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowState s, ArrowReader r,
ArrowConst r, ArrowRun, ArrowEnv var val env)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure var val env)
runTerminatingT :: TerminatingT c x y -> c x (Terminating y)
runTerminatingT = coerce
......
......@@ -16,7 +16,7 @@ import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Transformer.Reader
......@@ -31,7 +31,7 @@ import Data.Coerce
-- | Records the full call string.
newtype ContourT lab c a b = ContourT (ReaderT [lab] c a b)
deriving (Profunctor,Category,Arrow,ArrowLift,ArrowChoice, ArrowState s,
ArrowEnv x y env, ArrowFail e, ArrowExcept e)
ArrowEnv var val, ArrowClosure var val env, ArrowFail e, ArrowExcept e)
-- | Runs a computation that records a the full call string of the interpreter.
runContourT :: (Arrow c, Profunctor c) => ContourT lab c a b -> c a b
......@@ -60,5 +60,5 @@ instance (ArrowApply c, Profunctor c) => ArrowApply (ContourT lab c) where
app = ContourT $ app .# first coerce
instance ArrowReader r c => ArrowReader r (ContourT lab c) where
ask = lift' ask
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> local f)
ask = lift' Reader.ask
local (ContourT (ReaderT f)) = ContourT $ ReaderT $ ((\(c,(r,x)) -> (r,(c,x))) ^>> Reader.local f)
......@@ -15,13 +15,13 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.Store
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Trans
import Control.Arrow.Except
import Control.Arrow.Environment
import Control.Arrow.Environment as Env
import Control.Arrow.Fix
import Data.Identifiable
......@@ -44,22 +44,26 @@ runEnvT = coerce
runEnvT' :: (Profunctor c, Identifiable var) => EnvT var val c x y -> c ([(var,val)],x) y
runEnvT' f = lmap (first M.fromList) (runEnvT f)
instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowEnv var val (HashMap var val) (EnvT var val c) where
instance (Identifiable var, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT var val c) where
type Join (EnvT var val c) x y = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- ask -< ()
env <- Reader.ask -< ()
case M.lookup var env of
Just val -> f -< (val,x)
Nothing -> g -< x
getEnv = EnvT ask
extendEnv = arr $ \(x,y,env) -> M.insert x y env
localEnv (EnvT f) = EnvT (local f)
extend (EnvT f) = EnvT $ proc (var,val,x) -> do
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 (ArrowApply c,Profunctor c) => ArrowApply (EnvT var val c) where
app = EnvT $ app .# first coerce
instance ArrowReader r c => ArrowReader r (EnvT var val c) where
ask = lift' ask
local (EnvT (ReaderT f)) = EnvT (ReaderT ((\(env,(r,x)) -> (r,(env,x))) ^>> local f))
ask = lift' Reader.ask
local (EnvT (ReaderT f)) = EnvT (ReaderT (lmap (\(env,(r,x)) -> (r,(env,x))) (Reader.local f)))
deriving instance ArrowFix (HashMap var val,x) y c => ArrowFix x y (EnvT var val c)
......@@ -29,9 +29,9 @@ 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)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowState s,ArrowReader r,ArrowFail err,ArrowEnv a b env,ArrowStore var val,ArrowConst r,
ArrowRun)
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)
runExceptT :: ExceptT e c x y -> c x (Error e y)
runExceptT = coerce
......
......@@ -31,7 +31,8 @@ import Data.Coerce
-- | Arrow transformer that adds failure to the result of a computation
newtype FailureT e c x y = FailureT (KleisliT (Error e) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowState s,ArrowReader r,ArrowExcept exc,ArrowEnv a b env,ArrowStore var val,ArrowConst r)
ArrowConst r,ArrowState s,ArrowReader r,ArrowExcept exc,
ArrowEnv var val, ArrowClosure var val env,ArrowStore var val)
runFailureT :: FailureT e c x y -> c x (Error e y)
runFailureT = coerce
......
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Transformer.Concrete.Fixpoint(FixT,runFixT) where
import Prelude hiding ((.))
import Control.Arrow.Fix
import Control.Category
import Control.Arrow
import Data.Profunctor
-- | Arrow transformer that computes the fixpoint in the concrete interpreter.
newtype FixT a b c x y = FixT {runFixT :: c x y} deriving (Profunctor,Category,Arrow,ArrowChoice)
type instance Fix x y (FixT () () c) = FixT x y c
instance (Arrow c, Profunctor c) => ArrowFix x y (FixT x y c) where
fix f = FixT $ runFixT (f (fix f))
......@@ -12,6 +12,7 @@ import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Alloc
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Except
import Control.Arrow.Trans
......@@ -31,9 +32,9 @@ import System.Random(StdGen,Random)
import qualified System.Random as R
newtype RandomT c x y = RandomT (StateT StdGen c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowReader r, ArrowFail e, ArrowExcept e,
ArrowEnv var val env, ArrowStore var val, ArrowRun)
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)
runRandomT :: RandomT c x y -> c (StdGen,x) (StdGen,y)
runRandomT = coerce
......
......@@ -25,7 +25,7 @@ import Control.Arrow.Alloc
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Store as Store
......@@ -40,7 +40,7 @@ import Data.Coerce
newtype ReachingDefsT lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowFail e,ArrowExcept e,ArrowState s,ArrowEnv var val env)
ArrowFail e,ArrowExcept e,ArrowState s,ArrowEnv var val,ArrowClosure var val env)
reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT lab c x y
reachingDefsT = lift
......@@ -72,8 +72,8 @@ instance (ArrowApply c,Profunctor c) => ArrowApply (ReachingDefsT lab c) where
app = ReachingDefsT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ReachingDefsT lab c) where
ask = lift' ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (local (unlift f))
ask = lift' Reader.ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (Reader.local (unlift f))
instance ArrowAlloc x y c => ArrowAlloc x y (ReachingDefsT lab c) where
alloc = lift' alloc
......@@ -31,8 +31,8 @@ import Data.Coerce
-- | Arrow transformer that adds a store to a computation.
newtype StoreT var val c x y = StoreT (StateT (HashMap var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowRun)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e)
-- | Execute a computation and only return the result value and store.
runStoreT :: StoreT var val c x y -> c (HashMap var val, x) (HashMap var val, y)
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Concrete.Trace where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Writer
import Control.Arrow.Trans
import Control.Arrow.Transformer.Writer
import Data.Profunctor
import Data.Sequence (Seq)
import qualified Data.Sequence as S
data Entry a b = Call a | Return b deriving (Show,Eq)
type Log a b = Seq (Entry a b)
newtype TraceT a b c x y = TraceT (WriterT (Log a b) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans, ArrowRun)
runTraceT :: TraceT a b c x y -> c x (Log a b,y)
runTraceT (TraceT (WriterT f)) = f
instance (ArrowApply c,Profunctor c) => ArrowApply (TraceT a b c) where
app = TraceT $ (\(TraceT f,x) -> (f,x)) ^>> app
type instance Fix x y (TraceT x y c) = TraceT x y (Fix (Dom (TraceT x y) x y) (Cod (TraceT x y) x y) c)
instance ArrowFix (Dom (TraceT x y) x y) (Cod (TraceT x y) x y) c => ArrowFix x y (TraceT x y c) where
fix f = TraceT $ fix (unwrap . f . TraceT)
where
unwrap :: (Arrow c,Profunctor c) => TraceT x y c x y -> WriterT (Log x y) c x y
unwrap (TraceT g) = proc x -> do
tell -< S.singleton (Call x)
y <- g -< x
tell -< S.singleton (Return y)
returnA -< y
......@@ -34,7 +34,7 @@ import Data.Coerce
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowComplete,ArrowLowerBounded,ArrowLift,
ArrowState s,ArrowReader r',ArrowWriter w,
ArrowEnv var val env, ArrowStore var val,
ArrowEnv var val, ArrowClosure var val env, ArrowStore var val,
ArrowFail e, ArrowExcept e)
runConstT :: r -> ConstT r c x y -> c x y
......
......@@ -14,8 +14,8 @@ import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Monad
import Control.Arrow.Const
import Control.Arrow.Fix
import Control.Arrow.State
import Control.Arrow.Reader
import Control.Arrow.State as State
import Control.Arrow.Reader as Reader
import Control.Arrow.Environment as Env
import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc
......@@ -93,26 +93,29 @@ instance (ArrowMonad f c, ArrowApply c) => ArrowApply (KleisliT f c) where
{-# INLINE app #-}
instance (ArrowMonad f c, ArrowState s c) => ArrowState s (KleisliT f c) where
get = lift' get
put = lift' put
get = lift' State.get
put = lift' State.put
{-# INLINE get #-}
{-# INLINE put #-}
instance (ArrowMonad f c, ArrowReader r c) => ArrowReader r (KleisliT f c) where
ask = lift' ask
local f = lift (local (unlift f))
ask = lift' Reader.ask