Commit 20d0e0a5 authored by Sven Keidel's avatar Sven Keidel

add an continuation transformer to the library

parent 5616e1e3
Pipeline #25443 failed with stages
in 84 minutes and 26 seconds
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Cont where
import Control.Arrow
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowCont c where
type Cont c y :: *
-- | @callCC@ exposes the current continuation. The continuation can be used to escape the current c
callCC :: (Cont c y -> c x y) -> c x y
jump :: Cont c x -> c x y
......@@ -14,6 +14,7 @@ import Prelude hiding ((.),read,Maybe(..))
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader as Reader
......@@ -44,7 +45,7 @@ import GHC.Exts
newtype EnvT (env :: k1 -> k2 -> *) 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)
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun, ArrowCont)
runEnvT :: EnvT env var val c x y -> c (env var val,x) y
runEnvT = coerce
......
......@@ -10,6 +10,7 @@ module Control.Arrow.Transformer.Abstract.Error(ErrorT,runErrorT) where
import Prelude hiding (id,lookup,(.),read,fail)
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
......@@ -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,
ArrowCont, ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowExcept e')
......
......@@ -12,6 +12,7 @@ import Prelude hiding (id,lookup,(.),read,fail)
import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
......@@ -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,
ArrowCont, ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowFail e')
......
......@@ -10,6 +10,7 @@ module Control.Arrow.Transformer.Abstract.Store where
import Prelude hiding (Maybe(..))
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -37,7 +38,7 @@ import Data.Coerce
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,
ArrowCont, ArrowConst r, ArrowReader r,
ArrowEnv var' val', ArrowClosure expr cls,
ArrowFail e, ArrowExcept e, ArrowState (store var val),
ArrowLowerBounded, ArrowRun, ArrowJoin)
......
......@@ -10,6 +10,7 @@ module Control.Arrow.Transformer.Abstract.Terminating(TerminatingT,runTerminatin
import Prelude hiding (id,(.),lookup,fail)
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Environment
import Control.Arrow.Closure
......@@ -32,7 +33,7 @@ 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, ArrowRun,
ArrowConst r, ArrowState s, ArrowReader r,
ArrowCont, ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore addr val)
runTerminatingT :: TerminatingT c x y -> c x (Terminating y)
......
......@@ -12,6 +12,7 @@ import Prelude hiding (id,(.),lookup,read)
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Fix.Context
import Control.Arrow.Environment
......@@ -38,6 +39,7 @@ newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
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
constT f = ConstT (StaticT f)
{-# INLINE constT #-}
......@@ -70,6 +72,12 @@ instance (ArrowApply c, Profunctor c) => ArrowApply (ConstT r c) where
app = ConstT $ StaticT $ \r -> lmap (\(f,x) -> (coerce f r,x)) app
{-# INLINE app #-}
instance ArrowCont c => ArrowCont (ConstT r c) where
type Cont (ConstT r c) y = Cont c y
callCC f = lift $ \r -> callCC $ \k -> unlift (f k) r
jump k = lift $ \_ -> jump k
{-# INLINE callCC #-}
deriving instance ArrowComplete y c => ArrowComplete y (ConstT r c)
type instance Fix (ConstT r c) x y = ConstT r (Fix c x y)
......@@ -11,26 +11,45 @@ import Prelude hiding (id,(.),fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Fix
import Control.Arrow.Fail
import Control.Arrow.Order
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Writer
import Data.Profunctor
import Data.Profunctor.Unsafe
import Unsafe.Coerce
newtype ContT c x y = ContT { runContT :: forall r. c y r -> c x r }
newtype ContT r c x y = ContT { runContT :: c y r -> c x r }
instance (ArrowApply c, Profunctor c) => ArrowCont (ContT r c) where
type Cont (ContT r c) x = c x r
callCC f = lift $ \k -> unlift (f k) k
jump k = lift $ \_ -> k
{-# INLINE callCC #-}
{-# INLINE jump #-}
instance (ArrowApply c, ArrowRun c) => ArrowRun (ContT r c) where
type Run (ContT r c) x y = c y r -> Run c x r
run f x = run $ runContT f x
{-# INLINE run #-}
instance ArrowTrans (ContT r c) where
type Underlying (ContT r c) x y = c y r -> c x r
instance (ArrowApply c, ArrowRun c) => ArrowRun (ContT c) where
type Run (ContT c) x y = c x y
run f = runContT f id
instance ArrowLift (ContT r) where
lift' f = ContT $ \k -> k . f
{-# INLINE lift' #-}
instance Profunctor c => Profunctor (ContT c) where
dimap f g (ContT h) = ContT $ \k -> lmap f (h (lmap g k))
lmap f (ContT h) = ContT $ \k -> lmap f (h k)
rmap g (ContT h) = ContT $ \k -> h (lmap g k)
instance Profunctor c => Profunctor (ContT r c) where
dimap f g h = lift $ \k -> lmap f (unlift h (lmap g k))
lmap f h = lift $ \k -> lmap f (unlift h k)
rmap g h = lift $ \k -> unlift h (lmap g k)
f .# _ = f `seq` unsafeCoerce f
_ #. g = g `seq` unsafeCoerce g
{-# INLINE dimap #-}
......@@ -39,64 +58,65 @@ instance Profunctor c => Profunctor (ContT c) where
{-# INLINE (.#) #-}
{-# INLINE (#.) #-}
instance Category (ContT c) where
id = ContT id
ContT f . ContT g = ContT (g . f)
instance Category (ContT r c) where
id = lift id
f . g = lift (unlift g . unlift f)
{-# INLINE id #-}
{-# INLINE (.) #-}
instance ArrowApply c => Arrow (ContT c) where
arr f = ContT $ \k -> k . arr f
first (ContT f) = ContT $ \k -> proc (b,d) -> f (proc c -> k -< (c,d)) -<< b
second (ContT f) = ContT $ \k -> proc (d,b) -> f (proc c -> k -< (d,c)) -<< b
ContT f &&& ContT g = ContT $ \k -> proc b -> f (proc c1 -> g (proc c2 -> k -< (c1,c2)) -<< b) -<< b
ContT f *** ContT g = ContT $ \k -> proc (b1,b2) -> f (proc c1 -> g (proc c2 -> k -< (c1,c2)) -<< b2) -<< b1
instance ArrowApply c => Arrow (ContT r c) where
arr f = lift $ \k -> k . arr f
first f = lift $ \k -> proc (b,d) -> unlift f (proc c -> k -< (c,d)) -<< b
second f = lift $ \k -> proc (d,b) -> unlift f (proc c -> k -< (d,c)) -<< b
f &&& g = lift $ \k -> proc b -> unlift f (proc c1 -> unlift g (proc c2 -> k -< (c1,c2)) -<< b) -<< b
f *** g = lift $ \k -> proc (b1,b2) -> unlift f (proc c1 -> unlift g (proc c2 -> k -< (c1,c2)) -<< b2) -<< b1
{-# INLINE arr #-}
{-# INLINE first #-}
{-# INLINE second #-}
{-# INLINE (&&&) #-}
{-# INLINE (***) #-}
instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowChoice (ContT c) where
left (ContT f) = ContT $ \k -> f (lmap Left k) ||| (lmap Right k)
right (ContT f) = ContT $ \k -> (lmap Left k) ||| f (lmap Right k)
ContT f ||| ContT g = ContT $ \k -> f k ||| g k
ContT f +++ ContT g = ContT $ \k -> f (lmap Left k) ||| g (lmap Right k)
instance (ArrowApply c, ArrowChoice c, Profunctor c) => ArrowChoice (ContT r c) where
left f = lift $ \k -> unlift f (lmap Left k) ||| lmap Right k
right f = lift $ \k -> lmap Left k ||| unlift f (lmap Right k)
f ||| g = lift $ \k -> unlift f k ||| unlift g k
f +++ g = lift $ \k -> unlift f (lmap Left k) ||| unlift g (lmap Right k)
{-# INLINE left #-}
{-# INLINE right #-}
{-# INLINE (|||) #-}
{-# INLINE (+++) #-}
instance (ArrowApply c, ArrowFix (c x y)) => ArrowFix (ContT c x y) where
instance ArrowApply c => ArrowApply (ContT r c) where
app = lift $ \k -> proc (f,x) -> app -< (unlift f k, x)
{-# INLINE app #-}
-- | Lift and unlift proof the yoneda lemma.
instance Arrow c => ArrowTrans (ContT c) where
type Underlying (ContT c) x y = c x y
lift f = ContT $ \k -> k . f
unlift (ContT f) = f id
{-# INLINE lift #-}
{-# INLINE unlift #-}
type instance Fix (ContT _ c) x y = ContT y (Fix c x y)
instance ArrowFix (c x r) => ArrowFix (ContT r c x y) where
fix f = lift $ \k -> fix $ \g -> unlift1 f (const g) k
{-# INLINE fix #-}
instance ArrowLift ContT where
lift' f = ContT $ \k -> k . f
{-# INLINE lift' #-}
-- instance (ArrowApply c, ArrowJoin c, ArrowComplete r c) => ArrowJoin (ContT r c) where
-- joinSecond _ _ x = lift $ f <⊔> arr g
instance (ArrowApply c, ArrowComplete r c) => ArrowComplete y (ContT r c) where
(<>) f g = lift $ \k -> unlift f k <> unlift g k
instance (ArrowApply c, ArrowState s c) => ArrowState s (ContT c) where
instance (ArrowApply c, ArrowState s c) => ArrowState s (ContT r c) where
get = lift' get
put = lift' put
{-# INLINE get #-}
{-# INLINE put #-}
instance (ArrowApply c, ArrowReader s c) => ArrowReader s (ContT c) where
instance (ArrowApply c, ArrowReader s c) => ArrowReader s (ContT r c) where
ask = lift' ask
local (ContT f) = ContT $ \k -> local (f k)
local f = lift $ \k -> local (unlift f k)
{-# INLINE ask #-}
{-# INLINE local #-}
instance (ArrowApply c, ArrowWriter w c) => ArrowWriter w (ContT c) where
instance (ArrowApply c, ArrowWriter w c) => ArrowWriter w (ContT r c) where
tell = lift' tell
{-# INLINE tell #-}
instance (ArrowApply c, ArrowFail e c) => ArrowFail e (ContT c) where
instance (ArrowApply c, ArrowFail e c) => ArrowFail e (ContT r c) where
fail = lift' fail
{-# INLINE fail #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Kleisli where
......@@ -9,6 +11,7 @@ import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow hiding (ArrowMonad)
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
......@@ -81,6 +84,12 @@ instance (ArrowMonad f c, ArrowApply c) => ArrowApply (KleisliT f c) where
app = lift (app .# first coerce)
{-# INLINE app #-}
instance (ArrowCont c, Monad f, ArrowMonad f c) => ArrowCont (KleisliT f c) where
type Cont (KleisliT f c) y = Cont c (f y)
callCC f = lift $ callCC $ \k -> unlift (f k)
jump k = lift $ lmap (return @f) (jump k)
{-# INLINE callCC #-}
instance (ArrowMonad f c, ArrowState s c) => ArrowState s (KleisliT f c) where
get = lift' State.get
put = lift' State.put
......
......@@ -10,6 +10,7 @@ import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
......@@ -85,6 +86,12 @@ instance (ArrowApply c, Profunctor c) => ArrowApply (ReaderT r c) where
app = lift $ lmap (\(r,(f,b)) -> (unlift f,(r,b))) app
{-# INLINE app #-}
instance (ArrowCont c, Profunctor c) => ArrowCont (ReaderT r c) where
type Cont (ReaderT r c) y = Cont c y
callCC f = lift $ callCC $ \k -> unlift (f k)
jump k = lift $ lmap snd $ jump k
{-# INLINE callCC #-}
instance (Arrow c, Profunctor c) => ArrowReader r (ReaderT r c) where
ask = lift (arr fst)
local f = lift $ lmap snd (unlift f)
......
......@@ -11,6 +11,7 @@ import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
......@@ -103,6 +104,13 @@ instance (ArrowApply c, Profunctor c) => ArrowApply (StateT s c) where
app = lift $ lmap (\(s,(f,b)) -> (unlift f,(s,b))) app
{-# INLINE app #-}
instance (ArrowCont c, Profunctor c) => ArrowCont (StateT s c) where
type Cont (StateT s c) x = Cont c (s,x)
callCC f = lift $ callCC $ \k -> unlift (f k)
jump k = lift $ jump k
{-# INLINE callCC #-}
{-# INLINE jump #-}
instance (Arrow c, Profunctor c) => ArrowState s (StateT s c) where
get = lift (arr (\(a,()) -> (a,a)))
put = lift (arr (\(_,s) -> (s,())))
......
......@@ -24,6 +24,7 @@ import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Fail
import Control.Arrow.Fix
......@@ -42,7 +43,7 @@ newtype ValueT val c x y = ValueT { runValueT :: c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice, ArrowConst r,
ArrowEnv var val', ArrowLetRec var val', ArrowStore addr val',
ArrowExcept exc,ArrowFail e,
ArrowLowerBounded, ArrowReader r, ArrowState s)
ArrowLowerBounded, ArrowReader r, ArrowState s, ArrowCont)
instance (ArrowApply c, Profunctor c) => ArrowApply (ValueT val c) where
app = lift (app .# first coerce)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment